samples/uroof_sample.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; slightly more complicated OO system than mini-oof
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 use-lib: oof
   9
  10
  11 0 oop:class
  12   class-field clsvar
  13   field x
  14   field y
  15   method init
  16   method xy!
  17   method .xy
  18   class-method clsinit
  19 end-class: Object
  20
  21 .( Object cls=) Object .hex8 cr
  22
  23 Object method: clsinit  ( -- )
  24   endcr ." clsinit: cls=" self .hex8 cr
  25   42 to clsvar
  26   endcr ." class init! clsvar=" clsvar . cr
  27 ;
  28
  29 Object method: init  ( -- )
  30   ." init " class-name type ." (" static-class-name type ." ) ! self=" self .hex8
  31   ."  class=" my-class .hex8 cr
  32   .xy cr
  33   ."  clsvar=" clsvar . cr
  34   clsinit
  35   42 to x  666 to y
  36   .xy cr
  37 ;
  38
  39 Object method: .xy  ( -- )  ." x=" x . ." y=" y 0 .r ;
  40
  41 Object ::invoke Object clsinit
  42
  43 Object oop:new-allot value obj
  44 obj .hex8 cr
  45
  46 obj ::invoke Object init
  47
  48 order
  49 (self@) . cr
  50 .stack
  51
  52
  53 Object oop:class
  54   method child-mt
  55   field child-var
  56   class-method child-class-mt
  57   class-field child-cv
  58   method dispatch-test
  59   method (unknown-dispatch)  ( ... addr count -- )
  60 end-class: Child
  61
  62 Child method: init  ( -- )
  63   ." init " class-name type ." (" static-class-name type ." ) ! self=" self .hex8
  64   ."  class=" my-class .hex8 cr
  65   call-super
  66   ." child inited; " .xy cr
  67   ." :0:x=" self var^ x @ . cr
  68   \ ." :1:x=" addr: x @ . cr
  69   ." :1:x=" to^ x @ . cr
  70   inherited clsinit
  71 ;
  72
  73 Child method: .xy  ( -- )  ." [" inherited .xy ." ]" ;
  74
  75 Child method: (unknown-dispatch)  ( ... addr count -- )
  76   ." UNKNOWN DISPATCH \`" type ." \` in self=0x" self .hex8 cr
  77 ;
  78
  79 Child method: dispatch-test  ( -- )
  80   ." testing dispatch: self=0x" self .hex8 ."  class=0x" my-class .hex8 cr
  81   \ " child-cv" dispatch-str
  82   " child-mt" dispatch-str
  83   ." dispatch complete: self=0x" self .hex8 cr
  84   ." dispatch class: " self invoke class-name type cr
  85   ." static class: 0x" static-class .hex8 cr
  86 ;
  87
  88 Child oop:new-allot value childobj
  89 childobj .hex8 cr
  90
  91 childobj ::invoke Object init
  92
  93 obj ::invoke Object init
  94
  95 : a childobj ::invoke Object init ;
  96 a
  97
  98 Child method: child-class-mt  child-cv . cr 69 to child-cv ." Child class method; " child-cv . cr ;
  99 Child method: child-mt  child-var . cr 666 to child-var ." childcv! " child-cv . child-var . cr ;
 100
 101 Child Child:: child-class-mt
 102 childobj Child:: child-mt
 103
 104 childobj ::invoke Child dispatch-test
 105
 106 childobj " child-yy" ::dispatch-str
 107 childobj " dispatch-test" ::dispatch-str
 108 childobj " child-xx" ::dispatch-str
 109 childobj " child-mt" ::dispatch-str
 110 childobj ." *** class name: " ::invoke Object class-name type cr
 111
 112 childobj ::invoke Child x ." x=" . cr
 113
 114 order
 115 (self@) . cr
 116 .stack
 117 bye