Annotation of gforth/oof.fs, revision 1.7

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

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