gforth/objects.fs - diff

Return to objects.fs CVS log

Up to [gforth] / gforth

Diff for /gforth/objects.fs between versions 1.7 and 1.13

version 1.7, 1998/08/02 15:06:01	version 1.13, 1999/06/17 15:32:13
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-1998
\ public domain; NO WARRANTY	\ 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
Line 96 end-struct interface%	Line 96 end-struct interface%
interface%	interface%
cell% field class-parent	cell% field class-parent
cell% field class-wordlist \ inst-vars and other protected words	cell% field class-wordlist \ inst-vars and other protected words
cell% 2* field class-inst-size ( class -- addr ) \ objects	cell% 2* field class-inst-size ( class -- addr ) \ objects- objects
\g used as @code{class-inst-size 2@ ( class -- align size )},	\g Give the size specification for an instance (i.e. an object)
\g gives the size specification for an instance (i.e. an object)	\g of @var{class};
\g of @code{class}.	\g used as @code{class-inst-size 2@ ( class -- align size )}.
end-struct class%	end-struct class%

struct	struct
Line 118 end-struct selector%	Line 118 end-struct selector%

\ selectors and methods	\ selectors and methods

variable current-interface ( -- addr ) \ objects	variable current-interface ( -- addr ) \ objects- objects
\g this variable contains the class or interface currently being	\g Variable: contains the class or interface currently being
\g defined.	\g defined.


Line 139 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" -- ) \ objects	: method ( xt "name" -- ) \ objects- objects
\g @code{name} execution: @code{... object -- ...}@*	\g @code{name} execution: @code{... object -- ...}@*
\g creates selector @code{name} and makes @code{xt} its method in	\g Create selector @var{name} and makes @var{xt} its method in
\g the current class.	\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 )
Line 154 does> ( ... object -- ... )	Line 154 does> ( ... object -- ... )
do-class-method	do-class-method
then ;	then ;

: selector ( "name" -- ) \ objects	: selector ( "name" -- ) \ objects- objects
\g @code{name} execution: @code{... object -- ...}@*	\g @var{name} execution: @code{... object -- ...}@*
\g creates selector @code{name} for the current class and its	\g Create selector @var{name} for the current class and its
\g descendents; you can set a method for the selector in the	\g descendents; you can set a method for the selector in the
\g current class with @code{overrides}.	\g current class with @code{overrides}.
['] no-method method ;	['] no-method method ;
Line 166 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 ) \ objects	: class->map ( class -- map ) \ objects- objects
\g @code{map} is the pointer to @code{class}'s method map; it	\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 points to the place in the map to which the selector offsets
\g refer (i.e., where @code{object-map}s point to).	\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 177 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 -- ) \ objects	: class-override! ( xt sel-xt class-map -- ) \ objects- objects
\g @code{xt} is the new method for the selector @code{sel-xt} in	\g @var{xt} is the new method for the selector @var{sel-xt} in
\g @code{class-map}.	\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 197 does> ( ... object -- ... )	Line 197 does> ( ... object -- ... )
then	then
interface-override! ;	interface-override! ;

: overrides ( xt "selector" -- ) \ objects	: overrides ( xt "selector" -- ) \ objects- objects
\g replace default method for @code{selector} in the current class	\g replace default method for @var{selector} in the current class
\g with @code{xt}. @code{overrides} must not be used during an	\g with @var{xt}. @code{overrides} must not be used during an
\g interface definition.	\g interface definition.
' current-interface @ class->map class-override! ;	' current-interface @ class->map class-override! ;

Line 208 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 ( -- ) \ objects	: interface ( -- ) \ objects- objects
\g starts an interface definition.	\g Start an interface definition.
interface% %allot >r	interface% %allot >r
0 0 r@ interface-map 2!	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 ) \ objects	: end-interface-noname ( -- interface ) \ objects- objects
\g ends an interface definition. The resulting interface is	\g End an interface definition. The resulting interface is
\g @code{interface}.	\g @var{interface}.
current-interface @ ;	current-interface @ ;

: end-interface ( "name" -- ) \ objects	: end-interface ( "name" -- ) \ objects- objects
\g @code{name} execution: @code{-- interface}@*	\g @code{name} execution: @code{-- interface}@*
\g ends an interface definition. The resulting interface is	\g End an interface definition. The resulting interface is
\g @code{interface}.	\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 237 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 -- ) \ objects	: push-order ( class -- ) \ objects- objects
\g add @code{class}'s wordlists 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 -- align offset ) \ objects	: class ( parent-class -- align offset ) \ objects- objects
\g start a new class definition as a child of	\g Start a new class definition as a child of
\g @code{parent-class}. @code{align offset} are for use by	\g @var{parent-class}. @var{align offset} are for use by
\g @code{field} etc.	\g @var{field} etc.
class% %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 !
Line 264 variable last-interface-offset 0 last-in	Line 286 variable last-interface-offset 0 last-in
until	until
drop ;	drop ;

