File:  [gforth] / gforth / objects.fs
Revision 1.4: download - view: text, annotated - select for diffs
Mon Jun 23 15:53:53 1997 UTC (26 years, 9 months ago) by anton
Branches: MAIN
CVS tags: HEAD
changed compat/struct.fs and objects.fs for <align size> representation
refixed -trainling (in prim)
gforth.ds bug fixes
fixed/worked around declarations in forth.h

    1: \ yet another Forth objects extension
    2: 
    3: \ written by Anton Ertl 1996, 1997
    4: \ public domain; NO WARRANTY
    5: 
    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).
    9: 
   10: \ compat/struct.fs and this file together use the following words:
   11: 
   12: \ from CORE :
   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 ." .
   17: \ from CORE-EXT :
   18: \ tuck pick nip true <> 0> erase Value :noname compile, 
   19: \ from BLOCK-EXT :
   20: \ \ 
   21: \ from DOUBLE :
   22: \ 2Constant 
   23: \ from EXCEPTION :
   24: \ throw catch 
   25: \ from EXCEPTION-EXT :
   26: \ abort" 
   27: \ from FILE :
   28: \ ( 
   29: \ from FLOAT :
   30: \ faligned floats 
   31: \ from FLOAT-EXT :
   32: \ dfaligned dfloats sfaligned sfloats 
   33: \ from LOCAL :
   34: \ TO 
   35: \ from MEMORY :
   36: \ allocate resize free 
   37: \ from SEARCH :
   38: \ get-order set-order wordlist get-current set-current 
   39: 
   40: \ needs struct.fs
   41: 
   42: \ helper words
   43: 
   44: : -rot ( a b c -- c a b )
   45:     rot rot ;
   46: 
   47: : under+ ( a b c -- a+c b )
   48:     rot + swap ;
   49: 
   50: : perform ( ... addr -- ... )
   51:     @ execute ;
   52: 
   53: : ?dup-if ( compilation: -- orig ; run-time: n -- n|  )
   54:     POSTPONE ?dup POSTPONE if ; immediate
   55: 
   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: 
   62: : resize ( a-addr1 u -- a-addr2 ior ) \ gforth
   63:     over
   64:     if
   65: 	resize
   66:     else
   67: 	nip allocate
   68:     then ;
   69: 
   70: : extend-mem	( addr1 u1 u -- addr addr2 u2 )
   71:     \ extend memory block allocated from the heap by u aus
   72:     \ the (possibly reallocated) piece is addr2 u2, the extension is at addr
   73:     over >r + dup >r resize throw
   74:     r> over r> + -rot ;
   75: 
   76: \ data structures
   77: 
   78: struct
   79:     cell% field object-map
   80: end-struct object%
   81: 
   82: struct
   83:     cell% 2* field interface-map
   84:     cell%    field interface-map-offset \ aus
   85:       \ difference between where interface-map points and where
   86:       \ object-map points (0 for non-classes)
   87:     cell%    field interface-offset \ aus
   88:       \ offset of interface map-pointer in class-map (0 for classes)
   89: end-struct interface%
   90: 
   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%
   96: 
   97: struct
   98:     cell% field selector-offset \ the offset within the (interface) map
   99:     cell% field selector-interface \ the interface offset
  100: end-struct selector%
  101: 
  102: \ maps are not defined explicitly; they have the following structure:
  103: 
  104: \ pointers to interface maps (for classes) <- interface-map points here
  105: \ interface%/class% pointer                <- (object-)map  points here
  106: \ xts of methods 
  107: 
  108: 
  109: \ code
  110: 
  111: \ selectors and methods
  112: 
  113: variable current-interface
  114: 
  115: : no-method ( -- )
  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 ;
  129: 
  130: : method ( xt "name" -- )
  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 ;
  142: 
  143: : selector ( "name" -- )
  144:     \ define a method selector for later overriding in subclasses
  145:     ['] no-method method ;
  146: 
  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! ;
  179: 
  180: : overrides ( xt "selector" -- )
  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 ( -- )
  191:     interface% %allot >r
  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: 
  218: : class ( parent-class -- align size )
  219:     class% %allot >r
  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: 
  242: : end-class-noname ( align size -- class )
  243:     current-interface @ dup drop-order class-inst-size 2!
  244:     end-interface-noname ;
  245: 
  246: : end-class ( align size "name" -- )
  247:     \ name execution: ( -- class )
  248:     end-class-noname constant ;
  249: 
  250: \ visibility control
  251: 
  252: variable public-wordlist
  253: 
  254: : protected ( -- )
  255:     current-interface @ class-wordlist @
  256:     dup get-current <>
  257:     if \ we are not protected already
  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> + ! ;
  290: 
  291: \ this/self, instance variables etc.
  292: 
  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 ! ;
  304: 
  305: : m: ( -- xt colon-sys ) ( run-time: object -- )
  306:     :noname 
  307:     POSTPONE this
  308:     POSTPONE >r
  309:     POSTPONE to-this ;
  310: 
  311: : ;m ( colon-sys -- ) ( run-time: -- )
  312:     POSTPONE r>
  313:     POSTPONE to-this
  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.
  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: 
  325: : inst-something ( align1 size1 align size xt "name" -- align2 size2 )
  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 ;
  331: 
  332: : do-inst-var ( -- )
  333: does> \ name execution: ( -- addr )
  334:     ( addr1 ) @ this + ;
  335: 
  336: : inst-var ( align1 offset1 align size "name" -- align2 offset2 )
  337:     \ name execution: ( -- addr )
  338:     ['] do-inst-var inst-something ;
  339: 
  340: : do-inst-value ( -- )
  341: does> \ name execution: ( -- w )
  342:     ( addr1 ) @ this + @ ;
  343: 
  344: : inst-value ( align1 offset1 "name" -- align2 offset2 )
  345:     \ name execution: ( -- w )
  346:     \ a cell-sized value-flavoured instance field
  347:     cell% ['] do-inst-value inst-something ;
  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: 
  358: \ class binding stuff
  359: 
  360: : <bind> ( class selector-xt -- xt )
  361:     >body swap class->map over selector-interface @
  362:     ?dup-if
  363: 	+ @
  364:     then
  365:     swap selector-offset @ + @ ;
  366: 
  367: : bind' ( "class" "selector" -- xt )
  368:     ' execute ' <bind> ;
  369: 
  370: : bind ( ... object "class" "selector" -- ... )
  371:     bind' execute ;
  372: 
  373: : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... )
  374:     bind' compile, ; immediate
  375: 
  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 -- ... )
  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: 
  387: \ the object class
  388: 
  389: \ because OBJECT has no parent class, we have to build it by hand
  390: \ (instead of with class)
  391: 
  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
  400: 
  401: :noname ( object -- )
  402:     drop ;
  403: method construct ( ... object -- )
  404: 
  405: :noname ( object -- )
  406:     ." object:" dup . ." class:" object-map @ @ . ;
  407: method print
  408: 
  409: end-class object
  410: 
  411: \ constructing objects
  412: 
  413: : init-object ( ... class object -- )
  414:     swap class->map over object-map ! ( ... object )
  415:     construct ;
  416: 
  417: : xt-new ( ... class xt -- object )
  418:     \ makes a new object, using XT ( align size -- addr ) to allocate memory
  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
  424:     ['] %allot xt-new ;
  425: 
  426: : heap-new ( ... class -- object )
  427:     \ makes a new object in ALLOCATEd memory
  428:     ['] %alloc xt-new ;

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