Annotation of gforth/objects.fs, revision 1.4

1.1       anton       1: \ yet another Forth objects extension
                      2: 
1.3       anton       3: \ written by Anton Ertl 1996, 1997
1.4     ! anton       4: \ public domain; NO WARRANTY
1.1       anton       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: \ compat/struct.fs and this file together use the following words:
                     11: 
                     12: \ from CORE :
1.4     ! anton      13: \ : 1- + swap invert and ; DOES> @ immediate drop Create rot dup , >r
        !            14: \ r> IF ELSE THEN over chars aligned cells 2* here - allot execute
        !            15: \ POSTPONE ?dup 2dup move Variable 2@ 2! ! ['] >body = 2drop ' r@ +!
        !            16: \ Constant recurse 1+ BEGIN 0= UNTIL negate Literal ." .
1.2       anton      17: \ from CORE-EXT :
1.4     ! anton      18: \ tuck pick nip true <> 0> erase Value :noname compile, 
1.2       anton      19: \ from BLOCK-EXT :
                     20: \ \ 
                     21: \ from DOUBLE :
1.3       anton      22: \ 2Constant 
1.2       anton      23: \ from EXCEPTION :
                     24: \ throw catch 
                     25: \ from EXCEPTION-EXT :
                     26: \ abort" 
                     27: \ from FILE :
                     28: \ ( 
                     29: \ from FLOAT :
1.4     ! anton      30: \ faligned floats 
1.2       anton      31: \ from FLOAT-EXT :
1.4     ! anton      32: \ dfaligned dfloats sfaligned sfloats 
1.3       anton      33: \ from LOCAL :
                     34: \ TO 
1.2       anton      35: \ from MEMORY :
1.3       anton      36: \ allocate resize free 
                     37: \ from SEARCH :
                     38: \ get-order set-order wordlist get-current set-current 
1.2       anton      39: 
1.1       anton      40: \ needs struct.fs
                     41: 
                     42: \ helper words
                     43: 
                     44: : -rot ( a b c -- c a b )
                     45:     rot rot ;
                     46: 
1.4     ! anton      47: : under+ ( a b c -- a+c b )
1.3       anton      48:     rot + swap ;
                     49: 
1.1       anton      50: : perform ( ... addr -- ... )
                     51:     @ execute ;
                     52: 
1.3       anton      53: : ?dup-if ( compilation: -- orig ; run-time: n -- n|  )
                     54:     POSTPONE ?dup POSTPONE if ; immediate
                     55: 
1.1       anton      56: : save-mem     ( addr1 u -- addr2 u ) \ gforth
                     57:     \ copy a memory block into a newly allocated region in the heap
                     58:     swap >r
                     59:     dup allocate throw
                     60:     swap 2dup r> -rot move ;
                     61: 
1.3       anton      62: : resize ( a-addr1 u -- a-addr2 ior ) \ gforth
                     63:     over
                     64:     if
                     65:        resize
                     66:     else
                     67:        nip allocate
                     68:     then ;
                     69: 
1.1       anton      70: : extend-mem   ( addr1 u1 u -- addr addr2 u2 )
                     71:     \ extend memory block allocated from the heap by u aus
1.4     ! anton      72:     \ the (possibly reallocated) piece is addr2 u2, the extension is at addr
1.1       anton      73:     over >r + dup >r resize throw
                     74:     r> over r> + -rot ;
                     75: 
1.3       anton      76: \ data structures
1.1       anton      77: 
                     78: struct
1.4     ! anton      79:     cell% field object-map
        !            80: end-struct object%
1.1       anton      81: 
                     82: struct
1.4     ! anton      83:     cell% 2* field interface-map
        !            84:     cell%    field interface-map-offset \ aus
1.3       anton      85:       \ difference between where interface-map points and where
                     86:       \ object-map points (0 for non-classes)
1.4     ! anton      87:     cell%    field interface-offset \ aus
1.3       anton      88:       \ offset of interface map-pointer in class-map (0 for classes)
1.4     ! anton      89: end-struct interface%
1.3       anton      90: 
1.4     ! anton      91: interface%
        !            92:     cell%    field class-parent
        !            93:     cell%    field class-wordlist \ instance variables and other private words
        !            94:     cell% 2* field class-inst-size \ size and alignment
        !            95: end-struct class%
1.1       anton      96: 
1.3       anton      97: struct
1.4     ! anton      98:     cell% field selector-offset \ the offset within the (interface) map
        !            99:     cell% field selector-interface \ the interface offset
        !           100: end-struct selector%
1.3       anton     101: 
                    102: \ maps are not defined explicitly; they have the following structure:
                    103: 
                    104: \ pointers to interface maps (for classes) <- interface-map points here
1.4     ! anton     105: \ interface%/class% pointer                <- (object-)map  points here
1.3       anton     106: \ xts of methods 
                    107: 
1.1       anton     108: 
1.3       anton     109: \ code
1.1       anton     110: 
1.3       anton     111: \ selectors and methods
                    112: 
                    113: variable current-interface
1.1       anton     114: 
                    115: : no-method ( -- )
1.3       anton     116:     true abort" no method defined for this object/selector combination" ;
                    117: 
                    118: : do-class-method ( -- )
                    119: does> ( ... object -- ... )
                    120:     ( object )
                    121:     selector-offset @ over object-map @ + ( object xtp ) perform ;
                    122: 
                    123: : do-interface-method ( -- )
                    124: does> ( ... object -- ... )
                    125:     ( object selector-body )
                    126:     2dup selector-interface @ ( object selector-body object interface-offset )
                    127:     swap object-map @ + @ ( object selector-body map )
                    128:     swap selector-offset @ + perform ;
1.1       anton     129: 
                    130: : method ( xt "name" -- )
1.3       anton     131:     \ define selector with method xt
                    132:     create
                    133:     current-interface @ interface-map 2@ ( xt map-addr map-size )
                    134:     dup current-interface @ interface-map-offset @ - ,
                    135:     1 cells extend-mem current-interface @ interface-map 2! ! ( )
                    136:     current-interface @ interface-offset @ dup ,
                    137:     ( 0<> ) if
                    138:        do-interface-method
                    139:     else
                    140:        do-class-method
                    141:     then ;
1.1       anton     142: 
                    143: : selector ( "name" -- )
                    144:     \ define a method selector for later overriding in subclasses
                    145:     ['] no-method method ;
                    146: 
1.3       anton     147: : interface-override! ( xt sel-xt interface-map -- )
                    148:     \ xt is the new method for the selector sel-xt in interface-map
                    149:     swap >body ( xt map selector-body )
                    150:     selector-offset @ + ! ;
                    151: 
                    152: : class->map ( class -- map )
                    153:     \ compute the (object-)map for the class
                    154:     dup interface-map 2@ drop swap interface-map-offset @ + ;
                    155: 
                    156: : unique-interface-map ( class-map offset -- )
                    157:     \ if the interface at offset in class map is the same as its parent,
                    158:     \ copy it to make it unique; used for implementing a copy-on-write policy
                    159:     over @ class-parent @ class->map ( class-map offset parent-map )
                    160:     over + @ >r  \ the map for the interface for the parent
                    161:     + dup @ ( mapp map )
                    162:     dup r> =
                    163:     if
                    164:        @ interface-map 2@ save-mem drop
                    165:        swap !
                    166:     else
                    167:        2drop
                    168:     then ;
                    169: 
                    170: : class-override! ( xt sel-xt class-map -- )
                    171:     \ xt is the new method for the selector sel-xt in class-map
                    172:     over >body ( xt sel-xt class-map selector-body )
                    173:     selector-interface @ ( xt sel-xt class-map offset )
                    174:     ?dup-if \ the selector is for an interface
                    175:        2dup unique-interface-map
                    176:        + @
                    177:     then
                    178:     interface-override! ;
1.1       anton     179: 
                    180: : overrides ( xt "selector" -- )
1.3       anton     181:     \ replace default method "method" in the current class with xt
                    182:     \ must not be used during an interface definition
                    183:     ' current-interface @ class->map class-override! ;
                    184: 
                    185: \ interfaces
                    186: 
                    187: \ every interface gets a different offset; the latest one is stored here
                    188: variable last-interface-offset 0 last-interface-offset !
                    189: 
                    190: : interface ( -- )
1.4     ! anton     191:     interface% %allot >r
1.3       anton     192:     0 0 r@ interface-map 2!
                    193:     -1 cells last-interface-offset +!
                    194:     last-interface-offset @ r@ interface-offset !
                    195:     0 r@ interface-map-offset !
                    196:     r> current-interface ! ;
                    197: 
                    198: : end-interface-noname ( -- interface )
                    199:     current-interface @ ;
                    200: 
                    201: : end-interface ( "name" -- )
                    202:     \ name execution: ( -- interface )
                    203:     end-interface-noname constant ;
                    204: 
                    205: \ classes
                    206: 
                    207: : add-class-order ( n1 class -- wid1 ... widn n+n1 )
                    208:     dup >r class-parent @
                    209:     ?dup-if
                    210:        recurse \ first add the search order for the parent class
                    211:     then
                    212:     r> class-wordlist @ swap 1+ ;
                    213: 
                    214: : push-order ( class -- )
                    215:     \ add the class's wordlist to the search-order (in front)
                    216:     >r get-order r> add-class-order set-order ;
                    217: 
1.4     ! anton     218: : class ( parent-class -- align size )
        !           219:     class% %allot >r
1.3       anton     220:     dup interface-map 2@ save-mem r@ interface-map 2!
                    221:     dup interface-map-offset @ r@ interface-map-offset !
                    222:     r@ dup class->map !
                    223:     0 r@ interface-offset !
                    224:     dup r@ class-parent !
                    225:     wordlist r@ class-wordlist !
                    226:     r@ current-interface !
                    227:     r> push-order
                    228:     class-inst-size 2@ ;
                    229: 
                    230: : remove-class-order ( wid1 ... widn n+n1 class -- n1 )
                    231:     \ note: no checks, whether the wordlists are correct
                    232:     begin
                    233:        >r nip 1-
                    234:        r> class-parent @ dup 0=
                    235:     until
                    236:     drop ;
                    237: 
                    238: : drop-order ( class -- )
                    239:     \ note: no checks, whether the wordlists are correct
                    240:     >r get-order r> remove-class-order set-order ;
                    241: 
1.4     ! anton     242: : end-class-noname ( align size -- class )
1.3       anton     243:     current-interface @ dup drop-order class-inst-size 2!
                    244:     end-interface-noname ;
                    245: 
1.4     ! anton     246: : end-class ( align size "name" -- )
1.3       anton     247:     \ name execution: ( -- class )
                    248:     end-class-noname constant ;
1.1       anton     249: 
1.3       anton     250: \ visibility control
                    251: 
                    252: variable public-wordlist
                    253: 
1.4     ! anton     254: : protected ( -- )
1.3       anton     255:     current-interface @ class-wordlist @
                    256:     dup get-current <>
1.4     ! anton     257:     if \ we are not protected already
1.3       anton     258:        get-current public-wordlist !
                    259:     then
                    260:     set-current ;
                    261: 
                    262: : public ( -- )
                    263:     public-wordlist @ set-current ;
                    264: 
                    265: \ classes that implement interfaces
                    266: 
                    267: : front-extend-mem ( addr1 u1 u -- addr addr2 u2 )
                    268:     \ extend memory block allocated from the heap by u aus, with the
                    269:     \ old stuff coming at the end
                    270:     2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 )
                    271:     dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 )
                    272:     free throw
                    273:     r> dup r> ;
                    274:     
                    275: : implementation ( interface -- )
                    276:     dup interface-offset @ ( interface offset )
                    277:     current-interface @ interface-map-offset @ negate over - dup 0>
                    278:     if \ the interface does not fit in the present class-map
                    279:        >r current-interface @ interface-map 2@
                    280:        r@ front-extend-mem
                    281:        current-interface @ interface-map 2!
                    282:        r@ erase
                    283:        dup negate current-interface @ interface-map-offset !
                    284:        r>
                    285:     then ( interface offset n )
                    286:     drop >r
                    287:     interface-map 2@ save-mem drop ( map )
                    288:     current-interface @ dup interface-map 2@ drop
                    289:     swap interface-map-offset @ + r> + ! ;
1.1       anton     290: 
                    291: \ this/self, instance variables etc.
                    292: 
1.3       anton     293: \ rename "this" into "self" if you are a Smalltalk fiend
                    294: 0 value this ( -- object )
                    295: : to-this ( object -- )
                    296:     TO this ;
                    297: 
                    298: \ another implementation, if you don't have (fast) values
                    299: \ variable thisp
                    300: \ : this ( -- object )
                    301: \     thisp @ ;
                    302: \ : to-this ( object -- )
                    303: \     thisp ! ;
1.1       anton     304: 
                    305: : m: ( -- xt colon-sys ) ( run-time: object -- )
                    306:     :noname 
                    307:     POSTPONE this
                    308:     POSTPONE >r
1.3       anton     309:     POSTPONE to-this ;
1.1       anton     310: 
                    311: : ;m ( colon-sys -- ) ( run-time: -- )
                    312:     POSTPONE r>
1.3       anton     313:     POSTPONE to-this
1.1       anton     314:     POSTPONE ; ; immediate
                    315: 
                    316: : catch ( ... xt -- ... n )
                    317:     \ make it safe to call CATCH within a method.
                    318:     \ should also be done with all words containing CATCH.
1.3       anton     319:     this >r catch r> to-this ;
                    320: 
                    321: \ the following is a bit roundabout; this is caused by the standard
                    322: \ disallowing to change the compilation wordlist between CREATE and
                    323: \ DOES> (see RFI 3)
                    324: 
1.4     ! anton     325: : inst-something ( align1 size1 align size xt "name" -- align2 size2 )
1.3       anton     326:     \ xt ( -- ) typically is for a DOES>-word
                    327:     get-current >r
                    328:     current-interface @ class-wordlist @ set-current
                    329:     >r create-field r> execute
                    330:     r> set-current ;
1.1       anton     331: 
1.3       anton     332: : do-inst-var ( -- )
                    333: does> \ name execution: ( -- addr )
1.1       anton     334:     ( addr1 ) @ this + ;
                    335: 
1.4     ! anton     336: : inst-var ( align1 offset1 align size "name" -- align2 offset2 )
1.3       anton     337:     \ name execution: ( -- addr )
                    338:     ['] do-inst-var inst-something ;
                    339: 
                    340: : do-inst-value ( -- )
                    341: does> \ name execution: ( -- w )
                    342:     ( addr1 ) @ this + @ ;
                    343: 
1.4     ! anton     344: : inst-value ( align1 offset1 "name" -- align2 offset2 )
1.3       anton     345:     \ name execution: ( -- w )
                    346:     \ a cell-sized value-flavoured instance field
1.4     ! anton     347:     cell% ['] do-inst-value inst-something ;
1.3       anton     348: 
                    349: : <to-inst> ( w xt -- )
                    350:     >body @ this + ! ;
                    351: 
                    352: : [to-inst] ( compile-time: "name" -- ; run-time: w -- )
                    353:     ' >body @ POSTPONE literal
                    354:     POSTPONE this
                    355:     POSTPONE +
                    356:     POSTPONE ! ; immediate
                    357: 
1.4     ! anton     358: \ class binding stuff
1.1       anton     359: 
1.3       anton     360: : <bind> ( class selector-xt -- xt )
                    361:     >body swap class->map over selector-interface @
                    362:     ?dup-if
                    363:        + @
                    364:     then
                    365:     swap selector-offset @ + @ ;
1.1       anton     366: 
1.3       anton     367: : bind' ( "class" "selector" -- xt )
                    368:     ' execute ' <bind> ;
1.1       anton     369: 
1.3       anton     370: : bind ( ... object "class" "selector" -- ... )
1.1       anton     371:     bind' execute ;
                    372: 
1.3       anton     373: : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... )
1.1       anton     374:     bind' compile, ; immediate
                    375: 
1.4     ! anton     376: : current' ( "selector" -- xt )
        !           377:     current-interface @ ' <bind> ;
        !           378: 
        !           379: : [current] ( compile-time: "selector" -- ; run-time: ... object -- ... )
        !           380:     current' compile, ; immediate
        !           381: 
        !           382: : [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... )
1.3       anton     383:     \ same as `[bind] "parent" "selector"', where "parent" is the
                    384:     \ parent class of the current class
                    385:     current-interface @ class-parent @ ' <bind> compile, ; immediate
                    386: 
1.1       anton     387: \ the object class
                    388: 
1.3       anton     389: \ because OBJECT has no parent class, we have to build it by hand
                    390: \ (instead of with class)
                    391: 
1.4     ! anton     392: class% %allot current-interface !
        !           393: current-interface 1 cells save-mem current-interface @ interface-map 2!
        !           394: 0 current-interface @ interface-map-offset !
        !           395: 0 current-interface @ interface-offset !
        !           396: 0 current-interface @ class-parent !
        !           397: wordlist current-interface @ class-wordlist !
        !           398: object%
        !           399: current-interface @ push-order
1.3       anton     400: 
1.1       anton     401: :noname ( object -- )
1.3       anton     402:     drop ;
                    403: method construct ( ... object -- )
                    404: 
                    405: :noname ( object -- )
                    406:     ." object:" dup . ." class:" object-map @ @ . ;
1.1       anton     407: method print
1.3       anton     408: 
1.1       anton     409: end-class object
                    410: 
1.3       anton     411: \ constructing objects
1.1       anton     412: 
1.3       anton     413: : init-object ( ... class object -- )
                    414:     swap class->map over object-map ! ( ... object )
                    415:     construct ;
                    416: 
                    417: : xt-new ( ... class xt -- object )
1.4     ! anton     418:     \ makes a new object, using XT ( align size -- addr ) to allocate memory
1.3       anton     419:     over class-inst-size 2@ rot execute
                    420:     dup >r init-object r> ;
                    421: 
                    422: : dict-new ( ... class -- object )
                    423:     \ makes a new object HERE in dictionary
1.4     ! anton     424:     ['] %allot xt-new ;
1.3       anton     425: 
                    426: : heap-new ( ... class -- object )
                    427:     \ makes a new object in ALLOCATEd memory
1.4     ! anton     428:     ['] %alloc xt-new ;

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