| |
|
| \ oof.fs Object Oriented FORTH |
\ oof.fs Object Oriented FORTH |
| \ This file is (c) 1996 by Bernd Paysan |
\ This file is (c) 1996,2000 by Bernd Paysan |
| \ e-mail: paysan@informatik.tu-muenchen.de |
\ e-mail: bernd.paysan@gmx.de |
| \ |
\ |
| \ Please copy and share this program, modify it for your system |
\ Please copy and share this program, modify it for your system |
| \ and improve it as you like. But don't remove this notice. |
\ and improve it as you like. But don't remove this notice. |
| \ |
\ |
| \ Thank you. |
\ Thank you. |
| \ |
\ |
| |
|
| \ The program uses the following words |
\ The program uses the following words |
| \ from CORE : |
\ from CORE : |
| \ decimal : bl word 0= ; = cells Constant Variable ! Create , allot @ IF |
\ decimal : bl word 0= ; = cells Constant Variable ! Create , allot @ |
| \ POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+ Literal drop |
\ IF POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+ |
| \ align here aligned DOES> execute ['] 2@ recurse swap 1+ over LOOP and |
\ Literal drop align here aligned DOES> execute ['] 2@ recurse swap |
| \ EXIT ?dup 0< rot r@ - i negate +LOOP 2drop BEGIN WHILE 2dup REPEAT 1- |
\ 1+ over LOOP and EXIT ?dup 0< ] [ rot r@ - i negate +LOOP 2drop |
| \ rshift > / ' move UNTIL or count |
\ BEGIN WHILE 2dup REPEAT 1- rshift > / ' move UNTIL or count |
| \ from CORE-EXT : |
\ from CORE-EXT : |
| \ nip tuck true ?DO compile, false Value erase pick :noname 0<> |
\ nip false Value tuck true ?DO compile, erase pick :noname 0<> |
| \ from BLOCK-EXT : |
\ from BLOCK-EXT : |
| \ \ |
\ \ |
| \ from EXCEPTION : |
\ from EXCEPTION : |
| \ from MEMORY : |
\ from MEMORY : |
| \ allocate free |
\ allocate free |
| \ from SEARCH : |
\ from SEARCH : |
| \ find definitions get-order set-order get-current wordlist set-current |
\ find definitions get-order set-order get-current wordlist |
| \ search-wordlist |
\ set-current search-wordlist |
| \ from SEARCH-EXT : |
\ from SEARCH-EXT : |
| \ also Forth previous |
\ also Forth previous |
| \ from STRING : |
\ from STRING : |
| \ /string compare |
\ /string compare |
| \ from TOOLS-EXT : |
\ from TOOLS-EXT : |
| \ [IF] [THEN] [ELSE] state |
\ [IF] [THEN] [ELSE] state |
| |
\ from non-ANS : |
| |
\ cell dummy [THEN] ?EXIT Vocabulary [ELSE] ( \G |
| |
|
| \ Loadscreen 27dec95py |
\ Loadscreen 27dec95py |
| |
|
| 1 cells Constant cell |
1 cells Constant cell |
| [THEN] |
[THEN] |
| |
|
| |
define? \G [IF] |
| |
: \G postpone \ ; immediate |
| |
[THEN] |
| |
|
| define? ?EXIT [IF] |
define? ?EXIT [IF] |
| : ?EXIT postpone IF postpone EXIT postpone THEN ; immediate |
: ?EXIT postpone IF postpone EXIT postpone THEN ; immediate |
| [THEN] |
[THEN] |
| IF r> o, ELSE r> drop execute THEN o> false to method? ; |
IF r> o, ELSE r> drop execute THEN o> false to method? ; |
| |
|
| : cmethod, ( object early? -- ) |
: cmethod, ( object early? -- ) |
| state @ >r state on method, r> state ! ; |
state @ dup >r |
| |
0= IF postpone ] THEN |
| |
method, |
| |
r> 0= IF postpone [ THEN ; |
| |
|
| : early, ( object -- ) true to oset? true method, |
: early, ( object -- ) true to oset? true method, |
| state @ oset? and IF postpone o> THEN false to oset? ; |
state @ oset? and IF postpone o> THEN false to oset? ; |
| \ instance creation 29mar94py |
\ instance creation 29mar94py |
| |
|
| : instance, ( o -- ) alloc @ >r static new, r> alloc ! drop |
: instance, ( o -- ) alloc @ >r static new, r> alloc ! drop |
| DOES> state @ IF dup postpone Literal oset? IF postpone op! ELSE postpone >o THEN THEN early, ; |
DOES> state @ IF dup postpone Literal oset? IF postpone op! ELSE postpone >o THEN THEN early, |
| |
; |
| : ptr, ( o -- ) 0 , , |
: ptr, ( o -- ) 0 , , |
| DOES> state @ |
DOES> state @ |
| IF dup postpone Literal postpone @ oset? IF postpone op! ELSE postpone >o THEN cell+ |
IF dup postpone Literal postpone @ oset? IF postpone op! ELSE postpone >o THEN cell+ |
| get-order wordlist tuck classlist ! 1+ set-order |
get-order wordlist tuck classlist ! 1+ set-order |
| also types classlist @ set-current ; |
also types classlist @ set-current ; |
| |
|
| : (class ( parent -- ) |
: (class-does> DOES> false method, ; |
| |
|
| |
: (class ( parent -- ) (class-does> |
| here lastob ! true decl ! 0 ob-interface ! |
here lastob ! true decl ! 0 ob-interface ! |
| 0 , dup voc! dup lastparent ! |
0 , dup voc! dup lastparent ! |
| dup 0= IF 0 ELSE :method# + 2@ THEN methods ! vars ! |
dup 0= IF 0 ELSE :method# + 2@ THEN methods ! vars ! ; |
| DOES> false method, ; |
|
| |
|
| : (is ( addr -- ) bl word findo drop |
: (is ( addr -- ) bl word findo drop |
| dup defer? abort" not deferred!" |
dup defer? abort" not deferred!" |
| |
|
| Forth definitions |
Forth definitions |
| |
|
| |
: interface-does> |
| |
DOES> @ decl @ IF implement ELSE inter-method, THEN ; |
| : interface ( -- ) \ oof-interface- oof |
: interface ( -- ) \ oof-interface- oof |
| Create here lastif ! 0 , get-current old-current ! |
Create interface-does> |
| |
here lastif ! 0 , get-current old-current ! |
| last-interface @ dup IF :inum @ THEN 1 cells - inter# ! |
last-interface @ dup IF :inum @ THEN 1 cells - inter# ! |
| get-order wordlist |
get-order wordlist |
| dup inter-list ! dup set-current swap 1+ set-order |
dup inter-list ! dup set-current swap 1+ set-order |
| true decl ! |
true decl ! |
| 0 vars ! :inum cell+ methods ! also interfaces |
0 vars ! :inum cell+ methods ! also interfaces ; |
| DOES> @ decl @ IF implement ELSE inter-method, THEN ; |
|
| |
|
| previous previous |
previous previous |
| |
|
| |
|
