\ 
\ Last_change: KS 25.01.2012 10:21:03
\ 
\ The example from Berds article in the VD 4/2011, page 29/30 can now be
\ implemented as follows:
\
\ now implemented using simpleOOP by Klaus Schleisiek
\
\ some re-definitions to adapt to Manfred's syntax:

include oop.fs

: msg   polymorphic ;
Classroot definitions
: New   Classroot Object ;
: ::    Classroot Attribute ;

Forth definitions

\ The example follows here now:

class aCell aCell definitions 1 cells aCell allot
\ ----------------------------------------------------
: @ ( oid -- u ) ( forth ) @ ;
: ! ( u oid -- ) ( forth ) ! ;


forth definitions

class MemVar MemVar definitions
\ ---------------------------------------------------
aCell :: addr

msg @ ( obj -- x )
msg ! ( x obj -- )

: init ( addr obj -- ) MemVar addr ! ; \ early binding to aCell !

: ? ( obj -- ) MemVar @ . ; \ late binding to @

: +! ( x obj -- ) dup >r MemVar @ + r> MemVar ! ; \ late binding to @ and !

\ +! will late bind to the following methods when applied to a MemVar

: ! ( x obj -- ) MemVar addr @ ! ;
: @ ( obj -- x ) MemVar addr @ @ ;

forth definitions

: flash! ( x a -- ) ." flash store " ! ; \ a dummy to simulate flash access

MemVar Class FlashVar  FlashVar definitions
\ ---------------------------------------------
: ! ( x obj -- ) FlashVar addr @ flash! ;
\ This method is early bound to a FlashVar Instance but late bound to the +!
\ and ? methods defined in MemVar, when those are applied to a FlashVar
\ Instance.

forth definitions

: spi! ( x a -- ) ." spi store " ! ; \ a dummy to simulate write access
: spi@ ( a -- x ) ." spi fetch " @ ; \ a dummy to simulate read access

MemVar static Class SpiVar SpiVar definitions
\ ---------------------------------------------
: ! ( x obj -- ) SpiVar addr @ spi! ;
: @ ( obj -- x ) SpiVar addr @ spi@ ;
\ This methods are early bound to a SpiVar Instance but late bound to the +!
\ and ? methods defined in MemVar, when those are applied to a SpiVar
\ Instance.

Oop also forth definitions

\ Some test code to see that late binding in '?' and '+!' really works:

: search   name current @ (search-wordlist) u. ;

MemVar new a here 0 , a init
SpiVar new b here 1 , b init
FlashVar new c here 2 , c init

cr
cr ." a ? should print: 0"
cr ." " a ?
cr ." b ? should print: spi fetch 1"
cr ." " b ?
cr ." c ? should print: 2"
cr ." " c ?
cr
cr ." 100 a +! a ? should print: 100"
cr ." " 100 a +! a ?
cr ." 200 b +! b ? should print: spi fetch spi store spi fetch 201"
cr ." " 200 b +! b ?
cr
cr ." 300 c +! c ? should print: flash store 302"
cr ." " 300 c +! c ?

: test
   cr ." a: " 1 a +! a ?
   cr ." b: " 1 b +! b ?
   cr ." c: " 1 c +! c ?
;
FlashVar definitions

: +! ." flash+! " FlashVar +! ;

Forth definitions

FlashVar New d   here 3 , d init

: test  test cr ." d: " 1 d +!  d ? ;

test