Annotation of gforth/oof.fs, revision 1.15

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

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