File:  [gforth] / gforth / objects.fs
Revision 1.19: download - view: text, annotated - select for diffs
Sat Sep 23 15:06:01 2000 UTC (19 years, 1 month ago) by anton
Branches: MAIN
CVS tags: v0-7-0, v0-6-2, v0-6-1, v0-6-0, v0-5-0, HEAD
updated copyright dates in many files (not in ec-related files)

    1: \ yet another Forth objects extension
    2: 
    3: \ written by Anton Ertl 1996-2000
    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: s" gforth" environment? [if]
   45:     2drop
   46: [else]
   47: 
   48: : -rot ( a b c -- c a b )
   49:     rot rot ;
   50: 
   51: : perform ( ... addr -- ... )
   52:     @ execute ;
   53: 
   54: : ?dup-if ( compilation: -- orig ; run-time: n -- n|  )
   55:     POSTPONE ?dup POSTPONE if ; immediate
   56: 
   57: : save-mem	( addr1 u -- addr2 u ) \ gforth
   58:     \ copy a memory block into a newly allocated region in the heap
   59:     swap >r
   60:     dup allocate throw
   61:     swap 2dup r> -rot move ;
   62: 
   63: : resize ( a-addr1 u -- a-addr2 ior ) \ gforth
   64:     over
   65:     if
   66: 	resize
   67:     else
   68: 	nip allocate
   69:     then ;
   70: 
   71: : extend-mem	( addr1 u1 u -- addr addr2 u2 )
   72:     \ extend memory block allocated from the heap by u aus
   73:     \ the (possibly reallocated) piece is addr2 u2, the extension is at addr
   74:     over >r + dup >r resize throw
   75:     r> over r> + -rot ;
   76: 
   77: : \g ( -- )
   78:     postpone \ ; immediate
   79: [then]
   80: 
   81: \ data structures
   82: 
   83: struct
   84:     cell% field object-map
   85: end-struct object%
   86: 
   87: struct
   88:     cell% 2* field interface-map
   89:     cell%    field interface-map-offset \ aus
   90:       \ difference between where interface-map points and where
   91:       \ object-map points (0 for non-classes)
   92:     cell%    field interface-offset \ aus
   93:       \ offset of interface map-pointer in class-map (0 for classes)
   94: end-struct interface%
   95: 
   96: interface%
   97:     cell%    field class-parent
   98:     cell%    field class-wordlist \ inst-vars and other protected words
   99:     cell% 2* field class-inst-size ( class -- addr ) \ objects- objects
  100:     \g Give the size specification for an instance (i.e. an object)
  101:     \g of @var{class};
  102:     \g used as @code{class-inst-size 2@ ( class -- align size )}.
  103: end-struct class%
  104: 
  105: struct
  106:     cell% field selector-offset \ the offset within the (interface) map
  107:     cell% field selector-interface \ the interface offset
  108: end-struct selector%
  109: 
  110: \ maps are not defined explicitly; they have the following structure:
  111: 
  112: \ pointers to interface maps (for classes) <- interface-map points here
  113: \ interface%/class% pointer                <- (object-)map  points here
  114: \ xts of methods 
  115: 
  116: 
  117: \ code
  118: 
  119: \ selectors and methods
  120: 
  121: variable current-interface ( -- addr ) \ objects- objects
  122: \g Variable: contains the class or interface currently being
  123: \g defined.
  124: 
  125: 
  126: 
  127: : no-method ( -- )
  128:     true abort" no method defined for this object/selector combination" ;
  129: 
  130: : do-class-method ( -- )
  131: does> ( ... object -- ... )
  132:     ( object selector-body )
  133:     selector-offset @ over object-map @ + ( object xtp ) perform ;
  134: 
  135: : do-interface-method ( -- )
  136: does> ( ... object -- ... )
  137:     ( object selector-body )
  138:     2dup selector-interface @ ( object selector-body object interface-offset )
  139:     swap object-map @ + @ ( object selector-body map )
  140:     swap selector-offset @ + perform ;
  141: 
  142: : method ( xt "name" -- ) \ objects- objects
  143:     \g @code{name} execution: @code{... object -- ...}@*
  144:     \g Create selector @var{name} and makes @var{xt} its method in
  145:     \g the current class.
  146:     create
  147:     current-interface @ interface-map 2@ ( xt map-addr map-size )
  148:     dup current-interface @ interface-map-offset @ - ,
  149:     1 cells extend-mem current-interface @ interface-map 2! ! ( )
  150:     current-interface @ interface-offset @ dup ,
  151:     ( 0<> ) if
  152: 	do-interface-method
  153:     else
  154: 	do-class-method
  155:     then ;
  156: 
  157: : selector ( "name" -- ) \ objects- objects
  158:     \g @var{name} execution: @code{... object -- ...}@*
  159:     \g Create selector @var{name} for the current class and its
  160:     \g descendents; you can set a method for the selector in the
  161:     \g current class with @code{overrides}.
  162:     ['] no-method method ;
  163: 
  164: : interface-override! ( xt sel-xt interface-map -- )
  165:     \ xt is the new method for the selector sel-xt in interface-map
  166:     swap >body ( xt map selector-body )
  167:     selector-offset @ + ! ;
  168: 
  169: : class->map ( class -- map ) \ objects- objects
  170:     \g @var{map} is the pointer to @var{class}'s method map; it
  171:     \g points to the place in the map to which the selector offsets
  172:     \g refer (i.e., where @var{object-map}s point to).
  173:     dup interface-map 2@ drop swap interface-map-offset @ + ;
  174: 
  175: : unique-interface-map ( class-map offset -- )
  176:     \ if the interface at offset in class map is the same as its parent,
  177:     \ copy it to make it unique; used for implementing a copy-on-write policy
  178:     over @ class-parent @ class->map ( class-map offset parent-map )
  179:     over + @ >r  \ the map for the interface for the parent
  180:     + dup @ ( interface-mapp interface-map )
  181:     dup r> =
  182:     if
  183: 	dup @ interface-map 2@ nip save-mem drop	
  184: 	swap !
  185:     else
  186: 	2drop
  187:     then ;
  188: 
  189: : class-override! ( xt sel-xt class-map -- ) \ objects- objects
  190:     \g @var{xt} is the new method for the selector @var{sel-xt} in
  191:     \g @var{class-map}.
  192:     over >body ( xt sel-xt class-map selector-body )
  193:     selector-interface @ ( xt sel-xt class-map offset )
  194:     ?dup-if \ the selector is for an interface
  195: 	2dup unique-interface-map
  196: 	+ @
  197:     then
  198:     interface-override! ;
  199: 
  200: : overrides ( xt "selector" -- ) \ objects- objects
  201:     \g replace default method for @var{selector} in the current class
  202:     \g with @var{xt}. @code{overrides} must not be used during an
  203:     \g interface definition.
  204:     ' current-interface @ class->map class-override! ;
  205: 
  206: \ interfaces
  207: 
  208: \ every interface gets a different offset; the latest one is stored here
  209: variable last-interface-offset 0 last-interface-offset !
  210: 
  211: : interface ( -- ) \ objects- objects
  212:     \g Start an interface definition.
  213:     interface% %allot >r
  214:     r@ current-interface !
  215:     current-interface 1 cells save-mem r@ interface-map 2!
  216:     -1 cells last-interface-offset +!
  217:     last-interface-offset @ r@ interface-offset !
  218:     0 r> interface-map-offset ! ;
  219: 
  220: : end-interface-noname ( -- interface ) \ objects- objects
  221:     \g End an interface definition. The resulting interface is
  222:     \g @var{interface}.
  223:     current-interface @ ;
  224: 
  225: : end-interface ( "name" -- ) \ objects- objects
  226:     \g @code{name} execution: @code{-- interface}@*
  227:     \g End an interface definition. The resulting interface is
  228:     \g @var{interface}.
  229:     end-interface-noname constant ;
  230: 
  231: \ visibility control
  232: 
  233: variable public-wordlist
  234: 
  235: : protected ( -- ) \ objects- objects
  236:     \g Set the compilation wordlist to the current class's wordlist
  237:     current-interface @ class-wordlist @
  238:     dup get-current <>
  239:     if \ we are not protected already
  240: 	get-current public-wordlist !
  241:     then
  242:     set-current ;
  243: 
  244: : public ( -- ) \ objects- objects
  245:     \g Restore the compilation wordlist that was in effect before the
  246:     \g last @code{protected} that actually changed the compilation
  247:     \g wordlist.
  248:     current-interface @ class-wordlist @ get-current =
  249:     if \ we are protected
  250: 	public-wordlist @ set-current
  251:     then ;
  252: 
  253: \ classes
  254: 
  255: : add-class-order ( n1 class -- wid1 ... widn n+n1 )
  256:     dup >r class-parent @
  257:     ?dup-if
  258: 	recurse \ first add the search order for the parent class
  259:     then
  260:     r> class-wordlist @ swap 1+ ;
  261: 
  262: : class>order ( class -- ) \ objects- objects
  263:     \g Add @var{class}'s wordlists to the head of the search-order.
  264:     >r get-order r> add-class-order set-order ;
  265: 
  266: : push-order class>order ; \ old name
  267: 
  268: : methods ( class -- ) \ objects- objects
  269:     \g Makes @var{class} the current class. This is intended to be
  270:     \g used for defining methods to override selectors; you cannot
  271:     \g define new fields or selectors.
  272:     dup current-interface ! class>order ;
  273: 
  274: : class ( parent-class -- align offset ) \ objects- objects
  275:     \g Start a new class definition as a child of
  276:     \g @var{parent-class}. @var{align offset} are for use by
  277:     \g @var{field} etc.
  278:     class% %allot >r
  279:     dup interface-map 2@ save-mem r@ interface-map 2!
  280:     dup interface-map-offset @ r@ interface-map-offset !
  281:     r@ dup class->map !
  282:     0 r@ interface-offset !
  283:     dup r@ class-parent !
  284:     wordlist r@ class-wordlist !
  285:     r> methods
  286:     class-inst-size 2@ ;
  287: 
  288: : remove-class-order ( wid1 ... widn n+n1 class -- n1 )
  289:     \ note: no checks, whether the wordlists are correct
  290:     begin
  291: 	>r nip 1-
  292: 	r> class-parent @ dup 0=
  293:     until
  294:     drop ;
  295: 
  296: : class-previous ( class -- ) \ objects- objects
  297:     \g Drop @var{class}'s wordlists from the search order. No
  298:     \g checking is made whether @var{class}'s wordlists are actually
  299:     \g on the search order.
  300:     >r get-order r> remove-class-order set-order ;
  301: 
  302: : drop-order class-previous ; \ old name
  303: 
  304: : end-methods ( -- ) \ objects- objects
  305:     \g Switch back from defining methods of a class to normal mode
  306:     \g (currently this just restores the old search order).
  307:     current-interface @ class-previous ;
  308: 
  309: : end-class-noname ( align offset -- class ) \ objects- objects
  310:     \g End a class definition. The resulting class is @var{class}.
  311:     public end-methods
  312:     current-interface @ class-inst-size 2!
  313:     end-interface-noname ;
  314: 
  315: : end-class ( align offset "name" -- ) \ objects- objects
  316:     \g @var{name} execution: @code{-- class}@*
  317:     \g End a class definition. The resulting class is @var{class}.
  318:     \ name execution: ( -- class )
  319:     end-class-noname constant ;
  320: 
  321: \ classes that implement interfaces
  322: 
  323: : front-extend-mem ( addr1 u1 u -- addr addr2 u2 )
  324:     \ Extend memory block allocated from the heap by u aus, with the
  325:     \ old stuff coming at the end
  326:     2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 )
  327:     dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 )
  328:     free throw
  329:     r> dup r> ;
  330:     
  331: : implementation ( interface -- ) \ objects- objects
  332:     \g The current class implements @var{interface}. I.e., you can
  333:     \g use all selectors of the interface in the current class and its
  334:     \g descendents.
  335:     dup interface-offset @ ( interface offset )
  336:     current-interface @ interface-map-offset @ negate over - dup 0>
  337:     if \ the interface does not fit in the present class-map
  338: 	>r current-interface @ interface-map 2@
  339: 	r@ front-extend-mem
  340: 	current-interface @ interface-map 2!
  341: 	r@ erase
  342: 	dup negate current-interface @ interface-map-offset !
  343: 	r>
  344:     then ( interface offset n )
  345:     drop >r
  346:     interface-map 2@ save-mem drop ( map )
  347:     current-interface @ dup interface-map 2@ drop
  348:     swap interface-map-offset @ + r> + ! ;
  349: 
  350: \ this/self, instance variables etc.
  351: 
  352: \ rename "this" into "self" if you are a Smalltalk fiend
  353: 0 value this ( -- object ) \ objects- objects
  354: \g the receiving object of the current method (aka active object).
  355: : to-this ( object -- ) \ objects- objects
  356:     \g Set @code{this} (used internally, but useful when debugging).
  357:     TO this ;
  358: 
  359: \ another implementation, if you don't have (fast) values
  360: \ variable thisp
  361: \ : this ( -- object )
  362: \     thisp @ ;
  363: \ : to-this ( object -- )
  364: \     thisp ! ;
  365: 
  366: : enterm ( -- ; run-time: object -- )
  367:     \g method prologue; @var{object} becomes new @code{this}.
  368:     POSTPONE this
  369:     POSTPONE >r
  370:     POSTPONE to-this ;
  371:     
  372: : m: ( -- xt colon-sys; run-time: object -- ) \ objects- objects
  373:     \g Start a method definition; @var{object} becomes new @code{this}.
  374:     :noname enterm ;
  375: 
  376: : :m ( "name" -- xt; run-time: object -- ) \ objects- objects
  377:     \g Start a named method definition; @var{object} becomes new
  378:     \g @code{this}.  Has to be ended with @code{;m}.
  379:     : enterm ;
  380: 
  381: : exitm ( -- ) \ objects- objects
  382:     \g @code{exit} from a method; restore old @code{this}.
  383:     POSTPONE r>
  384:     POSTPONE to-this
  385:     POSTPONE exit ; immediate
  386: 
  387: : ;m ( colon-sys --; run-time: -- ) \ objects- objects
  388:     \g End a method definition; restore old @code{this}.
  389:     POSTPONE r>
  390:     POSTPONE to-this
  391:     POSTPONE ; ; immediate
  392: 
  393: : catch ( ... xt -- ... n ) \ exception
  394:     \ Make it safe to call CATCH within a method.
  395:     \ should also be done with all words containing CATCH.
  396:     this >r catch r> to-this ;
  397: 
  398: \ the following is a bit roundabout; this is caused by the standard
  399: \ disallowing to change the compilation wordlist between CREATE and
  400: \ DOES> (see RFI 3)
  401: 
  402: : inst-something ( align1 size1 align size xt "name" -- align2 size2 )
  403:     \ xt ( -- ) typically is for a DOES>-word
  404:     get-current >r
  405:     current-interface @ class-wordlist @ set-current
  406:     >r create-field r> execute
  407:     r> set-current ;
  408: 
  409: : do-inst-var ( -- )
  410: does> \ name execution: ( -- addr )
  411:     ( addr1 ) @ this + ;
  412: 
  413: : inst-var ( align1 offset1 align size "name" -- align2 offset2 ) \ objects- objects
  414:     \g @var{name} execution: @code{-- addr}@*
  415:     \g @var{addr} is the address of the field @var{name} in
  416:     \g @code{this} object.
  417:     ['] do-inst-var inst-something ;
  418: 
  419: : do-inst-value ( -- )
  420: does> \ name execution: ( -- w )
  421:     ( addr1 ) @ this + @ ;
  422: 
  423: : inst-value ( align1 offset1 "name" -- align2 offset2 ) \ objects- objects
  424:     \g @var{name} execution: @code{-- w}@*
  425:     \g @var{w} is the value of the field @var{name} in @code{this}
  426:     \g object.
  427:     cell% ['] do-inst-value inst-something ;
  428: 
  429: : <to-inst> ( w xt -- ) \ objects- objects
  430:     \g store @var{w} into the field @var{xt} in @code{this} object.
  431:     >body @ this + ! ;
  432: 
  433: : [to-inst] ( compile-time: "name" -- ; run-time: w -- ) \ objects- objects
  434:     \g store @var{w} into field @var{name} in @code{this} object.
  435:     ' >body @ POSTPONE literal
  436:     POSTPONE this
  437:     POSTPONE +
  438:     POSTPONE ! ; immediate
  439: 
  440: \ class binding stuff
  441: 
  442: : <bind> ( class selector-xt -- xt ) \ objects- objects
  443:     \g @var{xt} is the method for the selector @var{selector-xt} in
  444:     \g @var{class}.
  445:     >body swap class->map over selector-interface @
  446:     ?dup-if
  447: 	+ @
  448:     then
  449:     swap selector-offset @ + @ ;
  450: 
  451: : bind' ( "class" "selector" -- xt ) \ objects- objects
  452:     \g @var{xt} is the method for @var{selector} in @var{class}.
  453:     ' execute ' <bind> ;
  454: 
  455: : bind ( ... "class" "selector" -- ... ) \ objects- objects
  456:     \g Execute the method for @var{selector} in @var{class}.
  457:     bind' execute ;
  458: 
  459: : [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) \ objects- objects
  460:     \g Compile the method for @var{selector} in @var{class}.
  461:     bind' compile, ; immediate
  462: 
  463: : current' ( "selector" -- xt ) \ objects- objects
  464:     \g @var{xt} is the method for @var{selector} in the current class.
  465:     current-interface @ ' <bind> ;
  466: 
  467: : [current] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects
  468:     \g Compile the method for @var{selector} in the current class.
  469:     current' compile, ; immediate
  470: 
  471: : [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects
  472:     \g Compile the method for @var{selector} in the parent of the
  473:     \g current class.
  474:     current-interface @ class-parent @ ' <bind> compile, ; immediate
  475: 
  476: \ the object class
  477: 
  478: \ because OBJECT has no parent class, we have to build it by hand
  479: \ (instead of with class)
  480: 
  481: class% %allot current-interface !
  482: current-interface 1 cells save-mem current-interface @ interface-map 2!
  483: 0 current-interface @ interface-map-offset !
  484: 0 current-interface @ interface-offset !
  485: 0 current-interface @ class-parent !
  486: wordlist current-interface @ class-wordlist !
  487: object%
  488: current-interface @ class>order
  489: 
  490: ' drop ( object -- )
  491: method construct ( ... object -- ) \ objects- objects
  492: \g Initialize the data fields of @var{object}. The method for the
  493: \g class @var{object} just does nothing: @code{( object -- )}.
  494: 
  495: :noname ( object -- )
  496:     ." object:" dup . ." class:" object-map @ @ . ;
  497: method print ( object -- ) \ objects- objects
  498: \g Print the object. The method for the class @var{object} prints
  499: \g the address of the object and the address of its class.
  500: 
  501: selector equal ( object1 object2 -- flag )
  502: 
  503: end-class object ( -- class ) \ objects- objects
  504: \g the ancestor of all classes.
  505: 
  506: \ constructing objects
  507: 
  508: : init-object ( ... class object -- ) \ objects- objects
  509:     \g Initialize a chunk of memory (@var{object}) to an object of
  510:     \g class @var{class}; then performs @code{construct}.
  511:     swap class->map over object-map ! ( ... object )
  512:     construct ;
  513: 
  514: : xt-new ( ... class xt -- object ) \ objects- objects
  515:     \g Make a new object, using @code{xt ( align size -- addr )} to
  516:     \g get memory.
  517:     over class-inst-size 2@ rot execute
  518:     dup >r init-object r> ;
  519: 
  520: : dict-new ( ... class -- object ) \ objects- objects
  521:     \g @code{allot} and initialize an object of class @var{class} in
  522:     \g the dictionary.
  523:     ['] %allot xt-new ;
  524: 
  525: : heap-new ( ... class -- object ) \ objects- objects
  526:     \g @code{allocate} and initialize an object of class @var{class}.
  527:     ['] %alloc xt-new ;

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