( hype )

\ object-oriented forth

needs wordlist vocs

0 value self

: self+ ( n - a) self + ;

: send ( a xt) 
    self >r  swap to self 
    execute  r> to self 
;

variable cls ( contains ta -> |size|wid|super|)

: size^ ( - aa) 
    cls @ ?dup 0= abort" scope?" 
;

: mfind ( ta ca u - xt n)  
   rot cell+ @ search-wordlist
   dup 0= abort" no such method?"
;

: send1 ( a ta c-addr u )
   mfind 0<> state @ and
   if swap lit, lit, postpone send 
   else send then
;

: send' ( a ta "m ") 
   bl word count send1 
;

: super ( "m ") 
   size^ cell+ cell+ @ bl word count 
   mfind 0<
   if compile, else execute then 
; immediate

: defs ( n "f ") 
   create size^ @ cell+ , size^ +! immediate
   does> @ state @ if lit, postpone self+ 
   else self+ then 
;

: methods ( ta) 
   dup cls ! cell+ @ dup set-current
   also context ! 
;

variable lastclass

: class ( "c ") 
   create here dup lastclass ! 0 , 0 , 0 ,
   wordlist over cell+ ! methods ;

: subclass ( ta "c ") 
    dup class size^ over @ over ! cell+ cell+ ! 
    1 cells + @ @ ( last nfa in super wl)
    lastclass @ cell+ @ ( wl) !
;

: endclass ( ) 
    size^ drop previous definitions 0 cls ! 
;

: instance ( ta) 
    dup , @ here over allot swap erase
    does> dup swap @ send' 
;

: new ( ta "name ") 
    create instance immediate ;

: newobj ( ta )
\ create noname object and call "init" method
    here swap
    dup , @ here over allot swap erase
    dup @ s" init" send1
;

: -> ( obj "word" )
    [char] . parse sfind 0= if abort" ??" then
    execute
    nextword mfind drop 
    state @
    if lit, postpone send
    else send then
; immediate

: alloc ( ta -- obj )
    dup @ cell+ dup allocate throw
    tuck swap erase
    tuck !
;

: var 1 cells defs ;

: obj ( ta "name ") dup @ defs ,
   does> 2@ self+ swap send' ;

: ref ( ta "name ") var ,
   does> 2@ self+ @ swap send' ;

\eof

\ examples

class button
   var x
   var y
: draw ( )  ." x=" x @ . space ." y=" y @ . cr ;
: init ( x y )  y ! x !  ;
: test ;
endclass


button alloc value testobj

1 2 testobj -> button.init

: test
  testobj -> button.draw
;

test
button new myObj
3 4 myObj init
myObj draw


button subclass bchild
: draw ." child: " super draw ;
endclass

bchild subclass asd
  button obj bobj
endclass
