version 1.14, 1999/02/16 06:32:29
|
version 1.15, 2000/09/08 11:05:07
|
Line 1
|
Line 1
|
|
|
\ 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 |
|
\ from CORE : |
\ The program uses the following words |
\ decimal : bl word 0= ; = cells Constant Variable ! Create , allot @ IF |
\ from CORE : |
\ POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+ Literal drop |
\ decimal : bl word 0= ; = cells Constant Variable ! Create , allot @ |
\ align here aligned DOES> execute ['] 2@ recurse swap 1+ over LOOP and |
\ IF POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+ |
\ EXIT ?dup 0< rot r@ - i negate +LOOP 2drop BEGIN WHILE 2dup REPEAT 1- |
\ Literal drop align here aligned DOES> execute ['] 2@ recurse swap |
\ rshift > / ' move UNTIL or count |
\ 1+ over LOOP and EXIT ?dup 0< ] [ rot r@ - i negate +LOOP 2drop |
\ from CORE-EXT : |
\ BEGIN WHILE 2dup REPEAT 1- rshift > / ' move UNTIL or count |
\ nip tuck true ?DO compile, false Value erase pick :noname 0<> |
\ from CORE-EXT : |
\ from BLOCK-EXT : |
\ nip false Value tuck true ?DO compile, erase pick :noname 0<> |
\ \ |
\ from BLOCK-EXT : |
\ from EXCEPTION : |
\ \ |
\ throw |
\ from EXCEPTION : |
\ from EXCEPTION-EXT : |
\ throw |
\ abort" |
\ from EXCEPTION-EXT : |
\ from FILE : |
\ abort" |
\ ( S" |
\ from FILE : |
\ from FLOAT : |
\ ( S" |
\ faligned |
\ from FLOAT : |
\ from LOCAL : |
\ faligned |
\ TO |
\ from LOCAL : |
\ from MEMORY : |
\ TO |
\ allocate free |
\ from MEMORY : |
\ from SEARCH : |
\ allocate free |
\ find definitions get-order set-order get-current wordlist set-current |
\ from SEARCH : |
\ search-wordlist |
\ find definitions get-order set-order get-current wordlist |
\ from SEARCH-EXT : |
\ set-current search-wordlist |
\ also Forth previous |
\ from SEARCH-EXT : |
\ from STRING : |
\ also Forth previous |
\ /string compare |
\ from STRING : |
\ from TOOLS-EXT : |
\ /string compare |
\ [IF] [THEN] [ELSE] state |
\ from TOOLS-EXT : |
|
\ [IF] [THEN] [ELSE] state |
|
\ from non-ANS : |
|
\ cell dummy [THEN] ?EXIT Vocabulary [ELSE] ( \G |
|
|
\ Loadscreen 27dec95py |
\ Loadscreen 27dec95py |
|
|
Line 51 define? cell [IF]
|
Line 55 define? cell [IF]
|
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] |
Line 234 false Value method?
|
Line 242 false Value method?
|
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? ; |
Line 320 Objects definitions
|
Line 331 Objects definitions
|
\ 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+ |
Line 342 Variable ob-interface
|
Line 354 Variable ob-interface
|
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!" |
Line 631 Forth
|
Line 644 Forth
|
|
|
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 |
|
|
|
|