: drop-order ( class -- ) \ objects	: drop-order ( class -- ) \ objects- objects
\g drops @code{class}'s wordlists from the search order. No	\g Drop @var{class}'s wordlists from the search order. No
\g checking is made whether @code{class}'s wordlists are actually	\g checking is made whether @var{class}'s wordlists are actually
\g on the search order.	\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 ( align offset -- class ) \ objects	: end-class-noname ( align offset -- class ) \ objects- objects
\g ends a class definition. The resulting class is @code{class}.	\g End a class definition. The resulting class is @var{class}.
	public
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 ( align offset "name" -- ) \ objects	: end-class ( align offset "name" -- ) \ objects- objects
\g @code{name} execution: @code{-- class}@*	\g @var{name} execution: @code{-- class}@*
\g ends a class definition. The resulting class is @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

: protected ( -- ) \ 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
\g restore the compilation wordlist that was in effect before the
\g last @code{protected} that actually changed the compilation
\g wordlist.
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 -- ) \ objects	: implementation ( interface -- ) \ objects- objects
\g the current class implements @code{interface}. I.e., you can	\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 use all selectors of the interface in the current class and its
\g descendents.	\g descendents.
dup interface-offset @ ( interface offset )	dup interface-offset @ ( interface offset )
Line 332 variable public-wordlist	Line 336 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 ) \ objects	0 value this ( -- object ) \ objects- objects
\g the receiving object of the current method (aka active object).	\g the receiving object of the current method (aka active object).
: to-this ( object -- ) \ objects	: to-this ( object -- ) \ objects- objects
\g sets @code{this} (used internally, but useful when debugging).	\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 345 variable public-wordlist	Line 349 variable public-wordlist
\ : to-this ( object -- )	\ : to-this ( object -- )
\ thisp ! ;	\ thisp ! ;

: m: ( -- xt colon-sys; run-time: object -- ) \ objects	: m: ( -- xt colon-sys; run-time: object -- ) \ objects- objects
\g start a method definition; @code{object} becomes new @code{this}.	\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 ;

: exitm ( -- ) \ objects	: exitm ( -- ) \ objects- objects
\g @code{exit} from a method; restore old @code{this}.	\g @code{exit} from a method; restore old @code{this}.
POSTPONE r>	POSTPONE r>
POSTPONE to-this	POSTPONE to-this
POSTPONE exit ; immediate	POSTPONE exit ; immediate

: ;m ( colon-sys --; run-time: -- ) \ objects	: ;m ( colon-sys --; run-time: -- ) \ objects- objects
\g end a method definition; restore old @code{this}.	\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 ) \ exception	: 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 384 variable public-wordlist	Line 388 variable public-wordlist
does> \ name execution: ( -- addr )	does> \ name execution: ( -- addr )
( addr1 ) @ this + ;	( addr1 ) @ this + ;

: inst-var ( align1 offset1 align size "name" -- align2 offset2 ) \ objects	: inst-var ( align1 offset1 align size "name" -- align2 offset2 ) \ objects- objects
\g @code{name} execution: @code{-- addr}@*	\g @var{name} execution: @code{-- addr}@*
\g @code{addr} is the address of the field @code{name} in	\g @var{addr} is the address of the field @var{name} in
\g @code{this} object.	\g @code{this} object.
['] do-inst-var inst-something ;	['] do-inst-var inst-something ;

Line 394 does> \ name execution: ( -- addr )	Line 398 does> \ name execution: ( -- addr )
does> \ name execution: ( -- w )	does> \ name execution: ( -- w )
( addr1 ) @ this + @ ;	( addr1 ) @ this + @ ;

: inst-value ( align1 offset1 "name" -- align2 offset2 ) \ objects	: inst-value ( align1 offset1 "name" -- align2 offset2 ) \ objects- objects
\g @code{name} execution: @code{-- w}@*	\g @var{name} execution: @code{-- w}@*
\g @code{w} is the value of the field @code{name} in @code{this}	\g @var{w} is the value of the field @var{name} in @code{this}
\g object.	\g object.
cell% ['] do-inst-value inst-something ;	cell% ['] do-inst-value inst-something ;

: <to-inst> ( w xt -- ) \ objects	: <to-inst> ( w xt -- ) \ objects- objects
\g store @code{w} into the field @code{xt} in @code{this} object.	\g store @var{w} into the field @var{xt} in @code{this} object.
>body @ this + ! ;	>body @ this + ! ;

