1S" FICL_WANT_OOP" ENVIRONMENT? drop [if] 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.( loading ficl utility classes ) cr 8also 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\ 13object 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! ; 21end-class 22 23object subclass c-byte 24 char: .payload 25 26 : get drop c@ ; 27 : set drop c! ; 28end-class 29 30object subclass c-2byte 31 2 chars: .payload 32 33 : get drop w@ ; 34 : set drop w! ; 35end-class 36 37object subclass c-4byte 38 4 chars: .payload 39 40 : get drop q@ ; 41 : set drop q! ; 42end-class 43 44 45object subclass c-cell 46 cell: .payload 47 48 : get drop @ ; 49 : set drop ! ; 50end-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. 65object 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 113end-class 114 115 116\ ** C - C E L L P T R 117\ Models a pointer to cell (a 32 or 64 bit scalar). 118c-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 ; 127end-class 128 129 130\ ** C - 4 B Y T E P T R 131\ Models a pointer to a quadbyte scalar 132c-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 145c-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 ; 154end-class 155 156 157\ ** C - B Y T E P T R 158\ Models a pointer to an 8 bit scalar 159c-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 ; 168end-class 169 170 171previous definitions 172[endif] 173