urflibs/tests/uroof-sample-1.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth/C
   3 ;; Copyright (C) 2023 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; slightly more complicated OO system than mini-oof
   7 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9 $INCLUDE-ONCE <uroof.f>
  10
  11
  12 oof:class: MyItem
  13   field: fld
  14   method: mth1
  15   method: mth2
  16 end-class
  17
  18 oof:class: MyList
  19   MyItem obj-value: item-ptr
  20   method: item@
  21   method: item!
  22   method: doit
  23 end-class
  24
  25
  26 MyList oof:method: item@  ( -- addr )
  27   -> item-ptr @
  28 ;
  29 \ MyList oof:method-cfa: item debug:(decompile-cfa)
  30
  31 MyList oof:method: item!  ( addr -- )
  32   to item-ptr
  33 ;
  34
  35 MyList oof:method: doit  ( -- )
  36   item-ptr mth1
  37   item-ptr mth2
  38   item-ptr mth1
  39   item-ptr mth2
  40 ;
  41 \ MyList oof:method-cfa: doit debug:(decompile-cfa)
  42
  43
  44 MyItem oof:method: mth1  ( -- )
  45   \ ." fld: " fld . cr
  46   ." === MTH1 ===" cr
  47   ."   self: " self . cr
  48   ."   fld: " fld . cr
  49   ."   fld: " -> fld @ . cr
  50   69 to fld
  51 ;
  52
  53 MyItem oof:method: mth2  ( -- )
  54   \ ." fld: " fld . cr
  55   ." === MTH2 ===" cr
  56   ."   self: " self . cr
  57   ."   fld: " fld . cr
  58   ."   fld: " -> fld @ . cr
  59   ."   class-name: " @class oof:name-of type cr
  60   ."   size-of: " @class oof:size-of . cr
  61   @class oof:parent-of ?dup if
  62   ."   parent: " oof:name-of type cr
  63   endif
  64   666 to fld
  65 ;
  66
  67 MyList oof:obj-value head
  68 MyList oof:new to head
  69
  70 MyItem oof:new dup head item!
  71 head item@ <> " fucka? (0)" ?error
  72 head doit
  73 0 head item!
  74 \ head doit
  75
  76 MyItem oof:new dup head item!
  77 head item@ <> " fucka? (1)" ?error
  78 head doit
  79
  80 abort