File:  [gforth] / gforth / oof.fs
Revision 1.12: download - view: text, annotated - select for diffs
Sun Aug 3 20:21:35 1997 UTC (26 years, 8 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added "definitions" feature to OOF
Added scope prefix to glossary generator to document different occurances
of the same word

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

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