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