\ examples and tests for objects.fs
\ written by Anton Ertl 1996, 1997
\ public domain
cr object heap-new print
object class
:noname ( object -- )
drop ." undefined" ;
overrides print
end-class nothing
nothing heap-new constant undefined
cr undefined print
\ instance variables and this
object class
cell% inst-var n
m: ( object -- )
0 n ! ;m
overrides construct
m: ( object -- )
n @ . ;m
overrides print
m: ( object -- )
1 n +! ;m
method inc
end-class counter
counter heap-new constant counter1
cr
counter1 print
counter1 inc
counter1 print
counter1 inc
counter1 inc
counter1 inc
counter1 print
counter1 print
\ examples of static binding
cr undefined bind object print
: object-print ( object -- )
[bind] object print ;
cr undefined object-print
\ interface
\ sorry, a meaningful example would be too long
interface
selector add ( n object -- )
selector val ( object -- n )
end-interface foobar
counter class
foobar implementation
m: ( object -- )
this [parent] inc
n @ 10 mod 0=
if
." xcounter " this object-print ." made another ten" cr
then
;m overrides inc
m: ( n object -- )
0 do
this inc
loop
;m overrides add
m: ( object -- n )
n @
;m overrides val
end-class xcounter
object class
foobar implementation
cell% inst-var n
m: ( n object -- )
n !
;m overrides construct
m: ( object -- )
n @ .
;m overrides print
m: ( n object -- )
n +!
;m overrides add
protected
create protected1
protected
create protected2
cr order
public
create public1
cr order
\ we leave val undefined
end-class int
\ a perhaps more sensible class structure would be to have int as
\ superclass of counter, but that would not exercise interfaces
xcounter dict-new constant x
create y 3 int dict-new drop \ same as "3 int dict-new constant y"
cr
y print cr
20 x add
20 y add
x val .
\ y val . \ undefined
y print
cr
int push-order
order cr
words cr
int drop-order
order
cr
\ test override of inherited interface selector
xcounter class
m: ( object -- n )
this [parent] val 2*
;m overrides val
end-class ycounter
ycounter dict-new constant z
cr
z print cr
z val . cr
z inc
z val . cr
1 z add
z val . cr
\ test inst-value
object class
foobar implementation
inst-value N
m: ( n object -- )
this [parent] construct \ currently does nothing, but who knows
[to-inst] N
;m overrides construct
m: ( object -- )
N .
;m overrides print
m: ( object -- n )
N
;m overrides val
end-class const-int
5 const-int heap-new constant five
five print
five val 1+ . cr
.s cr
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>