gforth/objects.fs - diff

Return to objects.fs CVS log

Up to [gforth] / gforth

Diff for /gforth/objects.fs between versions 1.4 and 1.15

version 1.4, 1997/06/23 15:53:53	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; 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 41	Line 41

\ 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+c b )
rot + swap ;

: perform ( ... addr -- ... )	: perform ( ... addr -- ... )
@ execute ;	@ execute ;

Line 73	Line 74
over >r + dup >r resize throw	over >r + dup >r resize throw
r> over r> + -rot ;	r> over r> + -rot ;

	: \g ( -- )
	postpone \ ; immediate
	[then]

\ data structures	\ data structures

struct	struct
Line 90 end-struct interface%	Line 95 end-struct interface%

interface%	interface%
cell% field class-parent	cell% field class-parent
cell% field class-wordlist \ instance variables and other private words	cell% field class-wordlist \ inst-vars and other protected words
cell% 2* field class-inst-size \ size and alignment	cell% 2* field class-inst-size ( class -- addr ) \ objects- objects
	\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%	end-struct class%

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

\ 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 127 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 140 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 149 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 158 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 177 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 187 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
	\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 )	: 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 211 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 -- align size )	: methods ( class -- ) \ objects- objects
	\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	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 223 variable last-interface-offset 0 last-in	Line 280 variable last-interface-offset 0 last-in
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 235 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 ( align size -- 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 ( align size "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

: protected ( -- )
current-interface @ class-wordlist @
dup get-current <>
if \ we are not protected 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 291 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 302 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 333 variable public-wordlist	Line 398 variable public-wordlist
does> \ name execution: ( -- addr )	does> \ name execution: ( -- addr )
( addr1 ) @ this + ;	( addr1 ) @ this + ;

: inst-var ( align1 offset1 align size "name" -- align2 offset2 )	: 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 ( align1 offset1 "name" -- align2 offset2 )	: 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}
	\g object.
cell% ['] do-inst-value inst-something ;	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] ( compile-time: "name" -- ; run-time: w -- )	: [to-inst] ( compile-time: "name" -- ; run-time: w -- ) \ objects- objects
	\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 357 does> \ name execution: ( -- w )	Line 427 does> \ name execution: ( -- w )

\ class binding stuff	\ class binding stuff

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

: current' ( "selector" -- xt )	: current' ( "selector" -- xt ) \ objects- objects
	\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 -- ... )	: [current] ( compile-time: "selector" -- ; run-time: ... object -- ... ) \ objects- objects
	\g Compile the method for @var{selector} in the current class.
current' compile, ; immediate	current' compile, ; immediate

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

\ the object class	\ the object class
Line 398 wordlist current-interface @ class-wordl	Line 475 wordlist current-interface @ class-wordl
object%	object%
current-interface @ push-order	current-interface @ push-order

:noname ( object -- )	' drop ( object -- )
drop ;	method construct ( ... object -- ) \ objects- objects
method construct ( ... object -- )	\g Initialize the data fields of @var{object}. The method for the
	\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 ( align size -- 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
	\g the dictionary.
['] %allot xt-new ;	['] %allot xt-new ;

: heap-new ( ... class -- object )	: heap-new ( ... class -- object ) \ objects- objects
\ makes a new object in ALLOCATEd memory	\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.4
changed lines
	Added in v.1.15