: [to-inst] ( compile-time: "name" -- ; run-time: w -- ) \ objects	: [to-inst] ( compile-time: "name" -- ; run-time: w -- ) \ objects- objects
\g store @code{w} into field @code{name} in @code{this} object.	\g store @var{w} into field @var{name} in @code{this} object.
' >body @ POSTPONE literal	' >body @ POSTPONE literal
POSTPONE this	POSTPONE this
POSTPONE +	POSTPONE +
Line 413 does> \ name execution: ( -- w )	Line 417 does> \ name execution: ( -- w )

\ class binding stuff	\ class binding stuff

: <bind> ( class selector-xt -- xt ) \ objects	: <bind> ( class selector-xt -- xt ) \ objects- objects
\g @code{xt} is the method for the selector @code{selector-xt} in	\g @var{xt} is the method for the selector @var{selector-xt} in
\g @code{class}.	\g @var{class}.
>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 ) \ objects	: bind' ( "class" "selector" -- xt ) \ objects- objects
\g @code{xt} is the method for @code{selector} in @code{class}.	\g @var{xt} is the method for @var{selector} in @var{class}.
' execute ' <bind> ;	' execute ' <bind> ;

: bind ( ... "class" "selector" -- ... ) \ objects	: bind ( ... "class" "selector" -- ... ) \ objects- objects
\g execute the method for @code{selector} in @code{class}.	\g Execute the method for @var{selector} in @var{class}.
bind' execute ;	bind' execute ;

: [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) \ objects	: [bind] ( compile-time: "class" "selector" -- ; run-time: ... object -- ... ) \ objects- objects
\g compile the method for @code{selector} in @code{class}.	\g Compile the method for @var{selector} in @var{class}.
bind' compile, ; immediate	bind' compile, ; immediate

: current' ( "selector" -- xt ) \ objects	: current' ( "selector" -- xt ) \ objects- objects
\g @code{xt} is the method for @code{selector} in the current class.	\g @var{xt} is the method for @var{selector} in the current class.
current-interface @ ' <bind> ;	current-interface @ ' <bind> ;

: [current] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects	: [current] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects
\g compile the method for @code{selector} in the current class.	\g Compile the method for @var{selector} in the current class.
current' compile, ; immediate	current' compile, ; immediate

: [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects	: [parent] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects
\g compile the method for @code{selector} in the parent of the	\g Compile the method for @var{selector} in the parent of the
\g current class.	\g current class.
current-interface @ class-parent @ ' <bind> compile, ; immediate	current-interface @ class-parent @ ' <bind> compile, ; immediate

Line 462 object%	Line 466 object%
current-interface @ push-order	current-interface @ push-order

' drop ( object -- )	' drop ( object -- )
method construct ( ... object -- ) \ objects	method construct ( ... object -- ) \ objects- objects
\g initializes the data fields of @code{object}. The method for the	\g Initialize the data fields of @var{object}. The method for the
\g class @code{object} just does nothing @code{( 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 ( object -- ) \ objects	method print ( object -- ) \ objects- objects
\g prints the object. The method for the class @code{object} prints	\g Print the object. The method for the class @var{object} prints
\g the address of the object and the address of its class.	\g the address of the object and the address of its class.

end-class object ( -- class ) \ objects	end-class object ( -- class ) \ objects- objects
\g the ancestor of all classes.	\g the ancestor of all classes.

\ constructing objects	\ constructing objects

: init-object ( ... class object -- ) \ objects	: init-object ( ... class object -- ) \ objects- objects
\g initializes a chunk of memory (@code{object}) to an object of	\g Initialize a chunk of memory (@var{object}) to an object of
\g class @code{class}; then performs @code{construct}.	\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 ) \ objects	: xt-new ( ... class xt -- object ) \ objects- objects
\g makes a new object, using @code{xt ( align size -- addr )} to	\g Make a new object, using @code{xt ( align size -- addr )} to
\g get memory.	\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 ) \ objects	: dict-new ( ... class -- object ) \ objects- objects
\g @code{allot} and initialize an object of class @code{class} in	\g @code{allot} and initialize an object of class @var{class} in
\g the dictionary.	\g the dictionary.
['] %allot xt-new ;	['] %allot xt-new ;

: heap-new ( ... class -- object ) \ objects	: heap-new ( ... class -- object ) \ objects- objects
\g @code{allocate} and initialize an object of class @code{class}.	\g @code{allocate} and initialize an object of class @var{class}.
['] %alloc xt-new ;	['] %alloc xt-new ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.7
changed lines
	Added in v.1.13