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