Commit | Line | Data |
---|---|---|
8e9db35f PB |
1 | \ @(#) c_struct.fth 98/01/26 1.2 |
2 | \ STRUCTUREs are for interfacing with 'C' programs. | |
3 | \ Structures are created using :STRUCT and ;STRUCT | |
4 | \ | |
5 | \ This file must be loaded before loading any .J files. | |
6 | \ | |
7 | \ Author: Phil Burk | |
1a088514 | 8 | \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom |
8e9db35f PB |
9 | \ |
10 | \ The pForth software code is dedicated to the public domain, | |
11 | \ and any third party may reproduce, distribute and modify | |
12 | \ the pForth software code or any derivative works thereof | |
13 | \ without any compensation or license. The pForth software | |
14 | \ code is provided on an "as is" basis without any warranty | |
15 | \ of any kind, including, without limitation, the implied | |
16 | \ warranties of merchantability and fitness for a particular | |
17 | \ purpose and their equivalents under the laws of any jurisdiction. | |
18 | \ | |
19 | \ MOD: PLB 1/16/87 Use abort" instead of er.report | |
20 | \ MDH 4/14/87 Added sign-extend words to ..@ | |
21 | \ MOD: PLB 9/1/87 Add pointer to last member for debug. | |
22 | \ MOD: MDH 4/30/88 Use fast addressing for ..@ and ..! | |
23 | \ MOD: PLB/MDH 9/30/88 Fixed offsets for 16@+long and 8@+long | |
24 | \ fixed OB.COMPILE.+@/! for 0 offset | |
25 | \ MOD: PLB 1/11/89 Added EVEN-UP in case of last member BYTE | |
26 | \ MOD: RDG 9/19/90 Added floating point member support | |
27 | \ MOD: PLB 12/21/90 Optimized ..@ and ..! | |
28 | \ 00001 PLB 11/20/91 Make structures IMMEDIATE with ALITERAL for speed | |
29 | \ Don't need MOVEQ.L #0,D0 for 16@+WORD and 8@+WORD | |
30 | \ 00002 PLB 8/3/92 Added S@ and S!, and support for RPTR | |
31 | \ 951112 PLB Added FS@ and FS! | |
32 | \ This version for the pForth system. | |
33 | ||
34 | ANEW TASK-C_STRUCT | |
35 | ||
36 | decimal | |
37 | \ STRUCT ====================================================== | |
38 | : <:STRUCT> ( pfa -- , run time action for a structure) | |
39 | [COMPILE] CREATE | |
40 | @ even-up here swap dup ( -- here # # ) | |
41 | allot ( make room for ivars ) | |
42 | 0 fill ( initialize to zero ) | |
43 | \ immediate \ 00001 | |
44 | \ DOES> [compile] aliteral \ 00001 | |
45 | ; | |
46 | ||
47 | \ Contents of a structure definition. | |
48 | \ CELL 0 = size of instantiated structures | |
49 | \ CELL 1 = #bytes to last member name in dictionary. | |
50 | \ this is relative so it will work with structure | |
51 | \ relocation schemes like MODULE | |
52 | ||
53 | : :STRUCT ( -- , Create a 'C' structure ) | |
54 | \ Check pairs | |
55 | ob-state @ | |
56 | warning" :STRUCT - Previous :STRUCT or :CLASS unfinished!" | |
57 | ob_def_struct ob-state ! ( set pair flags ) | |
58 | \ | |
59 | \ Create new struct defining word. | |
60 | CREATE | |
61 | here ob-current-class ! ( set current ) | |
62 | 0 , ( initial ivar offset ) | |
63 | 0 , ( location for #byte to last ) | |
64 | DOES> <:STRUCT> | |
65 | ; | |
66 | ||
67 | : ;STRUCT ( -- , terminate structure ) | |
68 | ob-state @ ob_def_struct = NOT | |
69 | abort" ;STRUCT - Missing :STRUCT above!" | |
70 | false ob-state ! | |
71 | ||
72 | \ Point to last member. | |
73 | latest ob-current-class @ body> >name - ( byte difference of NFAs ) | |
74 | ob-current-class @ cell+ ! | |
75 | \ | |
76 | \ Even up byte offset in case last member was BYTE. | |
77 | ob-current-class @ dup @ even-up swap ! | |
78 | ; | |
79 | ||
80 | \ Member reference words. | |
81 | : .. ( object <member> -- member_address , calc addr of member ) | |
82 | ob.stats? drop state @ | |
83 | IF ?dup | |
84 | IF [compile] literal compile + | |
85 | THEN | |
86 | ELSE + | |
87 | THEN | |
88 | ; immediate | |
89 | ||
90 | ||
91 | : (S+C!) ( val addr offset -- ) + c! ; | |
92 | : (S+W!) ( val addr offset -- ) + w! ; | |
93 | : (S+!) ( val addr offset -- ) + ! ; | |
94 | : (S+REL!) ( ptr addr offset -- ) + >r if.use->rel r> ! ; | |
95 | ||
96 | : compile+!bytes ( offset size -- ) | |
97 | \ ." compile+!bytes ( " over . dup . ." )" cr | |
98 | swap [compile] literal \ compile offset into word | |
99 | CASE | |
100 | cell OF compile (s+!) ENDOF | |
101 | 2 OF compile (s+w!) ENDOF | |
102 | 1 OF compile (s+c!) ENDOF | |
103 | -4 OF compile (s+rel!) ENDOF \ 00002 | |
104 | -2 OF compile (s+w!) ENDOF | |
105 | -1 OF compile (s+c!) ENDOF | |
106 | true abort" s! - illegal size!" | |
107 | ENDCASE | |
108 | ; | |
109 | ||
110 | : !BYTES ( value address size -- ) | |
111 | CASE | |
112 | cell OF ! ENDOF | |
113 | -4 OF ( aptr addr ) swap if.use->rel swap ! ENDOF \ 00002 | |
114 | ABS | |
115 | 2 OF w! ENDOF | |
116 | 1 OF c! ENDOF | |
117 | true abort" s! - illegal size!" | |
118 | ENDCASE | |
119 | ; | |
120 | ||
121 | \ These provide ways of setting and reading members values | |
122 | \ without knowing their size in bytes. | |
123 | : (S!) ( offset size -- , compile proper fetch ) | |
124 | state @ | |
125 | IF compile+!bytes | |
126 | ELSE ( -- value addr off size ) | |
127 | >r + r> !bytes | |
128 | THEN | |
129 | ; | |
130 | : S! ( value object <member> -- , store value in member ) | |
131 | ob.stats? | |
132 | (s!) | |
133 | ; immediate | |
134 | ||
135 | : @BYTES ( addr +/-size -- value ) | |
136 | CASE | |
137 | cell OF @ ENDOF | |
138 | 2 OF w@ ENDOF | |
139 | 1 OF c@ ENDOF | |
140 | -4 OF @ if.rel->use ENDOF \ 00002 | |
141 | -2 OF w@ w->s ENDOF | |
142 | -1 OF c@ b->s ENDOF | |
143 | true abort" s@ - illegal size!" | |
144 | ENDCASE | |
145 | ; | |
146 | ||
147 | : (S+UC@) ( addr offset -- val ) + c@ ; | |
148 | : (S+UW@) ( addr offset -- val ) + w@ ; | |
149 | : (S+@) ( addr offset -- val ) + @ ; | |
150 | : (S+REL@) ( addr offset -- val ) + @ if.rel->use ; | |
151 | : (S+C@) ( addr offset -- val ) + c@ b->s ; | |
152 | : (S+W@) ( addr offset -- val ) + w@ w->s ; | |
153 | ||
154 | : compile+@bytes ( offset size -- ) | |
155 | \ ." compile+@bytes ( " over . dup . ." )" cr | |
156 | swap [compile] literal \ compile offset into word | |
157 | CASE | |
158 | cell OF compile (s+@) ENDOF | |
159 | 2 OF compile (s+uw@) ENDOF | |
160 | 1 OF compile (s+uc@) ENDOF | |
161 | -4 OF compile (s+rel@) ENDOF \ 00002 | |
162 | -2 OF compile (s+w@) ENDOF | |
163 | -1 OF compile (s+c@) ENDOF | |
164 | true abort" s@ - illegal size!" | |
165 | ENDCASE | |
166 | ; | |
167 | ||
168 | : (S@) ( offset size -- , compile proper fetch ) | |
169 | state @ | |
170 | IF compile+@bytes | |
171 | ELSE >r + r> @bytes | |
172 | THEN | |
173 | ; | |
174 | ||
175 | : S@ ( object <member> -- value , fetch value from member ) | |
176 | ob.stats? | |
177 | (s@) | |
178 | ; immediate | |
179 | ||
180 | ||
181 | ||
182 | exists? F* [IF] | |
183 | \ 951112 Floating Point support | |
184 | : FLPT ( <name> -- , declare space for a floating point value. ) | |
185 | 1 floats bytes | |
186 | ; | |
187 | : (S+F!) ( val addr offset -- ) + f! ; | |
188 | : (S+F@) ( addr offset -- val ) + f@ ; | |
189 | ||
190 | : FS! ( value object <member> -- , fetch value from member ) | |
191 | ob.stats? | |
192 | 1 floats <> abort" FS@ with non-float!" | |
193 | state @ | |
194 | IF | |
195 | [compile] literal | |
196 | compile (s+f!) | |
197 | ELSE (s+f!) | |
198 | THEN | |
199 | ; immediate | |
200 | : FS@ ( object <member> -- value , fetch value from member ) | |
201 | ob.stats? | |
202 | 1 floats <> abort" FS@ with non-float!" | |
203 | state @ | |
204 | IF | |
205 | [compile] literal | |
206 | compile (s+f@) | |
207 | ELSE (s+f@) | |
208 | THEN | |
209 | ; immediate | |
210 | [THEN] | |
211 | ||
212 | 0 [IF] | |
213 | :struct mapper | |
214 | long map_l1 | |
215 | long map_l2 | |
216 | aptr map_a1 | |
217 | rptr map_r1 | |
218 | flpt map_f1 | |
219 | short map_s1 | |
220 | ushort map_s2 | |
221 | byte map_b1 | |
222 | ubyte map_b2 | |
223 | ;struct | |
224 | mapper map1 | |
225 | ||
226 | : TT | |
227 | -500 map1 s! map_s1 | |
228 | map1 s@ map_s1 -500 - abort" map_s1 failed!" | |
229 | -500 map1 s! map_s2 | |
230 | map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!" | |
231 | -89 map1 s! map_b1 | |
232 | map1 s@ map_b1 -89 - abort" map_s1 failed!" | |
233 | here map1 s! map_r1 | |
234 | map1 s@ map_r1 here - abort" map_r1 failed!" | |
235 | -89 map1 s! map_b2 | |
236 | map1 s@ map_b2 -89 $ FF and - abort" map_s2 failed!" | |
237 | 23.45 map1 fs! map_f1 | |
238 | map1 fs@ map_f1 f. ." =?= 23.45" cr | |
239 | ; | |
240 | ." Testing c_struct.fth" cr | |
241 | TT | |
242 | [THEN] |