\ 
\ Last_change: KS 29.01.2012 16:35:19
\ 
Forth definitions

include oop.fs

\ -----------------------------------------------------------------------------
\ Basic Objects: Cell, Buffer, String
\ -----------------------------------------------------------------------------

Class Cell   Cell definitions

1 cells Cell allot

: @    ( obj -- n )   @ ;
                          
: !    ( n obj -- )   ! ;
                          
: +!   ( n obj -- )   dup >r Cell @ + r> Cell ! ;
                          
: on   ( obj -- )     -1 swap Cell ! ;
                          
: off  ( obj -- )     0 swap Cell ! ;

: ?    ( obj -- )     Cell @ . ;

Forth definitions

Class Buffer   Buffer definitions

Cell Attribute Ptr
Cell Attribute Len

: size   ( obj -- +n )         Buffer Len @ ;

: addr   ( obj -- buf.addr )   Buffer Ptr @ ?dup 0= ABORT" uninitialized_buffer" ;
 
: allot  ( +n obj -- )
   dup Buffer Ptr @ IF  Buffer Len @ u> ABORT" buffer_too_small"  EXIT THEN
   here over Buffer Ptr !   over swap Buffer Len !   allot
;
: update ( addr +n obj -- )    dup >r Buffer Len !  r> Buffer Ptr ! ;

: reset  ( obj -- )            >r 0 0 r> Buffer update ;

: ?      ( obj -- )            dup @ ." addr " u.  cell+ @ ." length " u. ;

Forth definitions

class String   String definitions

Buffer   Attribute String

Polymorphic @
Polymorphic ??

: @     ( obj -- c-addr +n )   String String addr count ;

: size  ( obj -- +n )          String String size 1- ;

: ?size ( +n obj -- +n )       String size over < ABORT" string_overflow" ;

: chars ( obj -- +n )          String @ nip ;

: !     ( c-addr +n obj -- )   >r r@ String ?size r> String String addr place ;

: ?     ( obj -- )             String @ type ;

: init  ( +n obj -- )
    >r &255 umin 1+ r@ String String allot
    r> String String addr off
;
: +!    ( c-addr +n obj -- )
    >r r@ String chars  2dup +  r@ String ?size  ( addr +n chars newsize )
    dup >r   swap - umin                     ( addr +n' )
    r>   r@ String @ +                         ( addr +n' newsize addr+ )
    swap r> String String addr c! \ set new length ( addr +n' addr+ )
    swap move                   \ append string
;

Forth definitions
\ -----------------------------------------------------------------------------
\ testing
\ -----------------------------------------------------------------------------

String Object s1   20 s1 init
String Object s2   20 s2 init
Create dies ," dröhn "  dies count s1 !
Create das  ," blah "    das count s2 !

: stringtest  ( -- )  s1 @ s2 +!   s2 ? ;

\ -----------------------------------------------------------------------------
\ Proxy with lazy initialisation
\ -----------------------------------------------------------------------------

Class Indirect  Indirect definitions

Cell Attribute Zahl
Cell Proxy Ref

Forth definitions

Class Refref Refref definitions

Indirect Attribute Indir

Forth definitions

Cell     Object Zelle
Indirect Object Ind
Refref   Object Deeper

: deep-assign ( xt -- )  Deeper Indir BIND Ref ;

: init  ( -- object )   ." loading " ['] Zelle Ind BIND Ref   Ind Ref .. ;
' init Ind BIND Ref

\ -----------------------------------------------------------------------------
\ late binding / forward referencing
\ -----------------------------------------------------------------------------
Forth definitions

: with-dummy ( -- )   s1 ?? ;

\ Later, ?? can be defined as meaningful string method, e.g.:
\ String definitions
\ : ??  dup String ? String ? ;

\ -----------------------------------------------------------------------------
\ polymorphism
\ -----------------------------------------------------------------------------

: set@  ( xt -- )   s1 bind @ ;

:noname  ." poly " string string addr count ; set@

\ -----------------------------------------------------------------------------
\ late binding
\ -----------------------------------------------------------------------------

: latebound  ( -- )   Zelle ? ;

Cell definitions

: @  ." neu " Cell @ ;

Forth definitions

latebound