version 1.2, 1996/09/24 19:15:04
|
version 1.10, 1997/07/02 20:30:06
|
Line 7
|
Line 7
|
\ |
\ |
\ Thank you. |
\ Thank you. |
\ |
\ |
|
\ The program uses the following words |
|
\ from CORE : |
|
\ decimal : bl word 0= ; = cells Constant Variable ! Create , allot @ IF |
|
\ POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+ Literal drop |
|
\ align here aligned DOES> execute ['] 2@ recurse swap 1+ over LOOP and |
|
\ EXIT ?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 definitions get-order set-order get-current wordlist set-current |
|
\ search-wordlist |
|
\ from SEARCH-EXT : |
|
\ also Forth previous |
|
\ from STRING : |
|
\ /string compare |
|
\ from TOOLS-EXT : |
|
\ [IF] [THEN] [ELSE] state |
|
|
\ Loadscreen 27dec95py |
\ Loadscreen 27dec95py |
|
|
Line 15 decimal
|
Line 47 decimal
|
: define? ( -- flag ) |
: define? ( -- flag ) |
bl word find nip 0= ; |
bl word find nip 0= ; |
|
|
define? cell [IF] 1 cells Constant cell [THEN] |
define? cell [IF] |
|
1 cells Constant cell |
|
[THEN] |
|
|
define? ?EXIT [IF] |
define? ?EXIT [IF] |
: ?EXIT postpone IF postpone EXIT postpone THEN ; immediate |
: ?EXIT postpone IF postpone EXIT postpone THEN ; immediate |
Line 26 define? Vocabulary [IF]
|
Line 60 define? Vocabulary [IF]
|
DOES> @ >r get-order nip r> swap set-order ; |
DOES> @ >r get-order nip r> swap set-order ; |
[THEN] |
[THEN] |
|
|
|
define? faligned [IF] false [ELSE] 1 faligned 8 = [THEN] |
|
[IF] |
|
: 8aligned ( n1 -- n2 ) faligned ; |
|
[ELSE] |
|
: 8aligned ( n1 -- n2 ) 7 + -8 and ; |
|
[THEN] |
|
|
Vocabulary Objects also Objects also definitions |
Vocabulary Objects also Objects also definitions |
|
|
Vocabulary types types also |
Vocabulary types types also |
Line 85 Objects definitions
|
Line 126 Objects definitions
|
: defer? ( addr -- flag ) |
: defer? ( addr -- flag ) |
>body cell+ @ #defer = ; |
>body cell+ @ #defer = ; |
|
|
define? faligned [IF] false [ELSE] 1 faligned 8 = [THEN] |
false Value oset? |
[IF] : 8aligned ( n1 -- n2 ) faligned ; |
|
[ELSE] : 8aligned ( n1 -- n2 ) 7 + -8 and ; |
|
[THEN] |
|
|
|
: 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 157 Objects definitions
|
Line 195 Objects definitions
|
dup IF 2@ >r recurse r> :ilist + @ swap 1+ |
dup IF 2@ >r recurse r> :ilist + @ swap 1+ |
ELSE drop THEN ; |
ELSE drop THEN ; |
|
|
: add-order ( addr -- n ) >r |
: add-order ( addr -- n ) dup 0= ?EXIT >r |
get-order r> swap >r 0 swap object-order |
get-order r> swap >r 0 swap |
|
dup >r object-order r> :iface + @ interface-order |
r> over >r + set-order r> ; |
r> over >r + set-order r> ; |
|
|
: drop-order ( n -- ) 0 ?DO previous LOOP ; |
: drop-order ( n -- ) 0 ?DO previous LOOP ; |
Line 173 Objects definitions
|
Line 212 Objects definitions
|
drop dup early? IF >body @ THEN compile, ; |
drop dup early? IF >body @ THEN compile, ; |
|
|
: findo ( string -- cfa n ) |
: findo ( string -- cfa n ) |
>r get-order 0 |
o@ add-order >r |
o@ object-order |
find |
o@ :iface + @ interface-order set-order |
|
r> find |
|
?dup 0= IF drop set-order true abort" method not found!" THEN |
?dup 0= IF drop set-order true abort" method not found!" THEN |
>r >r set-order r> r> ; |
r> drop-order ; |
|
|
false Value method? |
false Value method? |
|
|
: 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? ; |
|
|
: early, ( object -- ) true method, |
: cmethod, ( object early? -- ) |
state @ IF postpone o> THEN ; |
state @ >r state on method, r> state ! ; |
: late, ( object -- ) false method, |
|
state @ IF postpone o> THEN ; |
: early, ( object -- ) true to oset? true method, |
|
state @ oset? and IF postpone o> THEN false to oset? ; |
|
: late, ( object -- ) true to oset? false method, |
|
state @ oset? and IF postpone o> THEN false to oset? ; |
|
|
\ new, 29oct94py |
\ new, 29oct94py |
|
|
Line 241 Create chunks here 16 cells dup allot er
|
Line 282 Create chunks here 16 cells dup allot er
|
>r drop r@ @ rot ! r@ swap erase r> ; |
>r drop r@ @ rot ! r@ swap erase r> ; |
|
|
: >chunk ( n -- root n' ) |
: >chunk ( n -- root n' ) |
8aligned dup 3 rshift cells chunks + swap ; |
1- -8 and dup 3 rshift cells chunks + swap 8 + ; |
|
|
: Dalloc ( size -- addr ) |
: Dalloc ( size -- addr ) |
dup 128 > IF allocate throw EXIT THEN |
dup 128 > IF allocate throw EXIT THEN |
Line 269 Objects definitions
|
Line 310 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 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 403 types definitions
|
Line 444 types definitions
|
: asptr ( addr -- ) cell+ @ Create immediate |
: asptr ( addr -- ) cell+ @ Create immediate |
lastob @ here lastob ! , , instptr> ; |
lastob @ here lastob ! , , instptr> ; |
|
|
|
: Fpostpone postpone postpone ; immediate |
|
|
: : ( <methodname> -- ) decl @ abort" HOW: missing! " |
: : ( <methodname> -- ) 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 |
Line 451 Create object immediate 0 (class \ do
|
Line 494 Create object immediate 0 (class \ do
|
early link immediate |
early link immediate |
early ' immediate |
early ' immediate |
early send immediate |
early send immediate |
|
early with immediate |
|
early endwith immediate |
|
early postpone immediate |
|
|
\ base object class implementation part 23mar95py |
\ base object class implementation part 23mar95py |
|
|
how: 0 parento ! |
how: 0 parento ! |
0 childo ! |
0 childo ! |
0 nexto ! |
0 nexto ! |
: class ( -- ) Create immediate o@ (class ; |
: class ( -- ) Create immediate o@ (class ; |
: : ( -- ) Create immediate o@ |
: : ( -- ) Create immediate o@ |
decl @ IF instvar, ELSE instance, THEN ; |
decl @ IF instvar, ELSE instance, THEN ; |
: ptr ( -- ) Create immediate o@ |
: ptr ( -- ) Create immediate o@ |
decl @ IF instptr, ELSE ptr, THEN ; |
decl @ IF instptr, ELSE ptr, THEN ; |
: asptr ( addr -- ) |
: asptr ( addr -- ) |
decl @ 0= abort" only in declaration!" |
decl @ 0= abort" only in declaration!" |
Create immediate o@ , cell+ @ , instptr> ; |
Create immediate o@ , cell+ @ , instptr> ; |
: [] ( n -- ) Create immediate o@ |
: [] ( n -- ) Create immediate o@ |
decl @ IF instarray, ELSE array, THEN ; |
decl @ IF instarray, ELSE array, THEN ; |
: new ( -- o ) o@ state @ |
: new ( -- o ) o@ state @ |
IF postpone Literal postpone new, ELSE new, THEN ; |
IF Fpostpone Literal Fpostpone new, ELSE new, THEN ; |
: new[] ( n -- o ) o@ state @ |
: new[] ( n -- o ) o@ state @ |
IF postpone Literal postpone new[], ELSE new[], THEN ; |
IF Fpostpone Literal Fpostpone new[], ELSE new[], THEN ; |
: dispose ( -- ) ^ size @ dispose, ; |
: dispose ( -- ) ^ size @ dispose, ; |
: bind ( addr -- ) (bind ; |
: bind ( addr -- ) (bind ; |
: bound ( o1 o2 addr2 -- ) (bound ; |
: bound ( o1 o2 addr2 -- ) (bound ; |
: link ( -- o addr ) (link ; |
: link ( -- o addr ) (link ; |
: class? ( class -- flag ) ^ parent? nip 0<> ; |
: class? ( class -- flag ) ^ parent? nip 0<> ; |
: :: ( -- ) |
: :: ( -- ) |
state @ IF ^ true method, ELSE inherit THEN ; |
state @ IF ^ true method, ELSE inherit THEN ; |
: super ( -- ) parento true method, ; |
: super ( -- ) parento true method, ; |
: is ( cfa -- ) (is ; |
: is ( cfa -- ) (is ; |
: self ( -- obj ) ^ ; |
: self ( -- obj ) ^ ; |
: init ( -- ) ; |
: init ( -- ) ; |
|
|
: ' ( -- xt ) bl word findo 0= abort" not found!" |
: ' ( -- xt ) bl word findo 0= abort" not found!" |
state @ IF postpone Literal THEN ; |
state @ IF Fpostpone Literal THEN ; |
: send ( xt -- ) execute ; |
: send ( xt -- ) execute ; |
|
: postpone ( -- ) o@ add-order Fpostpone Fpostpone drop-order ; |
|
|
|
: with ( -- ) |
|
state @ oset? 0= and IF Fpostpone >o THEN |
|
o@ add-order voc# ! false to oset? ; |
|
: endwith Fpostpone o> |
|
voc# @ drop-order ; |
class; \ object |
class; \ object |
|
|
\ interface 01sep96py |
\ interface 01sep96py |
Line 515 Vocabulary interfaces interfaces defini
|
Line 568 Vocabulary interfaces interfaces defini
|
|
|
: how: ( -- ) align |
: how: ( -- ) align |
here lastif @ ! 0 decl ! |
here lastif @ ! 0 decl ! |
last-interface @ , inter-list @ , methods @ , inter# @ , |
here last-interface @ , last-interface ! |
|
inter-list @ , methods @ , inter# @ , |
methods @ :inum cell+ ?DO ['] crash , LOOP ; |
methods @ :inum cell+ ?DO ['] crash , LOOP ; |
|
|
: interface; ( -- ) old-current @ set-current |
: interface; ( -- ) old-current @ set-current |
Line 544 Forth definitions
|
Line 598 Forth definitions
|
DOES> @ decl @ IF implement ELSE inter-method, THEN ; |
DOES> @ decl @ IF implement ELSE inter-method, THEN ; |
|
|
previous previous |
previous previous |
|
|