\ Subject: Another mini-oop
\ From: Doug Hoffman <dhoffman888@gmail.com>
\ Newsgroups: comp.lang.forth
\ news:613dfe6e$0$700$14726298@news.sunsite.dk
\ https://groups.google.com/g/comp.lang.forth/c/WYGu4YFhhas


0 value self
: dfa ( cls -- a) 8 cells + ;
: _mfa ( adr -- ofs) dup >r 2/ 2/ r@ xor 2/ 2/ r> xor 7 and cells ;
: mfa ( sel cls -- sel mfa) over _mfa + ;
: fm ( sel mfa -- xt) begin @ dup while 2dup cell+ @ =
  if 2 cells + nip @ exit then repeat -1 abort" method?" ;
: class ( supClass 'name' -- cls) create here >r
  9 cells dup allot r@ swap move r> ;
: makeSel ( 'name' -- sel ) create here dup _mfa c, 254 c,
  does> over @ over c@ + fm self >r swap to self execute r> to self ;
: sel ( 'name' -- sel ) >in @ bl word find if >body dup 1+ c@ 254 =
   if nip exit then then drop >in ! makeSel ;
: :m ( cls 'name' -- a xt) sel over mfa
   here over @ , swap !  , here 0 , :noname ;
: ;m ( a xt -- ) postpone ; swap ! ; immediate
: :: ( cls 'name' -- ) ' >body swap mfa fm compile, ; immediate
: (ivar) ( offset 'name' -- ) create , does> ( -- addr ) @ self + ;
: var ( cls n 'name' -- ) over dfa dup @ (ivar) +! ;
create object 9 cells dup allot object swap erase  cell object dfa !
object :m :init ;m drop
: new ( cls -- obj) dup dfa @ here swap allot tuck ! dup >r :init r> ;
: .. ( obj 'name' -- adr) ' >body @ + ; 



1 [if] \ usage example

object class button
  cell var text
  cell var len
  cell var x
  cell var y
 :m :init ( addr u -- ) len ! text ! 0 x ! 0 y ! ;m
 :m draw  x @ y @ at-xy text @ len @ type ;m
drop

\ inheritance

: bold   27 emit ." [1m" ;
: normal 27 emit ." [0m" ;

button class bold-button
 :m draw bold [ button :: draw ] normal ;m
drop

\ Create and draw the buttons:

s" normal button" button new constant foo
s" bold button" bold-button new constant bar
1 bar .. y !
page
foo draw
bar draw

[then]

1 [if] \ another example
 \ note re-use of draw (and there is no inheritance relationship)
object class point
  cell var x
  cell var y
 :m p! ( x y -- ) y ! x ! ;m
 :m p@ ( -- x y ) x @ y @ ;m
 :m draw x ? y ? ;m
 :m :init ( x y -- ) self p! ;m  \ late bind
\ :m :init ( x y -- ) [ point :: p! ] ;m \ alternatively early bind
drop

1 2 point new constant p1
p1 draw cr
foo draw  \ draw still works on foo and bar
page bar draw
: test 3 4 p1 p! p1 draw  p1 .. x @ p1 .. y @ + . ;
test
\ => 3 4 7

[then] 


bar .. y @  cr .( bar.y = ) . cr