stand/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
   8 also oop definitions
   9
  10 \ REF subclass holds a pointer to an object. It's
  11 \ mainly for aggregation to help in making data structures.
  12 \
  13 object subclass c-ref
  14     cell: .class
  15     cell: .instance
  16
  17         : get   ( inst class -- refinst refclass )
  18                 drop 2@ ;
  19         : set   ( refinst refclass inst class -- )
  20                 drop 2! ;
  21 end-class
  22
  23 object subclass c-byte
  24         char: .payload
  25
  26         : get  drop c@ ;
  27         : set  drop c! ;
  28 end-class
  29
  30 object subclass c-2byte
  31         2 chars: .payload
  32
  33         : get  drop w@ ;
  34         : set  drop w! ;
  35 end-class
  36
  37 object subclass c-4byte
  38         4 chars: .payload
  39
  40         : get  drop q@ ;
  41         : set  drop q! ;
  42 end-class
  43
  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 2:this -- }
 108         this --> get-ptr              ( addr )
 109         this --> @size  index *  +    ( addr' )
 110         this --> set-ptr
 111     ;
 112
 113 end-class
 114
 115
 116 \ ** C - C E L L P T R
 117 \ Models a pointer to cell (a 32 or 64 bit scalar).
 118 c-ptr subclass c-cellPtr
 119     : @size   2drop  1 cells ;
 120     \ fetch and store through the pointer
 121         : get   ( inst class -- cell )
 122         c-ptr => get-ptr @
 123     ;
 124         : set   ( value inst class -- )
 125         c-ptr => get-ptr !
 126     ;
 127 end-class
 128
 129
 130 \ ** C - 4 B Y T E P T R
 131 \ Models a pointer to a quadbyte scalar
 132 c-ptr subclass c-4bytePtr
 133     : @size   2drop  4  ;
 134     \ fetch and store through the pointer
 135         : get   ( inst class -- value )
 136         c-ptr => get-ptr q@
 137     ;
 138         : set   ( value inst class -- )
 139         c-ptr => get-ptr q!
 140     ;
 141  end-class
 142
 143 \ ** C - 2 B Y T E P T R
 144 \ Models a pointer to a 16 bit scalar
 145 c-ptr subclass c-2bytePtr
 146     : @size   2drop  2  ;
 147     \ fetch and store through the pointer
 148         : get   ( inst class -- value )
 149         c-ptr => get-ptr w@
 150     ;
 151         : set   ( value inst class -- )
 152         c-ptr => get-ptr w!
 153     ;
 154 end-class
 155
 156
 157 \ ** C - B Y T E P T R
 158 \ Models a pointer to an 8 bit scalar
 159 c-ptr subclass c-bytePtr
 160     : @size   2drop  1  ;
 161     \ fetch and store through the pointer
 162         : get   ( inst class -- value )
 163         c-ptr => get-ptr c@
 164     ;
 165         : set   ( value inst class -- )
 166         c-ptr => get-ptr c!
 167     ;
 168 end-class
 169
 170
 171 previous definitions
 172 \ #endif