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