1*afc2ba1dSToomas SoomeS" FICL_WANT_OOP" ENVIRONMENT? drop [if] 2*afc2ba1dSToomas Soome\ ** ficl/softwords/classes.fr 3*afc2ba1dSToomas Soome\ ** F I C L 2 . 0 C L A S S E S 4*afc2ba1dSToomas Soome\ john sadler 1 sep 98 5*afc2ba1dSToomas Soome\ Needs oop.fr 6*afc2ba1dSToomas Soome 7*afc2ba1dSToomas Soome.( loading ficl utility classes ) cr 8*afc2ba1dSToomas Soomealso oop definitions 9*afc2ba1dSToomas Soome 10*afc2ba1dSToomas Soome\ REF subclass holds a pointer to an object. It's 11*afc2ba1dSToomas Soome\ mainly for aggregation to help in making data structures. 12*afc2ba1dSToomas Soome\ 13*afc2ba1dSToomas Soomeobject subclass c-ref 14*afc2ba1dSToomas Soome cell: .class 15*afc2ba1dSToomas Soome cell: .instance 16*afc2ba1dSToomas Soome 17*afc2ba1dSToomas Soome : get ( inst class -- refinst refclass ) 18*afc2ba1dSToomas Soome drop 2@ ; 19*afc2ba1dSToomas Soome : set ( refinst refclass inst class -- ) 20*afc2ba1dSToomas Soome drop 2! ; 21*afc2ba1dSToomas Soomeend-class 22*afc2ba1dSToomas Soome 23*afc2ba1dSToomas Soomeobject subclass c-byte 24*afc2ba1dSToomas Soome char: .payload 25*afc2ba1dSToomas Soome 26*afc2ba1dSToomas Soome : get drop c@ ; 27*afc2ba1dSToomas Soome : set drop c! ; 28*afc2ba1dSToomas Soomeend-class 29*afc2ba1dSToomas Soome 30*afc2ba1dSToomas Soomeobject subclass c-2byte 31*afc2ba1dSToomas Soome 2 chars: .payload 32*afc2ba1dSToomas Soome 33*afc2ba1dSToomas Soome : get drop w@ ; 34*afc2ba1dSToomas Soome : set drop w! ; 35*afc2ba1dSToomas Soomeend-class 36*afc2ba1dSToomas Soome 37*afc2ba1dSToomas Soomeobject subclass c-4byte 38*afc2ba1dSToomas Soome 4 chars: .payload 39*afc2ba1dSToomas Soome 40*afc2ba1dSToomas Soome : get drop q@ ; 41*afc2ba1dSToomas Soome : set drop q! ; 42*afc2ba1dSToomas Soomeend-class 43*afc2ba1dSToomas Soome 44*afc2ba1dSToomas Soome 45*afc2ba1dSToomas Soomeobject subclass c-cell 46*afc2ba1dSToomas Soome cell: .payload 47*afc2ba1dSToomas Soome 48*afc2ba1dSToomas Soome : get drop @ ; 49*afc2ba1dSToomas Soome : set drop ! ; 50*afc2ba1dSToomas Soomeend-class 51*afc2ba1dSToomas Soome 52*afc2ba1dSToomas Soome 53*afc2ba1dSToomas Soome\ ** C - P T R 54*afc2ba1dSToomas Soome\ Base class for pointers to scalars (not objects). 55*afc2ba1dSToomas Soome\ Note: use c-ref to make references to objects. C-ptr 56*afc2ba1dSToomas Soome\ subclasses refer to untyped quantities of various sizes. 57*afc2ba1dSToomas Soome 58*afc2ba1dSToomas Soome\ Derived classes must specify the size of the thing 59*afc2ba1dSToomas Soome\ they point to, and supply get and set methods. 60*afc2ba1dSToomas Soome 61*afc2ba1dSToomas Soome\ All derived classes must define the @size method: 62*afc2ba1dSToomas Soome\ @size ( inst class -- addr-units ) 63*afc2ba1dSToomas Soome\ Returns the size in address units of the thing the pointer 64*afc2ba1dSToomas Soome\ refers to. 65*afc2ba1dSToomas Soomeobject subclass c-ptr 66*afc2ba1dSToomas Soome c-cell obj: .addr 67*afc2ba1dSToomas Soome 68*afc2ba1dSToomas Soome \ get the value of the pointer 69*afc2ba1dSToomas Soome : get-ptr ( inst class -- addr ) 70*afc2ba1dSToomas Soome c-ptr => .addr 71*afc2ba1dSToomas Soome c-cell => get 72*afc2ba1dSToomas Soome ; 73*afc2ba1dSToomas Soome 74*afc2ba1dSToomas Soome \ set the pointer to address supplied 75*afc2ba1dSToomas Soome : set-ptr ( addr inst class -- ) 76*afc2ba1dSToomas Soome c-ptr => .addr 77*afc2ba1dSToomas Soome c-cell => set 78*afc2ba1dSToomas Soome ; 79*afc2ba1dSToomas Soome 80*afc2ba1dSToomas Soome \ force the pointer to be null 81*afc2ba1dSToomas Soome : clr-ptr 82*afc2ba1dSToomas Soome 0 -rot c-ptr => .addr c-cell => set 83*afc2ba1dSToomas Soome ; 84*afc2ba1dSToomas Soome 85*afc2ba1dSToomas Soome \ return flag indicating null-ness 86*afc2ba1dSToomas Soome : ?null ( inst class -- flag ) 87*afc2ba1dSToomas Soome c-ptr => get-ptr 0= 88*afc2ba1dSToomas Soome ; 89*afc2ba1dSToomas Soome 90*afc2ba1dSToomas Soome \ increment the pointer in place 91*afc2ba1dSToomas Soome : inc-ptr ( inst class -- ) 92*afc2ba1dSToomas Soome 2dup 2dup ( i c i c i c ) 93*afc2ba1dSToomas Soome c-ptr => get-ptr -rot ( i c addr i c ) 94*afc2ba1dSToomas Soome --> @size + -rot ( addr' i c ) 95*afc2ba1dSToomas Soome c-ptr => set-ptr 96*afc2ba1dSToomas Soome ; 97*afc2ba1dSToomas Soome 98*afc2ba1dSToomas Soome \ decrement the pointer in place 99*afc2ba1dSToomas Soome : dec-ptr ( inst class -- ) 100*afc2ba1dSToomas Soome 2dup 2dup ( i c i c i c ) 101*afc2ba1dSToomas Soome c-ptr => get-ptr -rot ( i c addr i c ) 102*afc2ba1dSToomas Soome --> @size - -rot ( addr' i c ) 103*afc2ba1dSToomas Soome c-ptr => set-ptr 104*afc2ba1dSToomas Soome ; 105*afc2ba1dSToomas Soome 106*afc2ba1dSToomas Soome \ index the pointer in place 107*afc2ba1dSToomas Soome : index-ptr { index 2:this -- } 108*afc2ba1dSToomas Soome this --> get-ptr ( addr ) 109*afc2ba1dSToomas Soome this --> @size index * + ( addr' ) 110*afc2ba1dSToomas Soome this --> set-ptr 111*afc2ba1dSToomas Soome ; 112*afc2ba1dSToomas Soome 113*afc2ba1dSToomas Soomeend-class 114*afc2ba1dSToomas Soome 115*afc2ba1dSToomas Soome 116*afc2ba1dSToomas Soome\ ** C - C E L L P T R 117*afc2ba1dSToomas Soome\ Models a pointer to cell (a 32 or 64 bit scalar). 118*afc2ba1dSToomas Soomec-ptr subclass c-cellPtr 119*afc2ba1dSToomas Soome : @size 2drop 1 cells ; 120*afc2ba1dSToomas Soome \ fetch and store through the pointer 121*afc2ba1dSToomas Soome : get ( inst class -- cell ) 122*afc2ba1dSToomas Soome c-ptr => get-ptr @ 123*afc2ba1dSToomas Soome ; 124*afc2ba1dSToomas Soome : set ( value inst class -- ) 125*afc2ba1dSToomas Soome c-ptr => get-ptr ! 126*afc2ba1dSToomas Soome ; 127*afc2ba1dSToomas Soomeend-class 128*afc2ba1dSToomas Soome 129*afc2ba1dSToomas Soome 130*afc2ba1dSToomas Soome\ ** C - 4 B Y T E P T R 131*afc2ba1dSToomas Soome\ Models a pointer to a quadbyte scalar 132*afc2ba1dSToomas Soomec-ptr subclass c-4bytePtr 133*afc2ba1dSToomas Soome : @size 2drop 4 ; 134*afc2ba1dSToomas Soome \ fetch and store through the pointer 135*afc2ba1dSToomas Soome : get ( inst class -- value ) 136*afc2ba1dSToomas Soome c-ptr => get-ptr q@ 137*afc2ba1dSToomas Soome ; 138*afc2ba1dSToomas Soome : set ( value inst class -- ) 139*afc2ba1dSToomas Soome c-ptr => get-ptr q! 140*afc2ba1dSToomas Soome ; 141*afc2ba1dSToomas Soome end-class 142*afc2ba1dSToomas Soome 143*afc2ba1dSToomas Soome\ ** C - 2 B Y T E P T R 144*afc2ba1dSToomas Soome\ Models a pointer to a 16 bit scalar 145*afc2ba1dSToomas Soomec-ptr subclass c-2bytePtr 146*afc2ba1dSToomas Soome : @size 2drop 2 ; 147*afc2ba1dSToomas Soome \ fetch and store through the pointer 148*afc2ba1dSToomas Soome : get ( inst class -- value ) 149*afc2ba1dSToomas Soome c-ptr => get-ptr w@ 150*afc2ba1dSToomas Soome ; 151*afc2ba1dSToomas Soome : set ( value inst class -- ) 152*afc2ba1dSToomas Soome c-ptr => get-ptr w! 153*afc2ba1dSToomas Soome ; 154*afc2ba1dSToomas Soomeend-class 155*afc2ba1dSToomas Soome 156*afc2ba1dSToomas Soome 157*afc2ba1dSToomas Soome\ ** C - B Y T E P T R 158*afc2ba1dSToomas Soome\ Models a pointer to an 8 bit scalar 159*afc2ba1dSToomas Soomec-ptr subclass c-bytePtr 160*afc2ba1dSToomas Soome : @size 2drop 1 ; 161*afc2ba1dSToomas Soome \ fetch and store through the pointer 162*afc2ba1dSToomas Soome : get ( inst class -- value ) 163*afc2ba1dSToomas Soome c-ptr => get-ptr c@ 164*afc2ba1dSToomas Soome ; 165*afc2ba1dSToomas Soome : set ( value inst class -- ) 166*afc2ba1dSToomas Soome c-ptr => get-ptr c! 167*afc2ba1dSToomas Soome ; 168*afc2ba1dSToomas Soomeend-class 169*afc2ba1dSToomas Soome 170*afc2ba1dSToomas Soome 171*afc2ba1dSToomas Soomeprevious definitions 172*afc2ba1dSToomas Soome[endif] 173