version 1.9, 1997/03/31 22:14:39
|
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 126 Objects definitions
|
Line 134 Objects definitions
|
: defer? ( addr -- flag ) |
: defer? ( addr -- flag ) |
>body cell+ @ #defer = ; |
>body cell+ @ #defer = ; |
|
|
|
false Value oset? |
|
|
: o+, ( addr offset -- ) |
: o+, ( addr offset -- ) |
postpone Literal postpone ^ postpone + |
postpone Literal postpone ^ postpone + |
postpone >o drop ; |
oset? IF postpone op! ELSE postpone >o THEN drop ; |
: o*, ( addr offset -- ) |
: o*, ( addr offset -- ) |
postpone Literal postpone * postpone Literal postpone + |
postpone Literal postpone * postpone Literal postpone + |
postpone >o ; |
oset? IF postpone op! ELSE postpone >o THEN ; |
: ^+@ ( offset -- addr ) ^ + @ ; |
: ^+@ ( offset -- addr ) ^ + @ ; |
: o+@, ( addr offset -- ) |
: o+@, ( addr offset -- ) |
postpone Literal postpone ^+@ postpone >o drop ; |
postpone Literal postpone ^+@ oset? IF postpone op! ELSE postpone >o THEN drop ; |
: ^*@ ( offset -- addr ) ^ + @ tuck @ :var# + @ 8aligned * + ; |
: ^*@ ( offset -- addr ) ^ + @ tuck @ :var# + @ 8aligned * + ; |
: o+@*, ( addr offset -- ) |
: o+@*, ( addr offset -- ) |
postpone Literal postpone ^*@ postpone >o drop ; |
postpone Literal postpone ^*@ oset? IF postpone op! ELSE postpone >o THEN drop ; |
|
|
\ variables / memory allocation 30oct94py |
\ variables / memory allocation 30oct94py |
|
|
Line 171 define? faligned 0= [IF]
|
Line 181 define? faligned 0= [IF]
|
|
|
types definitions |
types definitions |
|
|
: static ( -- ) mallot Create , #static , |
: static ( -- ) \ oof- oof |
DOES> @ o@ + ; |
\G Create a class-wide cell-sized variable. |
: method ( -- ) mallot Create , #method , |
mallot Create , #static , |
DOES> @ o@ + @ execute ; |
DOES> @ o@ + ; |
: early ( -- ) Create ['] crash , #early , |
: method ( -- ) \ oof- oof |
DOES> @ execute ; |
\G Create a method selector. |
: var ( size -- ) vallot Create , #var , |
mallot Create , #method , |
DOES> @ ^ + ; |
DOES> @ o@ + @ execute ; |
: defer ( -- ) valign cell vallot Create , #defer , |
: early ( -- ) \ oof- oof |
DOES> @ ^ + @ execute ; |
\G Create a method selector for early binding. |
|
Create ['] crash , #early , |
|
DOES> @ execute ; |
|
: var ( size -- ) \ oof- oof |
|
\G Create an instance variable |
|
vallot Create , #var , |
|
DOES> @ ^ + ; |
|
: defer ( -- ) \ oof- oof |
|
\G Create an instance defer |
|
valign cell vallot Create , #defer , |
|
DOES> @ ^ + @ execute ; |
|
|
\ dealing with threads 29oct94py |
\ dealing with threads 29oct94py |
|
|
Line 216 Objects definitions
|
Line 236 Objects definitions
|
r> drop-order ; |
r> drop-order ; |
|
|
false Value method? |
false Value method? |
false Value oset? |
|
|
|
: method, ( object early? -- ) true to method? |
: method, ( object early? -- ) true to method? |
swap >o >r bl word findo 0< state @ and |
swap >o >r bl word findo 0< state @ and |
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? -- ) |
|
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 @ IF postpone o> THEN false to oset? ; |
state @ oset? and IF postpone o> THEN false to oset? ; |
: late, ( object -- ) true to oset? false method, |
: late, ( object -- ) true to oset? false method, |
state @ IF postpone o> THEN false to oset? ; |
state @ oset? and IF postpone o> THEN false to oset? ; |
|
|
\ new, 29oct94py |
\ new, 29oct94py |
|
|
Line 306 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 postpone >o 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 @ postpone >o cell+ |
IF dup postpone Literal postpone @ oset? IF postpone op! ELSE postpone >o THEN cell+ |
ELSE @ THEN late, ; |
ELSE @ THEN late, ; |
|
|
: array, ( n o -- ) alloc @ >r static new[], r> alloc ! drop |
: array, ( n o -- ) alloc @ >r static new[], r> alloc ! drop |
Line 328 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 426 Variable last-interface 0 last-interfac
|
Line 453 Variable last-interface 0 last-interfac
|
|
|
types definitions |
types definitions |
|
|
: how: ( -- ) decl @ 0= abort" not twice!" 0 decl ! |
: how: ( -- ) \ oof- oof how-to |
|
\G End declaration, start implementation |
|
decl @ 0= abort" not twice!" 0 decl ! |
align interface, |
align interface, |
lastob! thread, parent, var, 'link, 0 , cells, interfaces, |
lastob! thread, parent, var, 'link, 0 , cells, interfaces, |
dup |
dup |
IF dup :method# + @ >r :init + swap r> :init /string move |
IF dup :method# + @ >r :init + swap r> :init /string move |
ELSE 2drop THEN ; |
ELSE 2drop THEN ; |
|
|
: class; ( -- ) decl @ IF how: THEN 0 'link ! |
: class; ( -- ) \ oof- oof end-class |
voc# @ drop-order old-current @ set-current ; |
\G End class declaration or implementation |
|
decl @ IF how: THEN 0 'link ! |
|
voc# @ drop-order old-current @ set-current ; |
|
|
|
: ptr ( -- ) \ oof- oof |
|
\G Create an instance pointer |
|
Create immediate lastob @ here lastob ! instptr, ; |
|
: asptr ( class -- ) \ oof- oof |
|
\G Create an alias to an instance pointer, cast to another class. |
|
cell+ @ Create immediate |
|
lastob @ here lastob ! , , instptr> ; |
|
|
: ptr ( -- ) Create immediate lastob @ here lastob ! instptr, ; |
: Fpostpone postpone postpone ; immediate |
: asptr ( addr -- ) cell+ @ Create immediate |
|
lastob @ here lastob ! , , instptr> ; |
|
|
|
: : ( <methodname> -- ) decl @ abort" HOW: missing! " |
: : ( <methodname> -- ) \ oof- oof colon |
|
decl @ abort" HOW: missing! " |
bl word findo 0= abort" not found" |
bl word findo 0= abort" not found" |
dup exec? over early? or over >body cell+ @ 0< or |
dup exec? over early? or over >body cell+ @ 0< or |
0= abort" not a method" |
0= abort" not a method" |
Line 448 types definitions
|
Line 486 types definitions
|
|
|
Forth |
Forth |
|
|
: ; ( xt colon-sys -- ) postpone ; |
: ; ( xt colon-sys -- ) \ oof- oof |
|
postpone ; |
m-name @ dup >body swap exec? |
m-name @ dup >body swap exec? |
IF @ o@ + |
IF @ o@ + |
ELSE dup cell+ @ 0< IF 2@ swap o@ + @ + THEN |
ELSE dup cell+ @ 0< IF 2@ swap o@ + @ + THEN |
Line 468 Create object immediate 0 (class \ do
|
Line 507 Create object immediate 0 (class \ do
|
static size \ number of variables (bytes) |
static size \ number of variables (bytes) |
static newlink \ ptr to allocated space |
static newlink \ ptr to allocated space |
static ilist \ interface list |
static ilist \ interface list |
method init |
method init ( ... -- ) \ object- oof |
method dispose |
method dispose ( -- ) \ object- oof |
|
|
early class |
early class ( "name" -- ) \ object- oof |
early new immediate |
early new ( -- o ) \ object- oof |
early new[] immediate |
immediate |
early : |
early new[] ( n -- o ) \ object- oof new-array |
early ptr |
immediate |
early asptr |
early : ( "name" -- ) \ object- oof define |
early [] |
early ptr ( "name" -- ) \ object- oof |
early :: immediate |
early asptr ( o "name" -- ) \ object- oof |
early class? |
early [] ( n "name" -- ) \ object- oof array |
early super immediate |
early :: ( "name" -- ) \ object- oof scope |
early self |
immediate |
early bind immediate |
early class? ( o -- flag ) \ object- oof class-query |
early is immediate |
early super ( "name" -- ) \ object- oof |
early bound |
immediate |
early link immediate |
early self ( -- o ) \ object- oof |
early ' immediate |
early bind ( o "name" -- ) \ object- oof |
early send immediate |
immediate |
early with immediate |
early bound ( class addr "name" -- ) \ object- oof |
early endwith immediate |
early link ( "name" -- class addr ) \ object- oof |
|
immediate |
|
early is ( xt "name" -- ) \ object- oof |
|
immediate |
|
early send ( xt -- ) \ object- oof |
|
immediate |
|
early with ( o -- ) \ object- oof |
|
immediate |
|
early endwith ( -- ) \ object- oof |
|
immediate |
|
early ' ( "name" -- xt ) \ object- oof tick |
|
immediate |
|
early postpone ( "name" -- ) \ object- oof |
|
immediate |
|
early definitions ( -- ) \ object- oof |
|
|
\ base object class implementation part 23mar95py |
\ base object class implementation part 23mar95py |
|
|
how: 0 parento ! |
how: |
0 childo ! |
0 parento ! |
0 nexto ! |
0 childo ! |
: class ( -- ) Create immediate o@ (class ; |
0 nexto ! |
: : ( -- ) Create immediate o@ |
: class ( -- ) Create immediate o@ (class ; |
decl @ IF instvar, ELSE instance, THEN ; |
: : ( -- ) Create immediate o@ |
: ptr ( -- ) Create immediate o@ |
decl @ IF instvar, ELSE instance, THEN ; |
decl @ IF instptr, ELSE ptr, THEN ; |
: ptr ( -- ) Create immediate o@ |
: asptr ( addr -- ) |
decl @ IF instptr, ELSE ptr, THEN ; |
decl @ 0= abort" only in declaration!" |
: asptr ( addr -- ) |
Create immediate o@ , cell+ @ , instptr> ; |
decl @ 0= abort" only in declaration!" |
: [] ( n -- ) Create immediate o@ |
Create immediate o@ , cell+ @ , instptr> ; |
decl @ IF instarray, ELSE array, THEN ; |
: [] ( n -- ) Create immediate o@ |
: new ( -- o ) o@ state @ |
decl @ IF instarray, ELSE array, THEN ; |
IF postpone Literal postpone new, ELSE new, THEN ; |
: new ( -- o ) o@ state @ |
: new[] ( n -- o ) o@ state @ |
IF Fpostpone Literal Fpostpone new, ELSE new, THEN ; |
IF postpone Literal postpone new[], ELSE new[], THEN ; |
: new[] ( n -- o ) o@ state @ |
: dispose ( -- ) ^ size @ dispose, ; |
IF Fpostpone Literal Fpostpone new[], ELSE new[], THEN ; |
: bind ( addr -- ) (bind ; |
: dispose ( -- ) ^ size @ dispose, ; |
: bound ( o1 o2 addr2 -- ) (bound ; |
: bind ( addr -- ) (bind ; |
: link ( -- o addr ) (link ; |
: bound ( o1 o2 addr2 -- ) (bound ; |
: class? ( class -- flag ) ^ parent? nip 0<> ; |
: link ( -- o addr ) (link ; |
: :: ( -- ) |
: class? ( class -- flag ) ^ parent? nip 0<> ; |
state @ IF ^ true method, ELSE inherit THEN ; |
: :: ( -- ) |
: super ( -- ) parento true method, ; |
state @ IF ^ true method, ELSE inherit THEN ; |
: is ( cfa -- ) (is ; |
: super ( -- ) parento true method, ; |
: self ( -- obj ) ^ ; |
: is ( cfa -- ) (is ; |
: init ( -- ) ; |
: self ( -- obj ) ^ ; |
|
: init ( -- ) ; |
: ' ( -- xt ) bl word findo 0= abort" not found!" |
|
state @ IF postpone Literal THEN ; |
: ' ( -- xt ) bl word findo 0= abort" not found!" |
: send ( xt -- ) execute ; |
state @ IF Fpostpone Literal THEN ; |
|
: send ( xt -- ) execute ; |
: with ( -- ) |
: postpone ( -- ) o@ add-order Fpostpone Fpostpone drop-order ; |
state @ oset? 0= and IF postpone >o THEN |
|
o@ add-order voc# ! false to oset? |
: with ( -- ) |
r> drop state @ |
state @ oset? 0= and IF Fpostpone >o THEN |
IF o> |
o@ add-order voc# ! false to oset? ; |
ELSE oset? IF ^ THEN o> postpone >o |
: endwith Fpostpone o> voc# @ drop-order ; |
THEN |
|
r> drop r> drop ; |
: definitions |
: endwith postpone o> |
o@ add-order 1+ voc# ! also types o@ lastob ! |
voc# @ drop-order ; |
false to oset? get-current old-current ! |
|
thread @ set-current ; |
class; \ object |
class; \ object |
|
|
\ interface 01sep96py |
\ interface 01sep96py |
|
|
Objects definitions |
Objects definitions |
|
|
: implement ( interface -- ) |
: implement ( interface -- ) \ oof-interface- oof |
align here over , ob-interface @ , ob-interface ! |
align here over , ob-interface @ , ob-interface ! |
:ilist + @ >r get-order r> swap 1+ set-order 1 voc# +! ; |
:ilist + @ >r get-order r> swap 1+ set-order 1 voc# +! ; |
|
|
: inter-method, ( interface -- ) |
: inter-method, ( interface -- ) \ oof-interface- oof |
:ilist + @ bl word count 2dup s" '" compare |
:ilist + @ bl word count 2dup s" '" compare |
0= dup >r IF 2drop bl word count THEN |
0= dup >r IF 2drop bl word count THEN |
rot search-wordlist |
rot search-wordlist |
Line 560 Variable inter#
|
Line 614 Variable inter#
|
|
|
Vocabulary interfaces interfaces definitions |
Vocabulary interfaces interfaces definitions |
|
|
: method ( -- ) mallot Create , inter# @ , |
: method ( -- ) \ oof-interface- oof |
DOES> 2@ swap o@ + @ + @ execute ; |
mallot Create , inter# @ , |
|
DOES> 2@ swap o@ + @ + @ execute ; |
|
|
: how: ( -- ) align |
: how: ( -- ) \ oof-interface- oof |
|
align |
here lastif @ ! 0 decl ! |
here lastif @ ! 0 decl ! |
here last-interface @ , last-interface ! |
here last-interface @ , last-interface ! |
inter-list @ , methods @ , inter# @ , |
inter-list @ , methods @ , inter# @ , |
methods @ :inum cell+ ?DO ['] crash , LOOP ; |
methods @ :inum cell+ ?DO ['] crash , LOOP ; |
|
|
: interface; ( -- ) old-current @ set-current |
: interface; ( -- ) \ oof-interface- oof |
|
old-current @ set-current |
previous previous ; |
previous previous ; |
|
|
: : ( <methodname> -- ) decl @ abort" HOW: missing! " |
: : ( <methodname> -- ) \ oof-interface- oof colon |
|
decl @ abort" HOW: missing! " |
bl word count lastif @ @ :ilist + @ |
bl word count lastif @ @ :ilist + @ |
search-wordlist 0= abort" not found" |
search-wordlist 0= abort" not found" |
dup >body cell+ @ 0< 0= abort" not a method" |
dup >body cell+ @ 0< 0= abort" not a method" |
Line 580 Vocabulary interfaces interfaces defini
|
Line 638 Vocabulary interfaces interfaces defini
|
|
|
Forth |
Forth |
|
|
: ; ( xt colon-sys -- ) postpone ; |
: ; ( xt colon-sys -- ) \ oof-interface- oof |
|
postpone ; |
m-name @ >body @ lastif @ @ + ! ; immediate |
m-name @ >body @ lastif @ @ + ! ; immediate |
|
|
Forth definitions |
Forth definitions |
|
|
: interface ( -- ) |
: interface-does> |
Create here lastif ! 0 , get-current old-current ! |
DOES> @ decl @ IF implement ELSE inter-method, THEN ; |
|
: interface ( -- ) \ oof-interface- oof |
|
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 |
|
|
\ The program uses the following words |
|
\ from CORE : |
|
\ decimal : bl word 0= ; cells Constant POSTPONE IF EXIT THEN immediate |
|
\ Create , DOES> @ >r r> swap + and Variable ! allot ELSE +! dup * >body |
|
\ cell+ = Literal drop align here aligned execute ['] 2@ recurse 1+ over |
|
\ LOOP ?dup 0< rot r@ - i negate +LOOP 2drop BEGIN WHILE 2dup REPEAT 1- |
|
\ rshift > / ' move UNTIL or count |
|
\ from CORE-EXT : |
|
\ nip tuck true ?DO compile, false Value erase pick :noname 0<> |
|
\ from BLOCK-EXT : |
|
\ \ |
|
\ from EXCEPTION : |
|
\ throw |
|
\ from EXCEPTION-EXT : |
|
\ abort" |
|
\ from FILE : |
|
\ ( S" |
|
\ from FLOAT : |
|
\ faligned |
|
\ from LOCAL : |
|
\ TO |
|
\ from MEMORY : |
|
\ allocate free |
|
\ from SEARCH : |
|
\ find wordlist get-order set-order definitions get-current set-current search-wordlist |
|
\ from SEARCH-EXT : |
|
\ also Forth previous |
|
\ from STRING : |
|
\ /string compare |
|
\ from TOOLS-EXT : |
|
\ state [IF] [THEN] |
|