1 2\ oof.fs Object Oriented FORTH 3\ This file is (c) 1996,2000 by Bernd Paysan 4\ e-mail: bernd.paysan@gmx.de 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\ 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 46 47\ Loadscreen 27dec95py 48 49decimal 50 51: define? ( -- flag ) 52 bl word find nip 0= ; 53 54define? cell [IF] 551 cells Constant cell 56[THEN] 57 58define? \G [IF] 59: \G postpone \ ; immediate 60[THEN] 61 62define? ?EXIT [IF] 63: ?EXIT postpone IF postpone EXIT postpone THEN ; immediate 64[THEN] 65 66define? Vocabulary [IF] 67: Vocabulary wordlist create , 68DOES> @ >r get-order nip r> swap set-order ; 69[THEN] 70 71define? 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 78Vocabulary Objects also Objects also definitions 79 80Vocabulary types types also 81 820 cells Constant :wordlist 831 cells Constant :parent 842 cells Constant :child 853 cells Constant :next 864 cells Constant :method# 875 cells Constant :var# 886 cells Constant :newlink 897 cells Constant :iface 908 cells Constant :init 91 920 cells Constant :inext 931 cells Constant :ilist 942 cells Constant :ilen 953 cells Constant :inum 96 97Variable op 98: op! ( o -- ) op ! ; 99 100Forth definitions 101 102Create 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 118Objects definitions 119 120\ Coding 27dec95py 121 1220 Constant #static 1231 Constant #method 1242 Constant #early 1253 Constant #var 1264 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 137false Value oset? 138 139: o+, ( addr offset -- ) 140 postpone Literal postpone ^ postpone + 141 oset? IF postpone op! ELSE postpone >o THEN drop ; 142: o*, ( addr offset -- ) 143 postpone Literal postpone * postpone Literal postpone + 144 oset? IF postpone op! ELSE postpone >o THEN ; 145: ^+@ ( offset -- addr ) ^ + @ ; 146: o+@, ( addr offset -- ) 147 postpone Literal postpone ^+@ oset? IF postpone op! ELSE postpone >o THEN drop ; 148: ^*@ ( offset -- addr ) ^ + @ tuck @ :var# + @ 8aligned * + ; 149: o+@*, ( addr offset -- ) 150 postpone Literal postpone ^*@ oset? IF postpone op! ELSE postpone >o THEN drop ; 151 152\ variables / memory allocation 30oct94py 153 154Variable lastob 155Variable lastparent 0 lastparent ! 156Variable vars 157Variable methods 158Variable decl 0 decl ! 159Variable 'link 160 161: crash true abort" unbound method" ; 162 163: link, ( addr -- ) align here 'link ! , 0 , 0 , ; 164 1650 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 ! ; 176define? faligned 0= [IF] 177: vfalign ( -- ) vars @ faligned vars ! ; 178[THEN] 179 180: mallot ( -- offset ) methods @ cell methods +! ; 181 182types definitions 183 184: static ( -- ) \ oof- oof 185 \G Create a class-wide cell-sized variable. 186 mallot Create , #static , 187DOES> @ o@ + ; 188: method ( -- ) \ oof- oof 189 \G Create a method selector. 190 mallot Create , #method , 191DOES> @ o@ + @ execute ; 192: early ( -- ) \ oof- oof 193 \G Create a method selector for early binding. 194 Create ['] crash , #early , 195DOES> @ execute ; 196: var ( size -- ) \ oof- oof 197 \G Create an instance variable 198 vallot Create , #var , 199DOES> @ ^ + ; 200: defer ( -- ) \ oof- oof 201 \G Create an instance defer 202 valign cell vallot Create , #defer , 203DOES> @ ^ + @ execute ; 204 205\ dealing with threads 29oct94py 206 207Objects 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 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 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 ) 233 o@ add-order >r 234 find 235 ?dup 0= IF drop set-order true abort" method not found!" THEN 236 r> drop-order ; 237 238false Value method? 239 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 244: cmethod, ( object early? -- ) 245 state @ dup >r 246 0= IF postpone ] THEN 247 method, 248 r> 0= IF postpone [ THEN ; 249 250: early, ( object -- ) true to oset? true method, 251 state @ oset? and IF postpone o> THEN false to oset? ; 252: late, ( object -- ) true to oset? false method, 253 state @ oset? and IF postpone o> THEN false to oset? ; 254 255\ new, 29oct94py 256 257previous Objects definitions 258 259Variable alloc 2600 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 292Create 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' ) 306 1- -8 and dup 3 rshift cells chunks + swap 8 + ; 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 324Forth definitions 325 326: dynamic ['] Dalloc alloc ! ; dynamic 327: static ['] Salloc alloc ! ; 328 329Objects definitions 330 331\ instance creation 29mar94py 332 333: instance, ( o -- ) alloc @ >r static new, r> alloc ! drop 334 DOES> state @ IF dup postpone Literal oset? IF postpone op! ELSE postpone >o THEN THEN early, 335; 336: ptr, ( o -- ) 0 , , 337 DOES> state @ 338 IF dup postpone Literal postpone @ oset? IF postpone op! ELSE postpone >o THEN cell+ 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 347Variable voc# 348Variable classlist 349Variable old-current 350Variable 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 357: (class-does> DOES> false method, ; 358 359: (class ( parent -- ) (class-does> 360 here lastob ! true decl ! 0 ob-interface ! 361 0 , dup voc! dup lastparent ! 362 dup 0= IF 0 ELSE :method# + 2@ THEN methods ! vars ! ; 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 413Forth definitions 414 415: bind ( o -- ) ' state @ 416 IF postpone Literal postpone >body postpone (sbound EXIT THEN 417 >body (sbound ; immediate 418 419Objects definitions 420 421\ method implementation 29oct94py 422 423Variable m-name 424Variable 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 439 dup , op! o@ lastob ! ; 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 454types definitions 455 456: how: ( -- ) \ oof- oof how-to 457\G End declaration, start implementation 458 decl @ 0= abort" not twice!" 0 decl ! 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 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 474 \G Create an alias to an instance pointer, cast to another class. 475 cell+ @ Create immediate 476 lastob @ here lastob ! , , instptr> ; 477 478: Fpostpone postpone postpone ; immediate 479 480: : ( <methodname> -- ) \ oof- oof colon 481 decl @ abort" HOW: missing! " 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 487Forth 488 489: ; ( xt colon-sys -- ) \ oof- oof 490 postpone ; 491 m-name @ dup >body swap exec? 492 IF @ o@ + 493 ELSE dup cell+ @ 0< IF 2@ swap o@ + @ + THEN 494 THEN ! ; immediate 495 496Forth definitions 497 498\ object 23mar95py 499 500Create 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 510 method init ( ... -- ) \ object- oof 511 method dispose ( -- ) \ object- oof 512 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 546 547\ base object class implementation part 23mar95py 548 549how: 5500 parento ! 5510 childo ! 5520 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 ; 588 589 : definitions 590 o@ add-order 1+ voc# ! also types o@ lastob ! 591 false to oset? get-current old-current ! 592 thread @ set-current ; 593class; \ object 594 595\ interface 01sep96py 596 597Objects definitions 598 599: implement ( interface -- ) \ oof-interface- oof 600 align here over , ob-interface @ , ob-interface ! 601 :ilist + @ >r get-order r> swap 1+ set-order 1 voc# +! ; 602 603: inter-method, ( interface -- ) \ oof-interface- oof 604 :ilist + @ bl word count 2dup s" '" str= 605 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 611Variable inter-list 612Variable lastif 613Variable inter# 614 615Vocabulary interfaces interfaces definitions 616 617: method ( -- ) \ oof-interface- oof 618 mallot Create , inter# @ , 619DOES> 2@ swap o@ + @ + @ execute ; 620 621: how: ( -- ) \ oof-interface- oof 622 align 623 here lastif @ ! 0 decl ! 624 here last-interface @ , last-interface ! 625 inter-list @ , methods @ , inter# @ , 626 methods @ :inum cell+ ?DO ['] crash , LOOP ; 627 628: interface; ( -- ) \ oof-interface- oof 629 old-current @ set-current 630 previous previous ; 631 632: : ( <methodname> -- ) \ oof-interface- oof colon 633 decl @ abort" HOW: missing! " 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 639Forth 640 641: ; ( xt colon-sys -- ) \ oof-interface- oof 642 postpone ; 643 m-name @ >body @ lastif @ @ + ! ; immediate 644 645Forth definitions 646 647: interface-does> 648 DOES> @ decl @ IF implement ELSE inter-method, THEN ; 649: interface ( -- ) \ oof-interface- oof 650 Create interface-does> 651 here lastif ! 0 , get-current old-current ! 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 ! 656 0 vars ! :inum cell+ methods ! also interfaces ; 657 658previous previous 659 660 661