Annotation of gforth/oof.fs, revision 1.13

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: \
1.8       pazsan     10: \ The program uses the following words
                     11: \ from CORE :
1.9       pazsan     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 
1.8       pazsan     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 :
1.9       pazsan     34: \ find definitions get-order set-order get-current wordlist set-current
                     35: \ search-wordlist 
1.8       pazsan     36: \ from SEARCH-EXT :
                     37: \ also Forth previous 
                     38: \ from STRING :
                     39: \ /string compare 
                     40: \ from TOOLS-EXT :
                     41: \ [IF] [THEN] [ELSE] state 
1.1       pazsan     42: 
                     43: \ Loadscreen                                           27dec95py
                     44: 
                     45: decimal
                     46: 
                     47: : define?  ( -- flag )
                     48:   bl word find  nip 0= ;
                     49: 
1.7       pazsan     50: define? cell  [IF]
                     51: 1 cells Constant cell
                     52: [THEN]
1.1       pazsan     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: 
1.7       pazsan     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: 
1.1       pazsan     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: 
1.10      pazsan    129: false Value oset?
                    130: 
1.1       pazsan    131: : o+,   ( addr offset -- )
                    132:   postpone Literal postpone ^ postpone +
1.10      pazsan    133:   oset? IF  postpone op!  ELSE  postpone >o  THEN  drop ;
1.1       pazsan    134: : o*,   ( addr offset -- )
                    135:   postpone Literal postpone * postpone Literal postpone +
1.10      pazsan    136:   oset? IF  postpone op!  ELSE  postpone >o  THEN ;
1.1       pazsan    137: : ^+@  ( offset -- addr )  ^ + @ ;
                    138: : o+@,  ( addr offset -- )
1.10      pazsan    139:     postpone Literal postpone ^+@  oset? IF  postpone op!  ELSE  postpone >o  THEN drop ;
1.1       pazsan    140: : ^*@  ( offset -- addr )  ^ + @ tuck @ :var# + @ 8aligned * + ;
                    141: : o+@*, ( addr offset -- )
1.10      pazsan    142:   postpone Literal postpone ^*@  oset? IF  postpone op!  ELSE  postpone >o  THEN drop ;
1.1       pazsan    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: 
1.12      pazsan    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 ;
1.1       pazsan    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: 
1.7       pazsan    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
1.1       pazsan    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 )
1.7       pazsan    225:     o@ add-order >r
                    226:     find
1.1       pazsan    227:     ?dup 0= IF drop set-order true abort" method not found!" THEN
1.7       pazsan    228:     r> drop-order ;
1.1       pazsan    229: 
                    230: false Value method?
1.7       pazsan    231: 
1.1       pazsan    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: 
1.10      pazsan    236: : cmethod,  ( object early? -- )
                    237:     state @ >r state on  method, r> state ! ;
                    238: 
1.7       pazsan    239: : early, ( object -- )  true to oset?  true  method,
1.10      pazsan    240:   state @ oset? and IF  postpone o>  THEN  false to oset? ;
1.7       pazsan    241: : late,  ( object -- )  true to oset?  false method,
1.10      pazsan    242:   state @ oset? and IF  postpone o>  THEN  false to oset? ;
1.1       pazsan    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' )
1.4       pazsan    295:   1- -8 and dup 3 rshift cells chunks + swap 8 + ;
1.1       pazsan    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
1.10      pazsan    323:   DOES> state @ IF  dup postpone Literal oset? IF  postpone op!  ELSE  postpone >o  THEN  THEN early, ;
1.1       pazsan    324: : ptr,      ( o -- )  0 , ,
                    325:   DOES>  state @
1.10      pazsan    326:     IF    dup postpone Literal postpone @ oset? IF  postpone op!  ELSE  postpone >o  THEN cell+
1.1       pazsan    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
1.7       pazsan    426:     dup , op! o@ lastob ! ;
1.1       pazsan    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: 
1.12      pazsan    443: : how:  ( -- ) \ oof- oof how-to
                    444: \G End declaration, start implementation
                    445:     decl @ 0= abort" not twice!" 0 decl !
1.1       pazsan    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: 
1.12      pazsan    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> ;
1.1       pazsan    464: 
1.10      pazsan    465: : Fpostpone  postpone postpone ; immediate
                    466: 
1.13    ! pazsan    467: : : ( <methodname> -- ) \ oof- oof colon
        !           468:     decl @ abort" HOW: missing! "
