File:  [gforth] / gforth / oof.fs
Revision 1.8: download - view: text, annotated - select for diffs
Thu Mar 13 23:40:33 1997 UTC (22 years, 7 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added lots of copyright notices.

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

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