sys/boot/ficl/softwords/classes.fr

   1 \ #if (FICL_WANT_OOP)
   2 \ ** ficl/softwords/classes.fr
   3 \ ** F I C L   2 . 0   C L A S S E S
   4 \ john sadler  1 sep 98
   5 \ Needs oop.fr
   6 \
   7 \ $FreeBSD$
   8
   9 also oop definitions
  10
  11 \ REF subclass holds a pointer to an object. It's
  12 \ mainly for aggregation to help in making data structures.
  13 \
  14 object subclass c-ref
  15     cell: .class
  16     cell: .instance
  17
  18         : get   ( inst class -- refinst refclass )
  19                 drop 2@ ;
  20         : set   ( refinst refclass inst class -- )
  21                 drop 2! ;
  22 end-class
  23
  24 object subclass c-byte
  25         char: .payload
  26
  27         : get  drop c@ ;
  28         : set  drop c! ;
  29 end-class
  30
  31 object subclass c-2byte
  32         2 chars: .payload
  33
  34         : get  drop w@ ;
  35         : set  drop w! ;
  36 end-class
  37
  38 object subclass c-4byte
  39         4 chars: .payload
  40
  41         : get  drop q@ ;
  42         : set  drop q! ;
  43 end-class
  44
  45
  46 object subclass c-cell
  47         cell: .payload
  48
  49         : get  drop @ ;
  50         : set  drop ! ;
  51 end-class
  52
  53
  54 \ ** C - P T R
  55 \ Base class for pointers to scalars (not objects).
  56 \ Note: use c-ref to make references to objects. C-ptr
  57 \ subclasses refer to untyped quantities of various sizes.
  58
  59 \ Derived classes must specify the size of the thing
  60 \ they point to, and supply get and set methods.
  61
  62 \ All derived classes must define the @size method:
  63 \ @size ( inst class -- addr-units )
  64 \ Returns the size in address units of the thing the pointer
  65 \ refers to.
  66 object subclass c-ptr
  67     c-cell obj: .addr
  68
  69     \ get the value of the pointer
  70     : get-ptr   ( inst class -- addr )
  71         c-ptr  => .addr
  72         c-cell => get
  73     ;
  74
  75     \ set the pointer to address supplied
  76     : set-ptr   ( addr inst class -- )
  77         c-ptr  => .addr
  78         c-cell => set
  79     ;
  80
  81     \ force the pointer to be null
  82         : clr-ptr
  83             0 -rot  c-ptr => .addr  c-cell => set
  84         ;
  85
  86     \ return flag indicating null-ness
  87         : ?null     ( inst class -- flag )
  88             c-ptr => get-ptr 0=
  89         ;
  90
  91     \ increment the pointer in place
  92     : inc-ptr   ( inst class -- )
  93         2dup 2dup                   ( i c i c i c )
  94         c-ptr => get-ptr  -rot      ( i c addr i c )
  95         --> @size  +  -rot          ( addr' i c )
  96         c-ptr => set-ptr
  97     ;
  98
  99     \ decrement the pointer in place
 100     : dec-ptr    ( inst class -- )
 101         2dup 2dup                   ( i c i c i c )
 102         c-ptr => get-ptr  -rot      ( i c addr i c )
 103         --> @size  -  -rot          ( addr' i c )
 104         c-ptr => set-ptr
 105     ;
 106
 107     \ index the pointer in place
 108     : index-ptr   { index 2:this -- }
 109         this --> get-ptr              ( addr )
 110         this --> @size  index *  +    ( addr' )
 111         this --> set-ptr
 112     ;
 113
 114 end-class
 115
 116
 117 \ ** C - C E L L P T R
 118 \ Models a pointer to cell (a 32 or 64 bit scalar).
 119 c-ptr subclass c-cellPtr
 120     : @size   2drop  1 cells ;
 121     \ fetch and store through the pointer
 122         : get   ( inst class -- cell )
 123         c-ptr => get-ptr @
 124     ;
 125         : set   ( value inst class -- )
 126         c-ptr => get-ptr !
 127     ;
 128 end-class
 129
 130
 131 \ ** C - 4 B Y T E P T R
 132 \ Models a pointer to a quadbyte scalar
 133 c-ptr subclass c-4bytePtr
 134     : @size   2drop  4  ;
 135     \ fetch and store through the pointer
 136         : get   ( inst class -- value )
 137         c-ptr => get-ptr q@
 138     ;
 139         : set   ( value inst class -- )
 140         c-ptr => get-ptr q!
 141     ;
 142  end-class
 143
 144 \ ** C - 2 B Y T E P T R
 145 \ Models a pointer to a 16 bit scalar
 146 c-ptr subclass c-2bytePtr
 147     : @size   2drop  2  ;
 148     \ fetch and store through the pointer
 149         : get   ( inst class -- value )
 150         c-ptr => get-ptr w@
 151     ;
 152         : set   ( value inst class -- )
 153         c-ptr => get-ptr w!
 154     ;
 155 end-class
 156
 157
 158 \ ** C - B Y T E P T R
 159 \ Models a pointer to an 8 bit scalar
 160 c-ptr subclass c-bytePtr
 161     : @size   2drop  1  ;
 162     \ fetch and store through the pointer
 163         : get   ( inst class -- value )
 164         c-ptr => get-ptr c@
 165     ;
 166         : set   ( value inst class -- )
 167         c-ptr => get-ptr c!
 168     ;
 169 end-class
 170
 171
 172 previous definitions
 173 \ #endif