version 1.3, 1997/06/06 17:27:57
|
version 1.4, 1997/06/23 15:53:53
|
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, 1997 |
\ 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 |
Line 151
|
Line 44
|
: -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 ) |
: under+ ( a b c -- a+c b ) |
rot + swap ; |
rot + swap ; |
|
|
: perform ( ... addr -- ... ) |
: perform ( ... addr -- ... ) |
Line 176
|
Line 69
|
|
|
: 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 |
|
here 2 cells allot 2! ; |
|
|
|
\ 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 \ instance variables and other private words |
2 cells: field class-inst-size \ size and alignment |
cell% 2* field class-inst-size \ size and alignment |
end-struct class-struct |
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 298 does> ( ... object -- ... )
|
Line 188 does> ( ... object -- ... )
|
variable last-interface-offset 0 last-interface-offset ! |
variable last-interface-offset 0 last-interface-offset ! |
|
|
: interface ( -- ) |
: interface ( -- ) |
interface-struct struct-allot >r |
interface% %allot >r |
0 0 r@ interface-map 2! |
0 0 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 ! |
Line 325 variable last-interface-offset 0 last-in
|
Line 215 variable last-interface-offset 0 last-in
|
\ add the class's wordlist to the search-order (in front) |
\ add the class's wordlist to the search-order (in front) |
>r get-order r> add-class-order set-order ; |
>r get-order r> add-class-order set-order ; |
|
|
: class ( parent-class -- size align ) |
: class ( parent-class -- align size ) |
class-struct struct-allot >r |
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 ! |
Line 349 variable last-interface-offset 0 last-in
|
Line 239 variable last-interface-offset 0 last-in
|
\ note: no checks, whether the wordlists are correct |
\ note: no checks, whether the wordlists are correct |
>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-class-noname ( align size -- class ) |
current-interface @ dup drop-order class-inst-size 2! |
current-interface @ dup drop-order class-inst-size 2! |
end-interface-noname ; |
end-interface-noname ; |
|
|
: end-class ( size align "name" -- ) |
: end-class ( align size "name" -- ) |
\ name execution: ( -- class ) |
\ name execution: ( -- class ) |
end-class-noname constant ; |
end-class-noname constant ; |
|
|
Line 361 variable last-interface-offset 0 last-in
|
Line 251 variable last-interface-offset 0 last-in
|
|
|
variable public-wordlist |
variable public-wordlist |
|
|
: private ( -- ) |
: protected ( -- ) |
current-interface @ class-wordlist @ |
current-interface @ class-wordlist @ |
dup get-current <> |
dup get-current <> |
if \ we are not private already |
if \ we are not protected already |
get-current public-wordlist ! |
get-current public-wordlist ! |
then |
then |
set-current ; |
set-current ; |
Line 432 variable public-wordlist
|
Line 322 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 333 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 ) |
\ name execution: ( -- addr ) |
\ name execution: ( -- addr ) |
['] do-inst-var inst-something ; |
['] do-inst-var inst-something ; |
|
|
Line 451 does> \ name execution: ( -- addr )
|
Line 341 does> \ name execution: ( -- addr )
|
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 ) |
\ name execution: ( -- w ) |
\ name execution: ( -- w ) |
\ a cell-sized value-flavoured instance field |
\ a cell-sized value-flavoured instance field |
1 cells: ['] do-inst-value inst-something ; |
cell% ['] do-inst-value inst-something ; |
|
|
: <to-inst> ( w xt -- ) |
: <to-inst> ( w xt -- ) |
>body @ this + ! ; |
>body @ this + ! ; |
|
|
: to-inst ( w "name" -- ) |
|
' <to-inst> ; |
|
|
|
: [to-inst] ( compile-time: "name" -- ; run-time: w -- ) |
: [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 |
|
\ superclass method invocation (so that you don't have to name your methods) |
|
|
|
: <bind> ( class selector-xt -- xt ) |
: <bind> ( class selector-xt -- xt ) |
>body swap class->map over selector-interface @ |
>body swap class->map over selector-interface @ |
Line 489 does> \ name execution: ( -- w )
|
Line 373 does> \ name execution: ( -- w )
|
: [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) |
: [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) |
bind' compile, ; immediate |
bind' compile, ; immediate |
|
|
: [super] ( compile-time: "selector" -- ; run-time: ... object -- ... ) |
: current' ( "selector" -- xt ) |
|
current-interface @ ' <bind> ; |
|
|
|
: [current] ( compile-time: "selector" -- ; run-time: ... object -- ... ) |
|
current' compile, ; immediate |
|
|
|
: [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... ) |
\ same as `[bind] "parent" "selector"', where "parent" is the |
\ same as `[bind] "parent" "selector"', where "parent" is the |
\ parent class of the current class |
\ parent class of the current class |
current-interface @ class-parent @ ' <bind> compile, ; immediate |
current-interface @ class-parent @ ' <bind> compile, ; immediate |
Line 499 does> \ name execution: ( -- w )
|
Line 389 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 |
|
|
|
:noname ( object -- ) |
:noname ( object -- ) |
drop ; |
drop ; |
Line 526 end-class object
|
Line 415 end-class object
|
construct ; |
construct ; |
|
|
: xt-new ( ... class xt -- object ) |
: xt-new ( ... class xt -- object ) |
\ makes a new object, using XT ( size align -- addr ) to allocate memory |
\ makes a new object, using XT ( align size -- addr ) to allocate 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 ) |
\ makes a new object HERE in dictionary |
\ makes a new object HERE in dictionary |
['] struct-allot xt-new ; |
['] %allot xt-new ; |
|
|
: heap-new ( ... class -- object ) |
: heap-new ( ... class -- object ) |
\ makes a new object in ALLOCATEd memory |
\ makes a new object in ALLOCATEd memory |
['] struct-alloc xt-new ; |
['] %alloc xt-new ; |