1.1       pazsan    469:     bl word findo 0= abort" not found"
                    470:     dup exec? over early? or over >body cell+ @ 0< or
                    471:     0= abort" not a method"
                    472:     m-name ! :noname ;
                    473: 
                    474: Forth
                    475: 
1.13    ! pazsan    476: : ; ( xt colon-sys -- ) \ oof- oof
        !           477:     postpone ;
1.1       pazsan    478:     m-name @ dup >body swap exec?
                    479:     IF    @ o@ +
                    480:     ELSE  dup cell+ @ 0< IF  2@ swap o@ + @ +  THEN
                    481:     THEN ! ; immediate
                    482: 
                    483: Forth definitions
                    484: 
                    485: \ object                                               23mar95py
                    486: 
                    487: Create object  immediate  0 (class \ do not create as subclass
                    488:          cell var  oblink       \ create offset for backlink
                    489:          static    thread       \ method/variable wordlist
                    490:          static    parento      \ pointer to parent
                    491:          static    childo       \ ptr to first child
                    492:          static    nexto        \ ptr to next child of parent
                    493:          static    method#      \ number of methods (bytes)
                    494:          static    size         \ number of variables (bytes)
                    495:         static    newlink      \ ptr to allocated space
                    496:         static    ilist        \ interface list
1.12      pazsan    497:         method    init ( ... -- ) \ object- oof
                    498:          method    dispose ( -- ) \ object- oof
1.1       pazsan    499: 
1.12      pazsan    500:          early     class ( "name" -- ) \ object- oof
                    501:         early     new ( -- o ) \ object- oof
                    502:                                immediate
                    503:         early     new[] ( n -- o ) \ object- oof new-array
                    504:                                immediate
                    505:          early     : ( "name" -- ) \ object- oof define
                    506:          early     ptr ( "name" -- ) \ object- oof
                    507:          early     asptr ( o "name" -- ) \ object- oof
                    508:          early     [] ( n "name" -- ) \ object- oof array
                    509:         early     ::  ( "name" -- ) \ object- oof scope
                    510:                                immediate
                    511:          early     class? ( o -- flag ) \ object- oof class-query
                    512:         early     super  ( "name" -- ) \ object- oof
                    513:                                immediate
                    514:          early     self ( -- o ) \ object- oof
                    515:         early     bind ( o "name" -- ) \ object- oof
                    516:                                immediate
                    517:          early     bound ( class addr "name" -- ) \ object- oof
                    518:         early     link ( "name" -- class addr ) \ object- oof
                    519:                                immediate
                    520:         early     is  ( xt "name" -- ) \ object- oof
                    521:                                immediate
                    522:         early     send ( xt -- ) \ object- oof
                    523:                                immediate
                    524:         early     with ( o -- ) \ object- oof
                    525:                                immediate
                    526:         early     endwith ( -- ) \ object- oof
                    527:                                immediate
                    528:         early     ' ( "name" -- xt ) \ object- oof tick
                    529:                                immediate
                    530:         early     postpone ( "name" -- ) \ object- oof
                    531:                                immediate
                    532:         early     definitions ( -- ) \ object- oof
1.1       pazsan    533:         
                    534: \ base object class implementation part                23mar95py
                    535: 
1.11      pazsan    536: how:
                    537: 0 parento !
                    538: 0 childo !
                    539: 0 nexto !
                    540:     : class   ( -- )       Create immediate o@ (class ;
                    541:     : :       ( -- )       Create immediate o@
                    542:        decl @ IF  instvar,    ELSE  instance,  THEN ;
                    543:     : ptr     ( -- )       Create immediate o@
                    544:        decl @ IF  instptr,    ELSE  ptr,       THEN ;
                    545:     : asptr   ( addr -- )
                    546:        decl @ 0= abort" only in declaration!"
                    547:        Create immediate o@ , cell+ @ , instptr> ;
                    548:     : []      ( n -- )     Create immediate o@
                    549:        decl @ IF  instarray,  ELSE  array,     THEN ;
                    550:     : new     ( -- o )     o@ state @
                    551:        IF  Fpostpone Literal Fpostpone new,  ELSE  new,  THEN ;
                    552:     : new[]   ( n -- o )   o@ state @
                    553:        IF Fpostpone Literal Fpostpone new[], ELSE new[], THEN ;
                    554:     : dispose ( -- )       ^ size @ dispose, ;
                    555:     : bind    ( addr -- )  (bind ;
                    556:     : bound   ( o1 o2 addr2  -- ) (bound ;
                    557:     : link    ( -- o addr ) (link ;
                    558:     : class?  ( class -- flag )  ^ parent? nip 0<> ;
                    559:     : ::      ( -- )
                    560:        state @ IF  ^ true method,  ELSE  inherit  THEN ;
                    561:     : super   ( -- )       parento true method, ;
                    562:     : is      ( cfa -- )   (is ;
                    563:     : self    ( -- obj )   ^ ;
                    564:     : init    ( -- )       ;
                    565:     
                    566:     : '       ( -- xt )  bl word findo 0= abort" not found!"
                    567:        state @ IF  Fpostpone Literal  THEN ;
                    568:     : send    ( xt -- )  execute ;
                    569:     : postpone ( -- )  o@ add-order Fpostpone Fpostpone drop-order ;
                    570:     
                    571:     : with ( -- )
                    572:        state @ oset? 0= and IF  Fpostpone >o  THEN
                    573:        o@ add-order voc# ! false to oset? ;
                    574:     : endwith  Fpostpone o> voc# @ drop-order ;
1.7       pazsan    575: 
1.11      pazsan    576:     : definitions
                    577:        o@ add-order 1+ voc# ! also types o@ lastob !
                    578:        false to oset?   get-current old-current !
                    579:        thread @ set-current ;
1.1       pazsan    580: class; \ object
                    581: 
                    582: \ interface                                            01sep96py
                    583: 
                    584: Objects definitions
                    585: 
1.13    ! pazsan    586: : implement ( interface -- ) \ oof-interface- oof
1.1       pazsan    587:     align here over , ob-interface @ , ob-interface !
1.2       pazsan    588:     :ilist + @ >r get-order r> swap 1+ set-order  1 voc# +! ;
1.1       pazsan    589: 
1.13    ! pazsan    590: : inter-method, ( interface -- ) \ oof-interface- oof
1.1       pazsan    591:     :ilist + @ bl word count 2dup s" '" compare
                    592:     0= dup >r IF  2drop bl word count  THEN
                    593:     rot search-wordlist
                    594:     dup 0= abort" Not an interface method!"
                    595:     r> IF  drop state @ IF  postpone Literal  THEN  EXIT  THEN
                    596:     0< state @ and  IF  compile,  ELSE  execute  THEN ;
                    597: 
                    598: Variable inter-list
                    599: Variable lastif
                    600: Variable inter#
                    601: 
                    602: Vocabulary interfaces  interfaces definitions
                    603: 
1.13    ! pazsan    604: : method  ( -- ) \ oof-interface- oof
        !           605:     mallot Create , inter# @ ,
        !           606: DOES> 2@ swap o@ + @ + @ execute ;
1.1       pazsan    607: 
1.13    ! pazsan    608: : how: ( -- ) \ oof-interface- oof
        !           609:     align
1.1       pazsan    610:     here lastif @ !  0 decl !
1.4       pazsan    611:     here  last-interface @ ,  last-interface !
                    612:     inter-list @ ,  methods @ ,  inter# @ ,
1.1       pazsan    613:     methods @ :inum cell+ ?DO  ['] crash ,  LOOP ;
                    614: 
1.13    ! pazsan    615: : interface; ( -- ) \ oof-interface- oof
        !           616:     old-current @ set-current
1.1       pazsan    617:     previous previous ;
                    618: 
1.13    ! pazsan    619: : : ( <methodname> -- ) \ oof-interface- oof colon
        !           620:     decl @ abort" HOW: missing! "
1.1       pazsan    621:     bl word count lastif @ @ :ilist + @
                    622:     search-wordlist 0= abort" not found"
                    623:     dup >body cell+ @ 0< 0= abort" not a method"
                    624:     m-name ! :noname ;
                    625: 
                    626: Forth
                    627: 
1.13    ! pazsan    628: : ; ( xt colon-sys -- ) \ oof-interface- oof
        !           629:   postpone ;
1.1       pazsan    630:   m-name @ >body @ lastif @ @ + ! ; immediate
                    631: 
                    632: Forth definitions
                    633: 
1.13    ! pazsan    634: : interface ( -- ) \ oof-interface- oof
1.1       pazsan    635:     Create  here lastif !  0 ,  get-current old-current !
                    636:     last-interface @ dup  IF  :inum @  THEN  1 cells - inter# !
                    637:     get-order wordlist
                    638:     dup inter-list ! dup set-current swap 1+ set-order
                    639:     true decl !
                    640:     0 vars ! :inum cell+ methods !  also interfaces
                    641:     DOES>  @ decl @  IF  implement  ELSE  inter-method,  THEN ;
                    642: 
                    643: previous previous
1.7       pazsan    644: 

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