classes.fr revision 76116
1207753Smm\ #if (FICL_WANT_OOP) 2207753Smm\ ** ficl/softwords/classes.fr 3207753Smm\ ** F I C L 2 . 0 C L A S S E S 4207753Smm\ john sadler 1 sep 98 5207753Smm\ Needs oop.fr 6207753Smm\ 7207753Smm\ $FreeBSD: head/sys/boot/ficl/softwords/classes.fr 76116 2001-04-29 02:36:36Z dcs $ 8207753Smm 9207753Smmalso oop definitions 10207753Smm 11207753Smm\ REF subclass holds a pointer to an object. It's 12207753Smm\ mainly for aggregation to help in making data structures. 13207753Smm\ 14207753Smmobject subclass c-ref 15207753Smm cell: .class 16207753Smm cell: .instance 17207753Smm 18207753Smm : get ( inst class -- refinst refclass ) 19207753Smm drop 2@ ; 20207753Smm : set ( refinst refclass inst class -- ) 21207753Smm drop 2! ; 22207753Smmend-class 23207753Smm 24207753Smmobject subclass c-byte 25207753Smm char: .payload 26207753Smm 27207753Smm : get drop c@ ; 28207753Smm : set drop c! ; 29207753Smmend-class 30207753Smm 31207753Smmobject subclass c-2byte 32207753Smm 2 chars: .payload 33207753Smm 34207753Smm : get drop w@ ; 35207753Smm : set drop w! ; 36207753Smmend-class 37207753Smm 38207753Smmobject subclass c-4byte 39207753Smm 4 chars: .payload 40207753Smm 41207753Smm : get drop q@ ; 42207753Smm : set drop q! ; 43207753Smmend-class 44207753Smm 45207753Smm 46207753Smmobject subclass c-cell 47207753Smm cell: .payload 48207753Smm 49207753Smm : get drop @ ; 50207753Smm : set drop ! ; 51207753Smmend-class 52207753Smm 53207753Smm 54207753Smm\ ** C - P T R 55207753Smm\ Base class for pointers to scalars (not objects). 56207753Smm\ Note: use c-ref to make references to objects. C-ptr 57207753Smm\ subclasses refer to untyped quantities of various sizes. 58207753Smm 59207753Smm\ Derived classes must specify the size of the thing 60207753Smm\ they point to, and supply get and set methods. 61207753Smm 62207753Smm\ All derived classes must define the @size method: 63207753Smm\ @size ( inst class -- addr-units ) 64207753Smm\ Returns the size in address units of the thing the pointer 65207753Smm\ refers to. 66207753Smmobject subclass c-ptr 67207753Smm c-cell obj: .addr 68207753Smm 69207753Smm \ get the value of the pointer 70207753Smm : get-ptr ( inst class -- addr ) 71207753Smm c-ptr => .addr 72207753Smm c-cell => get 73207753Smm ; 74207753Smm 75207753Smm \ set the pointer to address supplied 76207753Smm : set-ptr ( addr inst class -- ) 77207753Smm c-ptr => .addr 78207753Smm c-cell => set 79207753Smm ; 80207753Smm 81207753Smm \ force the pointer to be null 82207753Smm : clr-ptr 83207753Smm 0 -rot c-ptr => .addr c-cell => set 84207753Smm ; 85207753Smm 86207753Smm \ return flag indicating null-ness 87207753Smm : ?null ( inst class -- flag ) 88207753Smm c-ptr => get-ptr 0= 89207753Smm ; 90207753Smm 91207753Smm \ increment the pointer in place 92207753Smm : inc-ptr ( inst class -- ) 93207753Smm 2dup 2dup ( i c i c i c ) 94207753Smm c-ptr => get-ptr -rot ( i c addr i c ) 95207753Smm --> @size + -rot ( addr' i c ) 96207753Smm c-ptr => set-ptr 97207753Smm ; 98207753Smm 99207753Smm \ decrement the pointer in place 100207753Smm : dec-ptr ( inst class -- ) 101207753Smm 2dup 2dup ( i c i c i c ) 102207753Smm c-ptr => get-ptr -rot ( i c addr i c ) 103207753Smm --> @size - -rot ( addr' i c ) 104207753Smm c-ptr => set-ptr 105207753Smm ; 106207753Smm 107207753Smm \ index the pointer in place 108207753Smm : index-ptr { index 2:this -- } 109207753Smm this --> get-ptr ( addr ) 110207753Smm this --> @size index * + ( addr' ) 111207753Smm this --> set-ptr 112207753Smm ; 113207753Smm 114207753Smmend-class 115207753Smm 116207753Smm 117207753Smm\ ** 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