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

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