version 1.3, 1997/06/06 17:27:57
|
version 1.15, 1999/07/05 19:56:01
|
Line 1
|
Line 1
|
\ yet another Forth objects extension |
\ yet another Forth objects extension |
|
|
\ written by Anton Ertl 1996, 1997 |
\ written by Anton Ertl 1996-1999 |
\ public domain |
\ public domain; NO WARRANTY |
|
|
\ This (in combination with compat/struct.fs) is in ANS Forth (with an |
\ This (in combination with compat/struct.fs) is in ANS Forth (with an |
\ environmental dependence on case insensitivity; convert everything |
\ environmental dependence on case insensitivity; convert everything |
\ to upper case for state sensitive systems). |
\ to upper case for state sensitive systems). |
|
|
\ If you don't use Gforth, you have to load compat/struct.fs first. |
|
\ compat/struct.fs and this file together use the following words: |
\ compat/struct.fs and this file together use the following words: |
|
|
\ from CORE : |
\ from CORE : |
\ : 1- + swap invert and ; DOES> @ immediate drop Create >r rot r@ dup |
\ : 1- + swap invert and ; DOES> @ immediate drop Create rot dup , >r |
\ , IF ELSE THEN r> chars cells 2* here - allot over execute POSTPONE |
\ r> IF ELSE THEN over chars aligned cells 2* here - allot execute |
\ ?dup 2dup move 2! Variable 2@ ! ['] >body = 2drop ' +! Constant |
\ POSTPONE ?dup 2dup move Variable 2@ 2! ! ['] >body = 2drop ' r@ +! |
\ recurse 1+ BEGIN 0= UNTIL negate Literal ." . |
\ Constant recurse 1+ BEGIN 0= UNTIL negate Literal ." . |
\ from CORE-EXT : |
\ from CORE-EXT : |
\ tuck nip true <> 0> erase Value :noname compile, |
\ tuck pick nip true <> 0> erase Value :noname compile, |
\ from BLOCK-EXT : |
\ from BLOCK-EXT : |
\ \ |
\ \ |
\ from DOUBLE : |
\ from DOUBLE : |
Line 28
|
Line 27
|
\ from FILE : |
\ from FILE : |
\ ( |
\ ( |
\ from FLOAT : |
\ from FLOAT : |
\ floats |
\ faligned floats |
\ from FLOAT-EXT : |
\ from FLOAT-EXT : |
\ dfloats sfloats |
\ dfaligned dfloats sfaligned sfloats |
\ from LOCAL : |
\ from LOCAL : |
\ TO |
\ TO |
\ from MEMORY : |
\ from MEMORY : |
Line 38
|
Line 37
|
\ from SEARCH : |
\ from SEARCH : |
\ get-order set-order wordlist get-current set-current |
\ get-order set-order wordlist get-current set-current |
|
|
\ --------------------------------------- |
|
\ MANUAL: |
|
|
|
\ A class is defined like this: |
|
|
|
\ <parent> class |
|
\ ... field <name> |
|
\ ... |
|
|
|
\ ... inst-var <name> |
|
\ ... |
|
|
|
\ selector <name> |
|
|
|
\ :noname ( ... object -- ... ) |
|
\ ... ; |
|
\ method <name> \ new method |
|
\ ... |
|
|
|
\ :noname ( ... object -- ... ) |
|
\ ... ; |
|
\ overrides <name> \ existing method |
|
\ ... |
|
|
|
\ end-class <name> |
|
|
|
\ you can write fields, inst-vars, selectors, methods and overrides in |
|
\ any order. |
|
|
|
\ A call of a method looks like this: |
|
|
|
\ ... <object> <method> |
|
|
|
\ (<object> just needs to reside on the stack, there's no need to name it). |
|
|
|
\ Instead of defining a method with ':noname ... ;', you can define it |
|
\ also with 'm: ... ;m'. The difference is that with ':noname' the |
|
\ "self" object is on the top of stack; with 'm:' you can get it with |
|
\ 'this'. You should use 'this' only in an 'm:' method even though the |
|
\ sample implementation does not enforce this. |
|
|
|
\ The difference between a field and and inst-var is that the field |
|
\ refers to an object at the top of data stack (i.e. a field has the |
|
\ stack effect (object -- addr), whereas the inst-var refers to this |
|
\ (i.e., it has the stack effect ( -- addr )); obviously, an inst-var |
|
\ can only be used in an 'm:' method. |
|
|
|
\ 'method' defines a new method selector and binds a method to it. |
|
|
|
\ 'selector' defines a new method selector without binding a method to |
|
\ it (you can use this to define abstract classes) |
|
|
|
\ 'overrides' binds a different method (than the parent class) to an |
|
\ existing method selector. |
|
|
|
\ If you want to perform early binding, you can do it like this: |
|
|
|
\ ... <object> [bind] <class> <method> \ compilation |
|
\ ... <object> bind <class> <method> \ interpretation |
|
|
|
\ You can get at the method from the method selector and the class like |
|
\ this: |
|
|
|
\ bind' <class> <method> |
|
|
|
|
|
\ An interface is defined like this: |
|
|
|
\ interface |
|
\ selector <name> |
|
\ : noname ( ... object -- ... ) |
|
\ ... ; |
|
\ method <name> |
|
\ ... |
|
\ end-interface <name> |
|
|
|
\ You can only define new selectors in an interface definition, no |
|
\ fields or instance variables. If you define a selector with |
|
\ 'method', the corresponding method becomes the default method for |
|
\ this selector. |
|
|
|
\ An interface is used like this: |
|
|
|
\ <parent> class |
|
\ <interface> implementation |
|
\ <interface> implementation |
|
|
|
\ :noname ( ... -- ... ) |
|
\ ... ; |
|
\ overrides <selector> |
|
|
|
\ end-class name |
|
|
|
\ a class inherits all interfaces of its parent. An 'implementation' |
|
\ means that the class also implements the specified interface (If the |
|
\ interface is already implemented by the parent class, an |
|
\ 'implementation' phrase resets the methods to the defaults. |
|
|
|
\ 'overrides' can also be used to override interface methods. It has |
|
\ to be used after announcing the 'implementation' of the |
|
\ interface. Apart from this, 'implementation' can be freely mixed |
|
\ with the other stuff (but I recommend to put all 'implementation' |
|
\ phrases at the beginning of the class definition). |
|
|
|
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ |
|
|
|
\ needs struct.fs |
\ needs struct.fs |
|
|
\ helper words |
\ helper words |
|
|
|
s" gforth" environment? [if] |
|
2drop |
|
[else] |
|
|
: -rot ( a b c -- c a b ) |
: -rot ( a b c -- c a b ) |
rot rot ; |
rot rot ; |
|
|
: under+ ( a b c -- a+b c ) |
|
rot + swap ; |
|
|
|
: perform ( ... addr -- ... ) |
: perform ( ... addr -- ... ) |
@ execute ; |
@ execute ; |
|
|
Line 176
|
Line 70
|
|
|
: extend-mem ( addr1 u1 u -- addr addr2 u2 ) |
: extend-mem ( addr1 u1 u -- addr addr2 u2 ) |
\ extend memory block allocated from the heap by u aus |
\ extend memory block allocated from the heap by u aus |
\ the (possibly reallocated piece is addr2 u2, the extension is at addr ) |
\ the (possibly reallocated) piece is addr2 u2, the extension is at addr |
over >r + dup >r resize throw |
over >r + dup >r resize throw |
r> over r> + -rot ; |
r> over r> + -rot ; |
|
|
: 2, ( w1 w2 -- ) \ gforth |
: \g ( -- ) |
here 2 cells allot 2! ; |
postpone \ ; immediate |
|
[then] |
|
|
\ data structures |
\ data structures |
|
|
struct |
struct |
1 cells: field object-map |
cell% field object-map |
end-struct object-struct |
end-struct object% |
|
|
struct |
struct |
2 cells: field interface-map |
cell% 2* field interface-map |
1 cells: field interface-map-offset \ aus |
cell% field interface-map-offset \ aus |
\ difference between where interface-map points and where |
\ difference between where interface-map points and where |
\ object-map points (0 for non-classes) |
\ object-map points (0 for non-classes) |
1 cells: field interface-offset \ aus |
cell% field interface-offset \ aus |
\ offset of interface map-pointer in class-map (0 for classes) |
\ offset of interface map-pointer in class-map (0 for classes) |
end-struct interface-struct |
end-struct interface% |
|
|
interface-struct |
interface% |
1 cells: field class-parent |
cell% field class-parent |
1 cells: field class-wordlist \ instance variables and other private words |
cell% field class-wordlist \ inst-vars and other protected words |
2 cells: field class-inst-size \ size and alignment |
cell% 2* field class-inst-size ( class -- addr ) \ objects- objects |
end-struct class-struct |
\g Give the size specification for an instance (i.e. an object) |
|
\g of @var{class}; |
|
\g used as @code{class-inst-size 2@ ( class -- align size )}. |
|
end-struct class% |
|
|
struct |
struct |
1 cells: field selector-offset \ the offset within the (interface) map |
cell% field selector-offset \ the offset within the (interface) map |
1 cells: field selector-interface \ the interface offset |
cell% field selector-interface \ the interface offset |
end-struct selector-struct |
end-struct selector% |
|
|
\ maps are not defined explicitly; they have the following structure: |
\ maps are not defined explicitly; they have the following structure: |
|
|
\ pointers to interface maps (for classes) <- interface-map points here |
\ pointers to interface maps (for classes) <- interface-map points here |
\ interface/class-struct pointer <- (object-)map points here |
\ interface%/class% pointer <- (object-)map points here |
\ xts of methods |
\ xts of methods |
|
|
|
|
Line 220 end-struct selector-struct
|
Line 118 end-struct selector-struct
|
|
|
\ selectors and methods |
\ selectors and methods |
|
|
variable current-interface |
variable current-interface ( -- addr ) \ objects- objects |
|
\g Variable: contains the class or interface currently being |
|
\g defined. |
|
|
|
|
|
|
: no-method ( -- ) |
: no-method ( -- ) |
true abort" no method defined for this object/selector combination" ; |
true abort" no method defined for this object/selector combination" ; |
|
|
: do-class-method ( -- ) |
: do-class-method ( -- ) |
does> ( ... object -- ... ) |
does> ( ... object -- ... ) |
( object ) |
( object selector-body ) |
selector-offset @ over object-map @ + ( object xtp ) perform ; |
selector-offset @ over object-map @ + ( object xtp ) perform ; |
|
|
: do-interface-method ( -- ) |
: do-interface-method ( -- ) |
Line 237 does> ( ... object -- ... )
|
Line 139 does> ( ... object -- ... )
|
swap object-map @ + @ ( object selector-body map ) |
swap object-map @ + @ ( object selector-body map ) |
swap selector-offset @ + perform ; |
swap selector-offset @ + perform ; |
|
|
: method ( xt "name" -- ) |
: method ( xt "name" -- ) \ objects- objects |
\ define selector with method xt |
\g @code{name} execution: @code{... object -- ...}@* |
|
\g Create selector @var{name} and makes @var{xt} its method in |
|
\g the current class. |
create |
create |
current-interface @ interface-map 2@ ( xt map-addr map-size ) |
current-interface @ interface-map 2@ ( xt map-addr map-size ) |
dup current-interface @ interface-map-offset @ - , |
dup current-interface @ interface-map-offset @ - , |
Line 250 does> ( ... object -- ... )
|
Line 154 does> ( ... object -- ... )
|
do-class-method |
do-class-method |
then ; |
then ; |
|
|
: selector ( "name" -- ) |
: selector ( "name" -- ) \ objects- objects |
\ define a method selector for later overriding in subclasses |
\g @var{name} execution: @code{... object -- ...}@* |
|
\g Create selector @var{name} for the current class and its |
|
\g descendents; you can set a method for the selector in the |
|
\g current class with @code{overrides}. |
['] no-method method ; |
['] no-method method ; |
|
|
: interface-override! ( xt sel-xt interface-map -- ) |
: interface-override! ( xt sel-xt interface-map -- ) |
Line 259 does> ( ... object -- ... )
|
Line 166 does> ( ... object -- ... )
|
swap >body ( xt map selector-body ) |
swap >body ( xt map selector-body ) |
selector-offset @ + ! ; |
selector-offset @ + ! ; |
|
|
: class->map ( class -- map ) |
: class->map ( class -- map ) \ objects- objects |
\ compute the (object-)map for the class |
\g @var{map} is the pointer to @var{class}'s method map; it |
|
\g points to the place in the map to which the selector offsets |
|
\g refer (i.e., where @var{object-map}s point to). |
dup interface-map 2@ drop swap interface-map-offset @ + ; |
dup interface-map 2@ drop swap interface-map-offset @ + ; |
|
|
: unique-interface-map ( class-map offset -- ) |
: unique-interface-map ( class-map offset -- ) |
Line 268 does> ( ... object -- ... )
|
Line 177 does> ( ... object -- ... )
|
\ copy it to make it unique; used for implementing a copy-on-write policy |
\ copy it to make it unique; used for implementing a copy-on-write policy |
over @ class-parent @ class->map ( class-map offset parent-map ) |
over @ class-parent @ class->map ( class-map offset parent-map ) |
over + @ >r \ the map for the interface for the parent |
over + @ >r \ the map for the interface for the parent |
+ dup @ ( mapp map ) |
+ dup @ ( interface-mapp interface-map ) |
dup r> = |
dup r> = |
if |
if |
@ interface-map 2@ save-mem drop |
dup @ interface-map 2@ nip save-mem drop |
swap ! |
swap ! |
else |
else |
2drop |
2drop |
then ; |
then ; |
|
|
: class-override! ( xt sel-xt class-map -- ) |
: class-override! ( xt sel-xt class-map -- ) \ objects- objects |
\ xt is the new method for the selector sel-xt in class-map |
\g @var{xt} is the new method for the selector @var{sel-xt} in |
|
\g @var{class-map}. |
over >body ( xt sel-xt class-map selector-body ) |
over >body ( xt sel-xt class-map selector-body ) |
selector-interface @ ( xt sel-xt class-map offset ) |
selector-interface @ ( xt sel-xt class-map offset ) |
?dup-if \ the selector is for an interface |
?dup-if \ the selector is for an interface |
Line 287 does> ( ... object -- ... )
|
Line 197 does> ( ... object -- ... )
|
then |
then |
interface-override! ; |
interface-override! ; |
|
|
: overrides ( xt "selector" -- ) |
: overrides ( xt "selector" -- ) \ objects- objects |
\ replace default method "method" in the current class with xt |
\g replace default method for @var{selector} in the current class |
\ must not be used during an interface definition |
\g with @var{xt}. @code{overrides} must not be used during an |
|
\g interface definition. |
' current-interface @ class->map class-override! ; |
' current-interface @ class->map class-override! ; |
|
|
\ interfaces |
\ interfaces |
Line 297 does> ( ... object -- ... )
|
Line 208 does> ( ... object -- ... )
|
\ every interface gets a different offset; the latest one is stored here |
\ every interface gets a different offset; the latest one is stored here |
variable last-interface-offset 0 last-interface-offset ! |
variable last-interface-offset 0 last-interface-offset ! |
|
|
: interface ( -- ) |
: interface ( -- ) \ objects- objects |
interface-struct struct-allot >r |
\g Start an interface definition. |
0 0 r@ interface-map 2! |
interface% %allot >r |
|
r@ current-interface ! |
|
current-interface 1 cells save-mem r@ interface-map 2! |
-1 cells last-interface-offset +! |
-1 cells last-interface-offset +! |
last-interface-offset @ r@ interface-offset ! |
last-interface-offset @ r@ interface-offset ! |
0 r@ interface-map-offset ! |
0 r> interface-map-offset ! ; |
r> current-interface ! ; |
|
|
|
: end-interface-noname ( -- interface ) |
: end-interface-noname ( -- interface ) \ objects- objects |
|
\g End an interface definition. The resulting interface is |
|
\g @var{interface}. |
current-interface @ ; |
current-interface @ ; |
|
|
: end-interface ( "name" -- ) |
: end-interface ( "name" -- ) \ objects- objects |
\ name execution: ( -- interface ) |
\g @code{name} execution: @code{-- interface}@* |
|
\g End an interface definition. The resulting interface is |
|
\g @var{interface}. |
end-interface-noname constant ; |
end-interface-noname constant ; |
|
|
|
\ visibility control |
|
|
|
variable public-wordlist |
|
|
|
: protected ( -- ) \ objects- objects |
|
\g Set the compilation wordlist to the current class's wordlist |
|
current-interface @ class-wordlist @ |
|
dup get-current <> |
|
if \ we are not protected already |
|
get-current public-wordlist ! |
|
then |
|
set-current ; |
|
|
|
: public ( -- ) \ objects- objects |
|
\g Restore the compilation wordlist that was in effect before the |
|
\g last @code{protected} that actually changed the compilation |
|
\g wordlist. |
|
current-interface @ class-wordlist @ get-current = |
|
if \ we are protected |
|
public-wordlist @ set-current |
|
then ; |
|
|
\ classes |
\ classes |
|
|
: add-class-order ( n1 class -- wid1 ... widn n+n1 ) |
: add-class-order ( n1 class -- wid1 ... widn n+n1 ) |
Line 321 variable last-interface-offset 0 last-in
|
Line 259 variable last-interface-offset 0 last-in
|
then |
then |
r> class-wordlist @ swap 1+ ; |
r> class-wordlist @ swap 1+ ; |
|
|
: push-order ( class -- ) |
: push-order ( class -- ) \ objects- objects |
\ add the class's wordlist to the search-order (in front) |
\g Add @var{class}'s wordlists to the head of the search-order. |
>r get-order r> add-class-order set-order ; |
>r get-order r> add-class-order set-order ; |
|
|
: class ( parent-class -- size align ) |
: methods ( class -- ) \ objects- objects |
class-struct struct-allot >r |
\g Makes @var{class} the current class. This is intended to be |
|
\g used for defining methods to override selectors; you cannot |
|
\g define new fields or selectors. |
|
dup current-interface ! push-order ; |
|
|
|
: class ( parent-class -- align offset ) \ objects- objects |
|
\g Start a new class definition as a child of |
|
\g @var{parent-class}. @var{align offset} are for use by |
|
\g @var{field} etc. |
|
class% %allot >r |
dup interface-map 2@ save-mem r@ interface-map 2! |
dup interface-map 2@ save-mem r@ interface-map 2! |
dup interface-map-offset @ r@ interface-map-offset ! |
dup interface-map-offset @ r@ interface-map-offset ! |
r@ dup class->map ! |
r@ dup class->map ! |
0 r@ interface-offset ! |
0 r@ interface-offset ! |
dup r@ class-parent ! |
dup r@ class-parent ! |
wordlist r@ class-wordlist ! |
wordlist r@ class-wordlist ! |
r@ current-interface ! |
r> methods |
r> push-order |
|
class-inst-size 2@ ; |
class-inst-size 2@ ; |
|
|
: remove-class-order ( wid1 ... widn n+n1 class -- n1 ) |
: remove-class-order ( wid1 ... widn n+n1 class -- n1 ) |
Line 345 variable last-interface-offset 0 last-in
|
Line 291 variable last-interface-offset 0 last-in
|
until |
until |
drop ; |
drop ; |
|
|
: drop-order ( class -- ) |
: drop-order ( class -- ) \ objects- objects |
\ note: no checks, whether the wordlists are correct |
\g Drop @var{class}'s wordlists from the search order. No |
|
\g checking is made whether @var{class}'s wordlists are actually |
|
\g on the search order. |
>r get-order r> remove-class-order set-order ; |
>r get-order r> remove-class-order set-order ; |
|
|
: end-class-noname ( size align -- class ) |
: end-methods ( -- ) \ objects- objects |
current-interface @ dup drop-order class-inst-size 2! |
\g Switch back from defining methods of a class to normal mode |
|
\g (currently this just restores the old search order). |
|
current-interface @ drop-order ; |
|
|
|
: end-class-noname ( align offset -- class ) \ objects- objects |
|
\g End a class definition. The resulting class is @var{class}. |
|
public end-methods |
|
current-interface @ class-inst-size 2! |
end-interface-noname ; |
end-interface-noname ; |
|
|
: end-class ( size align "name" -- ) |
: end-class ( align offset "name" -- ) \ objects- objects |
|
\g @var{name} execution: @code{-- class}@* |
|
\g End a class definition. The resulting class is @var{class}. |
\ name execution: ( -- class ) |
\ name execution: ( -- class ) |
end-class-noname constant ; |
end-class-noname constant ; |
|
|
\ visibility control |
|
|
|
variable public-wordlist |
|
|
|
: private ( -- ) |
|
current-interface @ class-wordlist @ |
|
dup get-current <> |
|
if \ we are not private already |
|
get-current public-wordlist ! |
|
then |
|
set-current ; |
|
|
|
: public ( -- ) |
|
public-wordlist @ set-current ; |
|
|
|
\ classes that implement interfaces |
\ classes that implement interfaces |
|
|
: front-extend-mem ( addr1 u1 u -- addr addr2 u2 ) |
: front-extend-mem ( addr1 u1 u -- addr addr2 u2 ) |
\ extend memory block allocated from the heap by u aus, with the |
\ Extend memory block allocated from the heap by u aus, with the |
\ old stuff coming at the end |
\ old stuff coming at the end |
2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 ) |
2dup + dup >r allocate throw ( addr1 u1 u addr2 ; R: u2 ) |
dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 ) |
dup >r + >r over r> rot move ( addr1 ; R: u2 addr2 ) |
free throw |
free throw |
r> dup r> ; |
r> dup r> ; |
|
|
: implementation ( interface -- ) |
: implementation ( interface -- ) \ objects- objects |
|
\g The current class implements @var{interface}. I.e., you can |
|
\g use all selectors of the interface in the current class and its |
|
\g descendents. |
dup interface-offset @ ( interface offset ) |
dup interface-offset @ ( interface offset ) |
current-interface @ interface-map-offset @ negate over - dup 0> |
current-interface @ interface-map-offset @ negate over - dup 0> |
if \ the interface does not fit in the present class-map |
if \ the interface does not fit in the present class-map |
Line 401 variable public-wordlist
|
Line 346 variable public-wordlist
|
\ this/self, instance variables etc. |
\ this/self, instance variables etc. |
|
|
\ rename "this" into "self" if you are a Smalltalk fiend |
\ rename "this" into "self" if you are a Smalltalk fiend |
0 value this ( -- object ) |
0 value this ( -- object ) \ objects- objects |
: to-this ( object -- ) |
\g the receiving object of the current method (aka active object). |
|
: to-this ( object -- ) \ objects- objects |
|
\g Set @code{this} (used internally, but useful when debugging). |
TO this ; |
TO this ; |
|
|
\ another implementation, if you don't have (fast) values |
\ another implementation, if you don't have (fast) values |
Line 412 variable public-wordlist
|
Line 359 variable public-wordlist
|
\ : to-this ( object -- ) |
\ : to-this ( object -- ) |
\ thisp ! ; |
\ thisp ! ; |
|
|
: m: ( -- xt colon-sys ) ( run-time: object -- ) |
: m: ( -- xt colon-sys; run-time: object -- ) \ objects- objects |
|
\g Start a method definition; @var{object} becomes new @code{this}. |
:noname |
:noname |
POSTPONE this |
POSTPONE this |
POSTPONE >r |
POSTPONE >r |
POSTPONE to-this ; |
POSTPONE to-this ; |
|
|
: ;m ( colon-sys -- ) ( run-time: -- ) |
: exitm ( -- ) \ objects- objects |
|
\g @code{exit} from a method; restore old @code{this}. |
|
POSTPONE r> |
|
POSTPONE to-this |
|
POSTPONE exit ; immediate |
|
|
|
: ;m ( colon-sys --; run-time: -- ) \ objects- objects |
|
\g End a method definition; restore old @code{this}. |
POSTPONE r> |
POSTPONE r> |
POSTPONE to-this |
POSTPONE to-this |
POSTPONE ; ; immediate |
POSTPONE ; ; immediate |
|
|
: catch ( ... xt -- ... n ) |
: catch ( ... xt -- ... n ) \ exception |
\ make it safe to call CATCH within a method. |
\ Make it safe to call CATCH within a method. |
\ should also be done with all words containing CATCH. |
\ should also be done with all words containing CATCH. |
this >r catch r> to-this ; |
this >r catch r> to-this ; |
|
|
Line 432 variable public-wordlist
|
Line 387 variable public-wordlist
|
\ disallowing to change the compilation wordlist between CREATE and |
\ disallowing to change the compilation wordlist between CREATE and |
\ DOES> (see RFI 3) |
\ DOES> (see RFI 3) |
|
|
: inst-something ( size1 align1 size align xt "name" -- size2 align2 ) |
: inst-something ( align1 size1 align size xt "name" -- align2 size2 ) |
\ xt ( -- ) typically is for a DOES>-word |
\ xt ( -- ) typically is for a DOES>-word |
get-current >r |
get-current >r |
current-interface @ class-wordlist @ set-current |
current-interface @ class-wordlist @ set-current |
Line 443 variable public-wordlist
|
Line 398 variable public-wordlist
|
does> \ name execution: ( -- addr ) |
does> \ name execution: ( -- addr ) |
( addr1 ) @ this + ; |
( addr1 ) @ this + ; |
|
|
: inst-var ( size1 align1 size align "name" -- size2 align2 ) |
: inst-var ( align1 offset1 align size "name" -- align2 offset2 ) \ objects- objects |
\ name execution: ( -- addr ) |
\g @var{name} execution: @code{-- addr}@* |
|
\g @var{addr} is the address of the field @var{name} in |
|
\g @code{this} object. |
['] do-inst-var inst-something ; |
['] do-inst-var inst-something ; |
|
|
: do-inst-value ( -- ) |
: do-inst-value ( -- ) |
does> \ name execution: ( -- w ) |
does> \ name execution: ( -- w ) |
( addr1 ) @ this + @ ; |
( addr1 ) @ this + @ ; |
|
|
: inst-value ( size1 align1 "name" -- size2 align2 ) |
: inst-value ( align1 offset1 "name" -- align2 offset2 ) \ objects- objects |
\ name execution: ( -- w ) |
\g @var{name} execution: @code{-- w}@* |
\ a cell-sized value-flavoured instance field |
\g @var{w} is the value of the field @var{name} in @code{this} |
1 cells: ['] do-inst-value inst-something ; |
\g object. |
|
cell% ['] do-inst-value inst-something ; |
|
|
: <to-inst> ( w xt -- ) |
: <to-inst> ( w xt -- ) \ objects- objects |
|
\g store @var{w} into the field @var{xt} in @code{this} object. |
>body @ this + ! ; |
>body @ this + ! ; |
|
|
: to-inst ( w "name" -- ) |
: [to-inst] ( compile-time: "name" -- ; run-time: w -- ) \ objects- objects |
' <to-inst> ; |
\g store @var{w} into field @var{name} in @code{this} object. |
|
|
: [to-inst] ( compile-time: "name" -- ; run-time: w -- ) |
|
' >body @ POSTPONE literal |
' >body @ POSTPONE literal |
POSTPONE this |
POSTPONE this |
POSTPONE + |
POSTPONE + |
POSTPONE ! ; immediate |
POSTPONE ! ; immediate |
|
|
\ early binding stuff |
\ class binding stuff |
|
|
\ this is not generally used, only where you want to do something like |
: <bind> ( class selector-xt -- xt ) \ objects- objects |
\ superclass method invocation (so that you don't have to name your methods) |
\g @var{xt} is the method for the selector @var{selector-xt} in |
|
\g @var{class}. |
: <bind> ( class selector-xt -- xt ) |
|
>body swap class->map over selector-interface @ |
>body swap class->map over selector-interface @ |
?dup-if |
?dup-if |
+ @ |
+ @ |
then |
then |
swap selector-offset @ + @ ; |
swap selector-offset @ + @ ; |
|
|
: bind' ( "class" "selector" -- xt ) |
: bind' ( "class" "selector" -- xt ) \ objects- objects |
|
\g @var{xt} is the method for @var{selector} in @var{class}. |
' execute ' <bind> ; |
' execute ' <bind> ; |
|
|
: bind ( ... object "class" "selector" -- ... ) |
: bind ( ... "class" "selector" -- ... ) \ objects- objects |
|
\g Execute the method for @var{selector} in @var{class}. |
bind' execute ; |
bind' execute ; |
|
|
: [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) |
: [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) \ objects- objects |
|
\g Compile the method for @var{selector} in @var{class}. |
bind' compile, ; immediate |
bind' compile, ; immediate |
|
|
: [super] ( compile-time: "selector" -- ; run-time: ... object -- ... ) |
: current' ( "selector" -- xt ) \ objects- objects |
\ same as `[bind] "parent" "selector"', where "parent" is the |
\g @var{xt} is the method for @var{selector} in the current class. |
\ parent class of the current class |
current-interface @ ' <bind> ; |
|
|
|
: [current] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects |
|
\g Compile the method for @var{selector} in the current class. |
|
current' compile, ; immediate |
|
|
|
: [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects |
|
\g Compile the method for @var{selector} in the parent of the |
|
\g current class. |
current-interface @ class-parent @ ' <bind> compile, ; immediate |
current-interface @ class-parent @ ' <bind> compile, ; immediate |
|
|
\ the object class |
\ the object class |
Line 499 does> \ name execution: ( -- w )
|
Line 466 does> \ name execution: ( -- w )
|
\ because OBJECT has no parent class, we have to build it by hand |
\ because OBJECT has no parent class, we have to build it by hand |
\ (instead of with class) |
\ (instead of with class) |
|
|
wordlist |
class% %allot current-interface ! |
here current-interface ! |
current-interface 1 cells save-mem current-interface @ interface-map 2! |
current-interface 1 cells save-mem 2, \ map now contains a pointer to class |
0 current-interface @ interface-map-offset ! |
0 , |
0 current-interface @ interface-offset ! |
0 , |
0 current-interface @ class-parent ! |
0 , \ parent |
wordlist current-interface @ class-wordlist ! |
, \ wordlist |
object% |
object-struct 2, \ instance size |
current-interface @ push-order |
object-struct |
|
|
' drop ( object -- ) |
:noname ( object -- ) |
method construct ( ... object -- ) \ objects- objects |
drop ; |
\g Initialize the data fields of @var{object}. The method for the |
method construct ( ... object -- ) |
\g class @var{object} just does nothing: @code{( object -- )}. |
|
|
:noname ( object -- ) |
:noname ( object -- ) |
." object:" dup . ." class:" object-map @ @ . ; |
." object:" dup . ." class:" object-map @ @ . ; |
method print |
method print ( object -- ) \ objects- objects |
|
\g Print the object. The method for the class @var{object} prints |
|
\g the address of the object and the address of its class. |
|
|
end-class object |
end-class object ( -- class ) \ objects- objects |
|
\g the ancestor of all classes. |
|
|
\ constructing objects |
\ constructing objects |
|
|
: init-object ( ... class object -- ) |
: init-object ( ... class object -- ) \ objects- objects |
|
\g Initialize a chunk of memory (@var{object}) to an object of |
|
\g class @var{class}; then performs @code{construct}. |
swap class->map over object-map ! ( ... object ) |
swap class->map over object-map ! ( ... object ) |
construct ; |
construct ; |
|
|
: xt-new ( ... class xt -- object ) |
: xt-new ( ... class xt -- object ) \ objects- objects |
\ makes a new object, using XT ( size align -- addr ) to allocate memory |
\g Make a new object, using @code{xt ( align size -- addr )} to |
|
\g get memory. |
over class-inst-size 2@ rot execute |
over class-inst-size 2@ rot execute |
dup >r init-object r> ; |
dup >r init-object r> ; |
|
|
: dict-new ( ... class -- object ) |
: dict-new ( ... class -- object ) \ objects- objects |
\ makes a new object HERE in dictionary |
\g @code{allot} and initialize an object of class @var{class} in |
['] struct-allot xt-new ; |
\g the dictionary. |
|
['] %allot xt-new ; |
: heap-new ( ... class -- object ) |
|
\ makes a new object in ALLOCATEd memory |
: heap-new ( ... class -- object ) \ objects- objects |
['] struct-alloc xt-new ; |
\g @code{allocate} and initialize an object of class @var{class}. |
|
['] %alloc xt-new ; |