sys/boot/ficl/softwords/classes.fr

   1 \ ** ficl/softwords/classes.fr
   2 \ ** F I C L   2 . 0   C L A S S E S
   3 \ john sadler  1 sep 98
   4 \ Needs oop.fr
   5 \
   6 \ $FreeBSD: src/sys/boot/ficl/softwords/classes.fr,v 1.1.6.1 2000/07/06 23:51:46 obrien Exp $
   7 \ $DragonFly: src/sys/boot/ficl/softwords/classes.fr,v 1.2 2003/06/17 04:28:18 dillon Exp $
   8
   9 .( loading ficl utility classes ) cr
  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 i@ ;
  43         : set  drop i! ;
  44 end-class
  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 inst class -- )
 109         locals| class inst index |
 110         inst class  c-ptr => get-ptr        ( addr )
 111         inst class --> @size  index *  +    ( addr' )
 112         inst class  c-ptr => 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 - I N T P T R
 133 \ Models a pointer to an int (a 32 bit 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 i@
 139     ;
 140         : set   ( value inst class -- )
 141         c-ptr => get-ptr i!
 142     ;
 143 end-class
 144
 145
 146 \ ** C - 2 B Y T E P T R
 147 \ Models a pointer to a 16 bit scalar
 148 c-ptr subclass c-2bytePtr
 149     : @size   2drop  2  ;
 150     \ fetch and store through the pointer
 151         : get   ( inst class -- value )
 152         c-ptr => get-ptr w@
 153     ;
 154         : set   ( value inst class -- )
 155         c-ptr => get-ptr w!
 156     ;
 157 end-class
 158
 159
 160 \ ** C - B Y T E P T R
 161 \ Models a pointer to an 8 bit scalar
 162 c-ptr subclass c-bytePtr
 163     : @size   2drop  1  ;
 164     \ fetch and store through the pointer
 165         : get   ( inst class -- value )
 166         c-ptr => get-ptr c@
 167     ;
 168         : set   ( value inst class -- )
 169         c-ptr => get-ptr c!
 170     ;
 171 end-class
 172
 173
 174 previous definitions