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 9also 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\ 14object 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! ; 22end-class 23 24object subclass c-byte 25 char: .payload 26 27 : get drop c@ ; 28 : set drop c! ; 29end-class 30 31object subclass c-2byte 32 2 chars: .payload 33 34 : get drop w@ ; 35 : set drop w! ; 36end-class 37 38object subclass c-4byte 39 4 chars: .payload 40 41 : get drop q@ ; 42 : set drop q! ; 43end-class 44 45 46object subclass c-cell 47 cell: .payload 48 49 : get drop @ ; 50 : set drop ! ; 51end-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. 66object 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 114end-class 115 116 117\ ** C - C E L L P T R 118\ Models a pointer to cell (a 32 or 64 bit scalar). 119c-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 ; 128end-class 129 130 131\ ** C - 4 B Y T E P T R 132\ Models a pointer to a quadbyte scalar 133c-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 146c-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 ; 155end-class 156 157 158\ ** C - B Y T E P T R 159\ Models a pointer to an 8 bit scalar 160c-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 ; 169end-class 170 171 172previous definitions 173\ #endif 174