Annotation of gforth/objects.fs, revision 1.2

1.1       anton       1: \ yet another Forth objects extension
                      2: 
                      3: \ written by Anton Ertl 1996
                      4: \ public domain
                      5: 
1.2     ! anton       6: \ This (in combination with compat/struct.fs) is in ANS Forth (with an
        !             7: \ environmental dependence on case insensitivity; convert everything
        !             8: \ to upper case for state sensitive systems).
1.1       anton       9: 
1.2     ! anton      10: \ If you don't use Gforth, you have to load compat/struct.fs first.
        !            11: \ compat/struct.fs and this file together use the following words:
        !            12: 
        !            13: \ from CORE :
        !            14: \ : 1- + swap invert and ; Create >r rot r@ dup , r> DOES> @ chars
        !            15: \ cells 2* here - allot drop over execute 2dup move 2! 2@ ! ['] >body
        !            16: \ ' Variable POSTPONE immediate ." . cr Constant +!
        !            17: \ from CORE-EXT :
        !            18: \ tuck :noname compile, true 
        !            19: \ from BLOCK-EXT :
        !            20: \ \ 
        !            21: \ from DOUBLE :
        !            22: \ 2Constant 2VARIABLE 
        !            23: \ from EXCEPTION :
        !            24: \ throw catch 
        !            25: \ from EXCEPTION-EXT :
        !            26: \ abort" 
        !            27: \ from FILE :
        !            28: \ ( 
        !            29: \ from FLOAT :
        !            30: \ floats 
        !            31: \ from FLOAT-EXT :
        !            32: \ dfloats sfloats 
        !            33: \ from MEMORY :
        !            34: \ allocate resize 
        !            35: \ from TOOLS-EXT :
        !            36: \ [IF] [THEN]
        !            37: 
        !            38: \ ---------------------------------------
        !            39: \ MANUAL:
1.1       anton      40: 
                     41: \ A class is defined like this:
                     42: 
                     43: \ <parent> class
                     44: \   ... field <name>
                     45: \   ...
                     46: 
                     47: \   ... inst-var <name>
                     48: \   ...
                     49: 
                     50: \ selector <name>
                     51: 
                     52: \ :noname ( ... object -- ... )
                     53: \   ... ;
                     54: \ method <name> \ new method
                     55: \ ...
                     56: 
                     57: \ :noname ( ... object -- ... )
                     58: \   ... ;
                     59: \ overrides <name> \ existing method
                     60: \ ...
                     61: 
                     62: \ end-class <name>
                     63: 
                     64: \ you can write fields, inst-vars, selectors, methods and overrides in
                     65: \ any order.
                     66: 
                     67: \ A call of a method looks like this:
                     68: 
                     69: \ ... <object> <method>
                     70: 
                     71: \ (<object> just needs to reside on the stack, there's no need to name it).
                     72: 
                     73: \ Instead of defining a method with ':noname ... ;', you can define it
                     74: \ also with 'm: ... ;m'. The difference is that with ':noname' the
                     75: \ "self" object is on the top of stack; with 'm:' you can get it with
                     76: \ 'this'. You should use 'this' only in an 'm:' method even though the
                     77: \ sample implementation does not enforce this.
                     78: 
                     79: \ The difference between a field and and inst-var is that the field
                     80: \ refers to an object at the top of data stack (i.e. a field has the
                     81: \ stack effect (object -- addr), whereas the inst-var refers to this
                     82: \ (i.e., it has the stack effect ( -- addr )); obviously, an inst-var
                     83: \ can only be used in an 'm:' method.
                     84: 
                     85: \ 'method' defines a new method selector and binds a method to it.
                     86: 
                     87: \ 'selector' defines a new method selector without binding a method to
                     88: \ it (you can use this to define abstract classes)
                     89: 
                     90: \ 'overrides' binds a different method (than the parent class) to an
                     91: \ existing method selector.
                     92: 
                     93: \ If you want to perform early binding, you can do it like this:
                     94: 
                     95: \ ... <object> [bind] <class> <method> \ compilation
                     96: \ ... <object> bind  <class> <method> \ interpretation
                     97: 
                     98: \ You can get at the method from the method selector and the class like
                     99: \ this:
                    100: 
                    101: \ bind' <class> <method>
                    102: \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
                    103: 
                    104: \ needs struct.fs
                    105: 
                    106: \ helper words
                    107: 
                    108: : -rot ( a b c -- c a b )
                    109:     rot rot ;
                    110: 
                    111: : perform ( ... addr -- ... )
                    112:     @ execute ;
                    113: 
                    114: : save-mem     ( addr1 u -- addr2 u ) \ gforth
                    115:     \ copy a memory block into a newly allocated region in the heap
                    116:     swap >r
                    117:     dup allocate throw
                    118:     swap 2dup r> -rot move ;
                    119: 
                    120: : extend-mem   ( addr1 u1 u -- addr addr2 u2 )
                    121:     \ extend memory block allocated from the heap by u aus
                    122:     \ the (possibly reallocated piece is addr2 u2, the extension is at addr )
                    123:     over >r + dup >r resize throw
                    124:     r> over r> + -rot ;
                    125: 
                    126: : 2,   ( w1 w2 -- ) \ gforth
                    127:     here 2 cells allot 2! ;
                    128: 
                    129: : const-field ( size1 align1 -- size2 align2 )
                    130:     1 cells: field
                    131: does> ( addr -- w )
                    132:     @ + @ ;
                    133: 
                    134: struct
                    135:     1 cells: field object-map
                    136: end-struct object-struct
                    137: 
                    138: struct
                    139:     2 cells: field class-map
                    140:     const-field class-instance-size \ aus
                    141:     const-field class-instance-align \ aus
                    142: end-struct class-struct
                    143: 
                    144: 2variable current-map \ address and size (in aus) of the current map
                    145: 
                    146: : class ( class -- size align )
                    147:     dup class-map 2@ save-mem current-map 2!
                    148:     dup class-instance-size
                    149:     swap class-instance-align ;
                    150: 
                    151: : end-class ( size align "name" -- )
                    152:     create
                    153:     current-map 2@ 2,
                    154:     swap , , ;
                    155: 
                    156: : no-method ( -- )
                    157:     abort" no method defined" ;
                    158: 
                    159: : method ( xt "name" -- )
                    160:     \ define method and selector
                    161:     current-map 2@ ( xt map-addr map-size )
                    162:     create dup ,
                    163:     1 cells extend-mem current-map 2!
                    164:     !
                    165: does> ( ... object -- ... )
                    166:     ( object addr )
                    167:     @ over ( object-map ) @ + ( object xtp ) perform ;
                    168: 
                    169: : selector ( "name" -- )
                    170:     \ define a method selector for later overriding in subclasses
                    171:     ['] no-method method ;
                    172: 
                    173: : override! ( xt method-xt -- )
                    174:     >body @ current-map 2@ drop + ! ;
                    175: 
                    176: : overrides ( xt "selector" -- )
                    177:     \ replace default method "method" with xt
                    178:     ' override! ;
                    179: 
                    180: : alloc-instance ( class -- object )
                    181:     \ make a new, (almost) uninitialized instance of a class
                    182:     dup class-instance-size allocate throw
                    183:     swap class-map 2@ drop over ( object-map ) ! ;
                    184: 
                    185: \ this/self, instance variables etc.
                    186: 
                    187: variable thisp
                    188: : this ( -- object )
                    189:     \ rename this into self if you are a Smalltalk fiend
                    190:     thisp @ ;
                    191: 
                    192: : m: ( -- xt colon-sys ) ( run-time: object -- )
                    193:     :noname 
                    194:     POSTPONE this
                    195:     POSTPONE >r
                    196:     POSTPONE thisp
                    197:     POSTPONE ! ;
                    198: 
                    199: : ;m ( colon-sys -- ) ( run-time: -- )
                    200:     POSTPONE r>
                    201:     POSTPONE thisp
                    202:     POSTPONE !
                    203:     POSTPONE ; ; immediate
                    204: 
                    205: : catch ( ... xt -- ... n )
                    206:     \ make it safe to call CATCH within a method.
                    207:     \ should also be done with all words containing CATCH.
                    208:     this >r catch r> thisp ! ;
                    209: 
                    210: : inst-var ( size1 align1 size align -- size2 align2 )
                    211:     field
                    212: does> ( -- addr )
                    213:     ( addr1 ) @ this + ;
                    214: 
                    215: \ early binding stuff
                    216: 
                    217: \ this is not generally used, only where you want to do something like
                    218: \ superclass method invocation (so that you don't have to name your methods)
                    219: 
                    220: : (bind) ( class method-xt -- xt )
                    221:     >body @ swap class-map 2@ drop + @ ;
                    222: 
                    223: : bind' ( "class" "method" -- xt )
                    224:     ' >body ' (bind) ;
                    225: 
                    226: : bind ( ... object "class" "method" -- ... )
                    227:     bind' execute ;
                    228: 
                    229: : [bind] ( compile-time: "class" "method" -- ; run-time: ... object -- ... )
                    230:     bind' compile, ; immediate
                    231: 
                    232: \ the object class
                    233: 
                    234: 0 0 save-mem current-map 2!
                    235: object-struct \ no class to inherit from, so we have to do this manually
                    236: :noname ( object -- )
                    237:     ." object:" dup . ." class:" object-map @ . ;
                    238: method print
                    239: end-class object
                    240: 
                    241: \ examples
                    242: true [if]
                    243: cr object alloc-instance print
                    244: 
                    245: object class
                    246: :noname ( object -- )
                    247:     drop ." undefined" ;
                    248: overrides print
                    249: end-class nothing
                    250: 
                    251: nothing alloc-instance constant undefined
                    252: 
                    253: cr undefined print
                    254: 
                    255: \ instance variables and this
                    256: object class
                    257: 1 cells: inst-var count-n
                    258: m: ( object -- )
                    259:     count-n @ . ;m
                    260: overrides print
                    261: m: ( object -- )
                    262:    0 count-n ! ;m
                    263: method init
                    264: m: ( object -- )
                    265:     1 count-n +! ;m
                    266: method inc
                    267: end-class counter
                    268: 
                    269: counter alloc-instance constant counter1
                    270: 
                    271: cr
                    272: counter1 init
                    273: counter1 print
                    274: counter1 inc
                    275: counter1 print
                    276: counter1 inc
                    277: counter1 inc
                    278: counter1 inc
                    279: counter1 print
                    280: counter1 print
                    281: 
                    282: \ examples of static binding
                    283: 
                    284: cr undefined bind object print
                    285: : object-print ( object -- )
                    286:     [bind] object print ;
                    287: 
                    288: cr undefined object-print
                    289: [then]

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>