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