File:  [gforth] / gforth / oof.fs
Revision 1.4: download - view: text, annotated - select for diffs
Mon Nov 18 21:28:18 1996 UTC (22 years, 9 months ago) by pazsan
Branches: MAIN
CVS tags: v0-2-1, v0-2-0, HEAD
   Fixed some OOF interfaces bugs.

    1: \ oof.fs	Object Oriented FORTH
    2: \ 		This file is (c) 1996 by Bernd Paysan
    3: \			e-mail: paysan@informatik.tu-muenchen.de
    4: \
    5: \		Please copy and share this program, modify it for your system
    6: \		and improve it as you like. But don't remove this notice.
    7: \
    8: \		Thank you.
    9: \
   10: 
   11: \ Loadscreen                                           27dec95py
   12: 
   13: decimal
   14: 
   15: : define?  ( -- flag )
   16:   bl word find  nip 0= ;
   17: 
   18: define? cell  [IF]  1 cells Constant cell  [THEN]
   19: 
   20: define? ?EXIT [IF]
   21: : ?EXIT  postpone IF  postpone EXIT postpone THEN ; immediate
   22: [THEN]
   23: 
   24: define? Vocabulary [IF]
   25: : Vocabulary wordlist create ,
   26: DOES> @ >r get-order nip r> swap set-order ;
   27: [THEN]
   28: 
   29: Vocabulary Objects  also Objects also definitions
   30: 
   31: Vocabulary types  types also
   32: 
   33: 0 cells Constant :wordlist
   34: 1 cells Constant :parent
   35: 2 cells Constant :child
   36: 3 cells Constant :next
   37: 4 cells Constant :method#
   38: 5 cells Constant :var#
   39: 6 cells Constant :newlink
   40: 7 cells Constant :iface
   41: 8 cells Constant :init
   42: 
   43: 0 cells Constant :inext
   44: 1 cells Constant :ilist
   45: 2 cells Constant :ilen
   46: 3 cells Constant :inum
   47: 
   48: Variable op
   49: : op! ( o -- )  op ! ;
   50: 
   51: Forth definitions
   52: 
   53: Create ostack 0 , 16 cells allot
   54: 
   55: : ^ ( -- o )  op @ ;
   56: : o@ ( -- o )  op @ @ ;
   57: : >o ( o -- )
   58:     state @
   59:     IF    postpone ^ postpone >r postpone op!
   60:     ELSE  1 ostack +! ^ ostack dup @ cells + ! op!
   61:     THEN  ; immediate
   62: : o> ( -- )
   63:     state @
   64:     IF    postpone r> postpone op!
   65:     ELSE  ostack dup @ cells + @ op! -1 ostack +!
   66:     THEN  ; immediate
   67: : o[] ( n -- ) o@ :var# + @ * ^ + op! ;
   68: 
   69: Objects definitions
   70: 
   71: \ Coding                                               27dec95py
   72: 
   73: 0 Constant #static
   74: 1 Constant #method
   75: 2 Constant #early
   76: 3 Constant #var
   77: 4 Constant #defer
   78: 
   79: : exec?    ( addr -- flag )
   80:   >body cell+ @ #method = ;
   81: : static?  ( addr -- flag )
   82:   >body cell+ @ #static = ;
   83: : early?   ( addr -- flag )
   84:   >body cell+ @ #early  = ;
   85: : defer?   ( addr -- flag )
   86:   >body cell+ @ #defer  = ;
   87: 
   88: define? faligned [IF] false [ELSE] 1 faligned 8 = [THEN]
   89: [IF]   : 8aligned ( n1 -- n2 )  faligned ;
   90: [ELSE] : 8aligned ( n1 -- n2 )  7 + -8 and ;
   91: [THEN]
   92: 
   93: : o+,   ( addr offset -- )
   94:   postpone Literal postpone ^ postpone +
   95:   postpone >o drop ;
   96: : o*,   ( addr offset -- )
   97:   postpone Literal postpone * postpone Literal postpone +
   98:   postpone >o ;
   99: : ^+@  ( offset -- addr )  ^ + @ ;
  100: : o+@,  ( addr offset -- )
  101:     postpone Literal postpone ^+@  postpone >o drop ;
  102: : ^*@  ( offset -- addr )  ^ + @ tuck @ :var# + @ 8aligned * + ;
  103: : o+@*, ( addr offset -- )
  104:   postpone Literal postpone ^*@  postpone >o drop ;
  105: 
  106: \ variables / memory allocation                        30oct94py
  107: 
  108: Variable lastob
  109: Variable lastparent   0 lastparent !
  110: Variable vars
  111: Variable methods
  112: Variable decl  0 decl !
  113: Variable 'link
  114: 
  115: : crash  true abort" unbound method" ;
  116: 
  117: : link, ( addr -- ) align here 'link !  , 0 , 0 , ;
  118: 
  119: 0 link,
  120: 
  121: \ type declaration                                     30oct94py
  122: 
  123: : vallot ( size -- offset )  vars @ >r  dup vars +!
  124:     'link @ 0=
  125:     IF  lastparent @ dup IF  :newlink + @  THEN  link,
  126:     THEN
  127:     'link @ 2 cells + +! r> ;
  128: 
  129: : valign  ( -- )  vars @ aligned vars ! ;
  130: define? faligned 0= [IF]
  131: : vfalign ( -- )  vars @ faligned vars ! ;
  132: [THEN]
  133: 
  134: : mallot ( -- offset )    methods @ cell methods +! ;
  135: 
  136: types definitions
  137: 
  138: : static   ( -- )  mallot Create , #static ,
  139:   DOES> @ o@ + ;
  140: : method   ( -- )  mallot Create , #method ,
  141:   DOES> @ o@ + @ execute ;
  142: : early    ( -- )  Create ['] crash , #early ,
  143:   DOES> @ execute ;
  144: : var ( size -- )  vallot Create , #var ,
  145:   DOES> @ ^ + ;
  146: : defer    ( -- )  valign cell vallot Create , #defer ,
  147:   DOES> @ ^ + @ execute ;
  148: 
  149: \ dealing with threads                                 29oct94py
  150: 
  151: Objects definitions
  152: 
  153: : object-order ( wid0 .. widm m addr -- wid0 .. widn n )
  154:     dup  IF  2@ >r recurse r> swap 1+  ELSE  drop  THEN ;
  155: 
  156: : interface-order ( wid0 .. widm m addr -- wid0 .. widn n )
  157:     dup  IF    2@ >r recurse r> :ilist + @ swap 1+
  158:          ELSE  drop  THEN ;
  159: 
  160: : add-order ( addr -- n )  >r
  161:     get-order r> swap >r 0 swap object-order
  162:     r> over >r + set-order r> ;
  163: 
  164: : drop-order ( n -- )  0 ?DO  previous  LOOP ;
  165: 
  166: \ object compiling/executing                           20feb95py
  167: 
  168: : o, ( xt early? -- )
  169:   over exec?   over and  IF 
  170:       drop >body @ o@ + @ compile,  EXIT  THEN
  171:   over static? over and  IF 
  172:       drop >body @ o@ + @ postpone Literal  EXIT THEN
  173:   drop dup early?  IF >body @  THEN  compile, ;
  174: 
  175: : findo    ( string -- cfa n )
  176:     >r get-order 0
  177:     o@ object-order
  178:     o@ :iface + @ interface-order set-order
  179:     r> find
  180:     ?dup 0= IF drop set-order true abort" method not found!" THEN
  181:     >r >r set-order r> r> ;
  182: 
  183: false Value method?
  184: : method,  ( object early? -- )  true to method?
  185:     swap >o >r bl word  findo  0< state @ and
  186:     IF  r> o,  ELSE  r> drop execute  THEN  o> false to method?  ;
  187: 
  188: : early, ( object -- )  true  method,
  189:   state @ IF  postpone o>  THEN  ;
  190: : late,  ( object -- )  false method,
  191:   state @ IF  postpone o>  THEN  ;
  192: 
  193: \ new,                                                 29oct94py
  194: 
  195: previous Objects definitions
  196: 
  197: Variable alloc
  198: 0 Value ohere
  199: 
  200: : oallot ( n -- )  ohere + to ohere ;
  201: 
  202: : ((new, ( link -- )
  203:   dup @ ?dup IF  recurse  THEN   cell+ 2@ swap ohere + >r
  204:   ?dup IF  ohere >r dup >r :newlink + @ recurse r> r> !  THEN
  205:   r> to ohere ;
  206: 
  207: : (new  ( object -- )
  208:   ohere >r dup >r :newlink + @ ((new, r> r> ! ;
  209: 
  210: : init-instance ( pos link -- pos )
  211:     dup >r @ ?dup IF  recurse  THEN  r> cell+ 2@
  212:     IF  drop dup >r ^ +
  213:         >o o@ :init + @ execute  0 o@ :newlink + @ recurse o>
  214:         r> THEN + ;
  215: 
  216: : init-object ( object -- size )
  217:     >o o@ :init + @ execute  0 o@ :newlink + @ init-instance o> ;
  218: 
  219: : (new, ( object -- ) ohere dup >r over :var# + @ erase (new
  220:     r> init-object drop ;
  221: 
  222: : size@  ( objc -- size )  :var# + @ 8aligned ;
  223: : (new[],   ( n o -- addr ) ohere >r
  224:     dup size@ rot over * oallot r@ ohere dup >r 2 pick -
  225:     ?DO  I to ohere >r dup >r (new, r> r> dup negate +LOOP
  226:     2drop r> to ohere r> ;
  227: 
  228: \ new,                                                 29oct94py
  229: 
  230: Create chunks here 16 cells dup allot erase
  231: 
  232: : DelFix ( addr root -- ) dup @ 2 pick ! ! ;
  233: 
  234: : NewFix  ( root size # -- addr )
  235:   BEGIN  2 pick @ ?dup 0=
  236:   WHILE  2dup * allocate throw over 0
  237:          ?DO    dup 4 pick DelFix 2 pick +
  238:          LOOP
  239:          drop
  240:   REPEAT
  241:   >r drop r@ @ rot ! r@ swap erase r> ;
  242: 
  243: : >chunk ( n -- root n' )
  244:   1- -8 and dup 3 rshift cells chunks + swap 8 + ;
  245: 
  246: : Dalloc ( size -- addr )
  247:   dup 128 > IF  allocate throw EXIT  THEN
  248:   >chunk 2048 over / NewFix ;
  249: 
  250: : Salloc ( size -- addr ) align here swap allot ;
  251: 
  252: : dispose, ( addr size -- )
  253:     dup 128 > IF drop free throw EXIT THEN
  254:     >chunk drop DelFix ;
  255: 
  256: : new, ( o -- addr )  dup :var# + @
  257:   alloc @ execute dup >r to ohere (new, r> ;
  258: 
  259: : new[], ( n o -- addr )  dup :var# + @ 8aligned
  260:   2 pick * alloc @ execute to ohere (new[], ;
  261: 
  262: Forth definitions
  263: 
  264: : dynamic ['] Dalloc alloc ! ;  dynamic
  265: : static  ['] Salloc alloc ! ;
  266: 
  267: Objects definitions
  268: 
  269: \ instance creation                                    29mar94py
  270: 
  271: : instance, ( o -- )  alloc @ >r static new, r> alloc ! drop
  272:   DOES> state @ IF  dup postpone Literal postpone >o  THEN early, ;
  273: : ptr,      ( o -- )  0 , ,
  274:   DOES>  state @
  275:     IF    postpone Literal postpone @ postpone >o cell+
  276:     ELSE  @  THEN late, ;
  277: 
  278: : array,  ( n o -- )  alloc @ >r static new[], r> alloc ! drop
  279:     DOES> ( n -- ) dup dup @ size@
  280:           state @ IF  o*,  ELSE  nip rot * +  THEN  early, ;
  281: 
  282: \ class creation                                       29mar94py
  283: 
  284: Variable voc#
  285: Variable classlist
  286: Variable old-current
  287: Variable ob-interface
  288: 
  289: : voc! ( addr -- )  get-current old-current !
  290:   add-order  2 + voc# !
  291:   get-order wordlist tuck classlist ! 1+ set-order
  292:   also types classlist @ set-current ;
  293: 
  294: : (class ( parent -- )
  295:     here lastob !  true decl !  0 ob-interface !
  296:     0 ,  dup voc!  dup lastparent !
  297:     dup 0= IF  0  ELSE  :method# + 2@  THEN  methods ! vars !
  298:     DOES>  false method, ;
  299: 
  300: : (is ( addr -- )  bl word findo drop
  301:     dup defer? abort" not deferred!"
  302:     >body @ state @
  303:     IF    postpone ^ postpone Literal postpone + postpone !
  304:     ELSE  ^ + !  THEN ;
  305: 
  306: : inherit   ( -- )  bl word findo drop
  307:     dup exec?  IF  >body @ dup o@ + @ swap lastob @ + !  EXIT  THEN
  308:     abort" Not a polymorph method!" ;
  309: 
  310: \ instance variables inside objects                    27dec93py
  311: 
  312: : instvar,    ( addr -- ) dup , here 0 , 0 vallot swap !
  313:     'link @ 2 cells + @  IF  'link @ link,  THEN
  314:     'link @ >r dup r@ cell+ ! :var# + @ dup vars +! r> 2 cells + !
  315:     DOES>  dup 2@ swap state @ IF  o+,  ELSE  ^ + nip nip  THEN
  316:            early, ;
  317: 
  318: : instptr>  ( -- )  DOES>  dup 2@ swap
  319:     state @ IF  o+@,  ELSE  ^ + @ nip nip  THEN  late, ;
  320: 
  321: : instptr,    ( addr -- )  , here 0 , cell vallot swap !
  322:     instptr> ;
  323: 
  324: : (o* ( i addr -- addr' ) dup @ :var# + @ 8aligned rot * + ;
  325: 
  326: : instarray,  ( addr -- )  , here 0 , cell vallot swap !
  327:     DOES>  dup 2@ swap
  328:            state @  IF  o+@*,  ELSE  ^ + @ nip nip (o*  THEN
  329:            late, ;
  330: 
  331: \ bind instance pointers                               27mar94py
  332: 
  333: : ((link ( addr -- o addr' ) 2@ swap ^ + ;
  334: 
  335: : (link  ( -- o addr )  bl word findo drop >body state @
  336:     IF postpone Literal postpone ((link EXIT THEN ((link ;
  337: 
  338: : parent? ( class o -- class class' ) @
  339:   BEGIN  2dup = ?EXIT dup  WHILE  :parent + @  REPEAT ;
  340: 
  341: : (bound ( obj1 obj2 adr2 -- ) >r over parent?
  342:     nip 0= abort" not the same class !" r> ! ;
  343: 
  344: : (bind ( addr -- ) \ <name>
  345:     (link state @ IF postpone (bound EXIT THEN (bound ;
  346: 
  347: : (sbound ( o addr -- ) dup cell+ @ swap (bound ;
  348: 
  349: Forth definitions
  350: 
  351: : bind ( o -- )  '  state @
  352:   IF   postpone Literal postpone >body postpone (sbound EXIT  THEN
  353:   >body (sbound ;  immediate
  354: 
  355: Objects definitions
  356: 
  357: \ method implementation                                29oct94py
  358: 
  359: Variable m-name
  360: Variable last-interface  0 last-interface !
  361: 
  362: : interface, ( -- )  last-interface @
  363:     BEGIN  dup  WHILE  dup , @  REPEAT drop ;
  364: 
  365: : inter, ( iface -- )
  366:     align here over :inum + @ lastob @ + !
  367:     here over :ilen + @ dup allot move ;
  368: 
  369: : interfaces, ( -- ) ob-interface @ lastob @ :iface + !
  370:     ob-interface @
  371:     BEGIN  dup  WHILE  2@ inter,  REPEAT  drop ;
  372: 
  373: : lastob!  ( -- )  lastob @ dup
  374:     BEGIN  nip dup @ here cell+ 2 pick ! dup 0= UNTIL  drop
  375:     dup , [ order ] op! o@ lastob ! ;
  376: 
  377: : thread,  ( -- )  classlist @ , ;
  378: : var,     ( -- )  methods @ , vars @ , ;
  379: : parent,  ( -- o parent )
  380:     o@ lastparent @ 2dup dup , 0 ,
  381:     dup IF  :child + dup @ , !   ELSE  , drop  THEN ;
  382: : 'link,  ( -- )
  383:     'link @ ?dup 0=
  384:     IF  lastparent @ dup  IF  :newlink + @  THEN  THEN , ;
  385: : cells,  ( -- )
  386:   methods @ :init ?DO  ['] crash , cell +LOOP ;
  387: 
  388: \ method implementation                                20feb95py
  389: 
  390: types definitions
  391: 
  392: : how:  ( -- )  decl @ 0= abort" not twice!" 0 decl !
  393:     align  interface,
  394:     lastob! thread, parent, var, 'link, 0 , cells, interfaces,
  395:     dup
  396:     IF    dup :method# + @ >r :init + swap r> :init /string move
  397:     ELSE  2drop  THEN ;
  398: 
  399: : class; ( -- ) decl @ IF  how:  THEN  0 'link !
  400:   voc# @ drop-order old-current @ set-current ;
  401: 
  402: : ptr ( -- ) Create immediate lastob @ here lastob ! instptr, ;
  403: : asptr ( addr -- )  cell+ @ Create immediate
  404:   lastob @ here lastob ! , ,  instptr> ;
  405: 
  406: : : ( <methodname> -- )  decl @ abort" HOW: missing! "
  407:     bl word findo 0= abort" not found"
  408:     dup exec? over early? or over >body cell+ @ 0< or
  409:     0= abort" not a method"
  410:     m-name ! :noname ;
  411: 
  412: Forth
  413: 
  414: : ; ( xt colon-sys -- )  postpone ;
  415:     m-name @ dup >body swap exec?
  416:     IF    @ o@ +
  417:     ELSE  dup cell+ @ 0< IF  2@ swap o@ + @ +  THEN
  418:     THEN ! ; immediate
  419: 
  420: Forth definitions
  421: 
  422: \ object                                               23mar95py
  423: 
  424: Create object  immediate  0 (class \ do not create as subclass
  425:          cell var  oblink       \ create offset for backlink
  426:          static    thread       \ method/variable wordlist
  427:          static    parento      \ pointer to parent
  428:          static    childo       \ ptr to first child
  429:          static    nexto        \ ptr to next child of parent
  430:          static    method#      \ number of methods (bytes)
  431:          static    size         \ number of variables (bytes)
  432: 	 static    newlink      \ ptr to allocated space
  433: 	 static    ilist        \ interface list
  434:          method    init
  435:          method    dispose
  436: 
  437:          early     class
  438:          early     new         immediate
  439:          early     new[]       immediate
  440:          early     :
  441:          early     ptr
  442:          early     asptr
  443:          early     []
  444:          early     ::          immediate
  445:          early     class?
  446:          early     super       immediate
  447:          early     self
  448:          early     bind        immediate
  449:          early     is          immediate
  450:          early     bound
  451:          early     link        immediate
  452: 	 early     '           immediate
  453: 	 early     send        immediate
  454: 	 
  455: \ base object class implementation part                23mar95py
  456: 
  457: how:     0 parento !
  458:          0 childo !
  459: 	 0 nexto !
  460:          : class   ( -- )       Create immediate o@ (class ;
  461:          : :       ( -- )       Create immediate o@
  462: 	     decl @ IF  instvar,    ELSE  instance,  THEN ;
  463:          : ptr     ( -- )       Create immediate o@
  464:            decl @ IF  instptr,    ELSE  ptr,       THEN ;
  465:          : asptr   ( addr -- )
  466:            decl @ 0= abort" only in declaration!"
  467:            Create immediate o@ , cell+ @ , instptr> ;
  468:          : []      ( n -- )     Create immediate o@
  469:            decl @ IF  instarray,  ELSE  array,     THEN ;
  470:          : new     ( -- o )     o@ state @
  471:            IF  postpone Literal postpone new,  ELSE  new,  THEN ;
  472:          : new[]   ( n -- o )   o@ state @
  473:            IF postpone Literal postpone new[], ELSE new[], THEN ;
  474:          : dispose ( -- )       ^ size @ dispose, ;
  475:          : bind    ( addr -- )  (bind ;
  476:          : bound   ( o1 o2 addr2  -- ) (bound ;
  477:          : link    ( -- o addr ) (link ;
  478:          : class?  ( class -- flag )  ^ parent? nip 0<> ;
  479:          : ::      ( -- )
  480:            state @ IF  ^ true method,  ELSE  inherit  THEN ;
  481:          : super   ( -- )       parento true method, ;
  482:          : is      ( cfa -- )   (is ;
  483:          : self    ( -- obj )   ^ ;
  484:          : init    ( -- )       ;
  485: 
  486:          : '       ( -- xt )  bl word findo 0= abort" not found!"
  487:            state @ IF  postpone Literal  THEN ;
  488: 	 : send    ( xt -- )  execute ;
  489: class; \ object
  490: 
  491: \ interface                                            01sep96py
  492: 
  493: Objects definitions
  494: 
  495: : implement ( interface -- )
  496:     align here over , ob-interface @ , ob-interface !
  497:     :ilist + @ >r get-order r> swap 1+ set-order  1 voc# +! ;
  498: 
  499: : inter-method, ( interface -- )
  500:     :ilist + @ bl word count 2dup s" '" compare
  501:     0= dup >r IF  2drop bl word count  THEN
  502:     rot search-wordlist
  503:     dup 0= abort" Not an interface method!"
  504:     r> IF  drop state @ IF  postpone Literal  THEN  EXIT  THEN
  505:     0< state @ and  IF  compile,  ELSE  execute  THEN ;
  506: 
  507: Variable inter-list
  508: Variable lastif
  509: Variable inter#
  510: 
  511: Vocabulary interfaces  interfaces definitions
  512: 
  513: : method  ( -- )  mallot Create , inter# @ ,
  514:   DOES> 2@ swap o@ + @ + @ execute ;
  515: 
  516: : how: ( -- )  align
  517:     here lastif @ !  0 decl !
  518:     here  last-interface @ ,  last-interface !
  519:     inter-list @ ,  methods @ ,  inter# @ ,
  520:     methods @ :inum cell+ ?DO  ['] crash ,  LOOP ;
  521: 
  522: : interface; ( -- )  old-current @ set-current
  523:     previous previous ;
  524: 
  525: : : ( <methodname> -- ) decl @ abort" HOW: missing! "
  526:     bl word count lastif @ @ :ilist + @
  527:     search-wordlist 0= abort" not found"
  528:     dup >body cell+ @ 0< 0= abort" not a method"
  529:     m-name ! :noname ;
  530: 
  531: Forth
  532: 
  533: : ; ( xt colon-sys -- )  postpone ;
  534:   m-name @ >body @ lastif @ @ + ! ; immediate
  535: 
  536: Forth definitions
  537: 
  538: : interface ( -- )
  539:     Create  here lastif !  0 ,  get-current old-current !
  540:     last-interface @ dup  IF  :inum @  THEN  1 cells - inter# !
  541:     get-order wordlist
  542:     dup inter-list ! dup set-current swap 1+ set-order
  543:     true decl !
  544:     0 vars ! :inum cell+ methods !  also interfaces
  545:     DOES>  @ decl @  IF  implement  ELSE  inter-method,  THEN ;
  546: 
  547: previous previous

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