samples/minioof-demo.f

   1 require m-inherited minioof
   2
   3
   4 \ use-lib: ans-tty
   5
   6 ." ROOT OBJECT=0x" object .hex8 cr
   7
   8 Object class
   9   cell var text
  10   cell var len
  11   cell var x
  12   cell var y
  13   method init
  14   method draw
  15 end-class Button
  16 ." BUTTON=0x" Button .hex8 cr
  17
  18 ;; Now, implement the two methods, draw and init:
  19
  20 :noname  ( o -- ) >r
  21   \ r@ x @ r@ y @ at-xy
  22   ." x=" r@ x @ 0 .r ." ; y=" r@ y @ 0 .r ." ; text=<"
  23   r@ text @ r> len @ type
  24   ." >"
  25 ;
  26 Button defines draw
  27
  28 :noname  ( addr u o -- ) >r
  29 ." INIT: class=0x" r@ @class .hex8 ." ; parentclass=0x" r@ @class @class-parent .hex8 cr
  30   6 r@ x ! 12 r@ y ! dup r@ len !
  31   ;; allocate string at "here"
  32   dup n-allot dup r> text ! swap move
  33 ;
  34 Button defines init
  35
  36 ;; For inheritance, we define a class bold-button, with no new data and no new methods.
  37
  38 Button class
  39 end-class Bold-Button
  40 ." BOLD-BUTTON=0x" Bold-Button .hex8 cr
  41
  42 : bold    ( .ansi-escape ." 1m" ) ." [BOLD]" ;
  43 : normal  ( .ansi-escape ." 0m" ) ." [NORMAL]" ;
  44
  45 \ this does early (static) binding
  46 \ :noname  ( o -- ) bold [ Button :: draw ] normal ;
  47 \ this does dynamic binding
  48 \ :noname  ( o -- ) bold  dup @class @class-parent m-invoke draw  normal ;
  49 \ or this (dynamic too)
  50 :noname  ( o -- ) bold  m-inherited draw  normal ;
  51 Bold-Button defines draw
  52
  53 ;; And finally, some code to demonstrate how to create objects and apply methods:
  54
  55 Button new constant foo
  56 s" thin foo" foo init
  57 \ page
  58 foo draw cr
  59 Bold-Button new constant bar
  60 s" fat bar" bar init
  61 bar y 1+!
  62 2 bar x +!
  63 bar draw cr
  64
  65 \ 0 999 at-xy
  66
  67 .stack
  68 bye