File:  [gforth] / gforth / oof.fs
Revision 1.16: download - view: text, annotated - select for diffs
Sat Sep 14 08:20:19 2002 UTC (21 years, 6 months ago) by anton
Branches: MAIN
CVS tags: v0-7-0, v0-6-2, v0-6-1, v0-6-0, HEAD
Added compat/strcomp.fs, introducing STR=, STRING-PREFIX?, and STR<
replaced most occurences of COMPARE with STR= and STRING-PREFIX?

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

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