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
   8 .( loading ficl utility classes ) cr
   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 i@ ;
  42         : set  drop i! ;
  43 end-class
  44
  45 object subclass c-cell
  46         cell: .payload
  47
  48         : get  drop @ ;
  49         : set  drop ! ;
  50 end-class
  51
  52
  53 \ ** C - P T R
  54 \ Base class for pointers to scalars (not objects).
  55 \ Note: use c-ref to make references to objects. C-ptr
  56 \ subclasses refer to untyped quantities of various sizes.
  57
  58 \ Derived classes must specify the size of the thing
  59 \ they point to, and supply get and set methods.
  60
  61 \ All derived classes must define the @size method:
  62 \ @size ( inst class -- addr-units )
  63 \ Returns the size in address units of the thing the pointer
  64 \ refers to.
  65 object subclass c-ptr
  66     c-cell obj: .addr
  67
  68     \ get the value of the pointer
  69     : get-ptr   ( inst class -- addr )
  70         c-ptr  => .addr
  71         c-cell => get
  72     ;
  73
  74     \ set the pointer to address supplied
  75     : set-ptr   ( addr inst class -- )
  76         c-ptr  => .addr
  77         c-cell => set
  78     ;
  79
  80     \ force the pointer to be null
  81         : clr-ptr
  82             0 -rot  c-ptr => .addr  c-cell => set
  83         ;
  84
  85     \ return flag indicating null-ness
  86         : ?null     ( inst class -- flag )
  87             c-ptr => get-ptr 0=
  88         ;
  89
  90     \ increment the pointer in place
  91     : inc-ptr   ( inst class -- )
  92         2dup 2dup                   ( i c i c i c )
  93         c-ptr => get-ptr  -rot      ( i c addr i c )
  94         --> @size  +  -rot          ( addr' i c )
  95         c-ptr => set-ptr
  96     ;
  97
  98     \ decrement the pointer in place
  99     : dec-ptr    ( inst class -- )
 100         2dup 2dup                   ( i c i c i c )
 101         c-ptr => get-ptr  -rot      ( i c addr i c )
 102         --> @size  -  -rot          ( addr' i c )
 103         c-ptr => set-ptr
 104     ;
 105
 106     \ index the pointer in place
 107     : index-ptr   ( index inst class -- )
 108         locals| class inst index |
 109         inst class  c-ptr => get-ptr        ( addr )
 110         inst class --> @size  index *  +    ( addr' )
 111         inst class  c-ptr => 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 - I N T P T R
 132 \ Models a pointer to an int (a 32 bit 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 i@
 138     ;
 139         : set   ( value inst class -- )
 140         c-ptr => get-ptr i!
 141     ;
 142 end-class
 143
 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