version 1.10, 1997/07/02 20:30:06
|
version 1.14, 1999/02/16 06:32:29
|
Line 173 define? faligned 0= [IF]
|
Line 173 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 430 Variable last-interface 0 last-interfac
|
Line 440 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 ! |
: ptr ( -- ) Create immediate lastob @ here lastob ! instptr, ; |
voc# @ drop-order old-current @ set-current ; |
: asptr ( addr -- ) cell+ @ Create immediate |
|
lastob @ here lastob ! , , instptr> ; |
: 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> ; |
|
|
: Fpostpone postpone postpone ; immediate |
: Fpostpone postpone postpone ; immediate |
|
|
: : ( <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 454 types definitions
|
Line 473 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 474 Create object immediate 0 (class \ do
|
Line 494 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 |
early postpone immediate |
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 Fpostpone Literal Fpostpone new, ELSE new, THEN ; |
: new ( -- o ) o@ state @ |
: new[] ( n -- o ) o@ state @ |
IF Fpostpone Literal Fpostpone new, ELSE new, THEN ; |
IF Fpostpone Literal Fpostpone 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 Fpostpone Literal THEN ; |
: ' ( -- xt ) bl word findo 0= abort" not found!" |
: send ( xt -- ) execute ; |
state @ IF Fpostpone Literal THEN ; |
: postpone ( -- ) o@ add-order Fpostpone Fpostpone drop-order ; |
: send ( xt -- ) execute ; |
|
: postpone ( -- ) o@ add-order Fpostpone Fpostpone drop-order ; |
: with ( -- ) |
|
state @ oset? 0= and IF Fpostpone >o THEN |
: with ( -- ) |
o@ add-order voc# ! false to oset? ; |
state @ oset? 0= and IF Fpostpone >o THEN |
: endwith Fpostpone o> |
o@ add-order voc# ! false to oset? ; |
voc# @ drop-order ; |
: endwith Fpostpone o> voc# @ drop-order ; |
|
|
|
: definitions |
|
o@ add-order 1+ voc# ! also types o@ lastob ! |
|
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 563 Variable inter#
|
Line 601 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 583 Vocabulary interfaces interfaces defini
|
Line 625 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 ( -- ) \ oof-interface- oof |
Create here lastif ! 0 , get-current old-current ! |
Create 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 |