version 1.4, 1996/11/18 21:28:18
|
version 1.5, 1997/01/25 20:53:02
|
Line 157 Objects definitions
|
Line 157 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 174 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? |
|
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? ; |
|
|
: early, ( object -- ) true method, |
: early, ( object -- ) true to oset? true method, |
state @ IF postpone o> THEN ; |
state @ IF postpone o> THEN false to oset? ; |
: late, ( object -- ) false method, |
: late, ( object -- ) true to oset? false method, |
state @ IF postpone o> THEN ; |
state @ IF postpone o> THEN false to oset? ; |
|
|
\ new, 29oct94py |
\ new, 29oct94py |
|
|
Line 272 Objects definitions
|
Line 273 Objects definitions
|
DOES> state @ IF dup postpone Literal postpone >o THEN early, ; |
DOES> state @ IF dup postpone Literal postpone >o THEN early, ; |
: ptr, ( o -- ) 0 , , |
: ptr, ( o -- ) 0 , , |
DOES> state @ |
DOES> state @ |
IF postpone Literal postpone @ postpone >o cell+ |
IF dup postpone Literal postpone @ postpone >o 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 372 Variable last-interface 0 last-interfac
|
Line 373 Variable last-interface 0 last-interfac
|
|
|
: lastob! ( -- ) lastob @ dup |
: lastob! ( -- ) lastob @ dup |
BEGIN nip dup @ here cell+ 2 pick ! dup 0= UNTIL drop |
BEGIN nip dup @ here cell+ 2 pick ! dup 0= UNTIL drop |
dup , [ order ] op! o@ lastob ! ; |
dup , op! o@ lastob ! ; |
|
|
: thread, ( -- ) classlist @ , ; |
: thread, ( -- ) classlist @ , ; |
: var, ( -- ) methods @ , vars @ , ; |
: var, ( -- ) methods @ , vars @ , ; |
Line 451 Create object immediate 0 (class \ do
|
Line 452 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 |
|
|
\ 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 postpone Literal postpone new, ELSE new, THEN ; |
: new[] ( n -- o ) o@ state @ |
: new[] ( n -- o ) o@ state @ |
IF postpone Literal postpone new[], ELSE new[], THEN ; |
IF postpone Literal postpone 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 postpone Literal THEN ; |
: send ( xt -- ) execute ; |
: send ( xt -- ) execute ; |
|
|
|
: with ( -- ) |
|
state @ oset? 0= and IF postpone >o THEN |
|
o@ add-order voc# ! false to oset? |
|
rdrop state @ |
|
IF o> |
|
ELSE oset? IF ^ THEN o> postpone >o |
|
THEN |
|
rdrop rdrop ; |
|
: endwith postpone o> |
|
voc# @ drop-order ; |
class; \ object |
class; \ object |
|
|
\ interface 01sep96py |
\ interface 01sep96py |