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 | 9 | \ |
1f99f95d S |
10 | \ Permission to use, copy, modify, and/or distribute this |
11 | \ software for any purpose with or without fee is hereby granted. | |
12 | \ | |
13 | \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL | |
14 | \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED | |
15 | \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL | |
16 | \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR | |
17 | \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING | |
18 | \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF | |
19 | \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF | |
20 | \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. | |
8e9db35f PB |
21 | \ |
22 | \ MOD: PLB 1/16/87 Use abort" instead of er.report | |
23 | \ MDH 4/14/87 Added sign-extend words to ..@ | |
24 | \ MOD: PLB 9/1/87 Add pointer to last member for debug. | |
25 | \ MOD: MDH 4/30/88 Use fast addressing for ..@ and ..! | |
26 | \ MOD: PLB/MDH 9/30/88 Fixed offsets for 16@+long and 8@+long | |
27 | \ fixed OB.COMPILE.+@/! for 0 offset | |
28 | \ MOD: PLB 1/11/89 Added EVEN-UP in case of last member BYTE | |
29 | \ MOD: RDG 9/19/90 Added floating point member support | |
30 | \ MOD: PLB 12/21/90 Optimized ..@ and ..! | |
31 | \ 00001 PLB 11/20/91 Make structures IMMEDIATE with ALITERAL for speed | |
32 | \ Don't need MOVEQ.L #0,D0 for 16@+WORD and 8@+WORD | |
33 | \ 00002 PLB 8/3/92 Added S@ and S!, and support for RPTR | |
34 | \ 951112 PLB Added FS@ and FS! | |
35 | \ This version for the pForth system. | |
36 | ||
37 | ANEW TASK-C_STRUCT | |
38 | ||
39 | decimal | |
40 | \ STRUCT ====================================================== | |
41 | : <:STRUCT> ( pfa -- , run time action for a structure) | |
42 | [COMPILE] CREATE | |
43 | @ even-up here swap dup ( -- here # # ) | |
44 | allot ( make room for ivars ) | |
45 | 0 fill ( initialize to zero ) | |
46 | \ immediate \ 00001 | |
47 | \ DOES> [compile] aliteral \ 00001 | |
48 | ; | |
49 | ||
50 | \ Contents of a structure definition. | |
51 | \ CELL 0 = size of instantiated structures | |
52 | \ CELL 1 = #bytes to last member name in dictionary. | |
53 | \ this is relative so it will work with structure | |
54 | \ relocation schemes like MODULE | |
55 | ||
56 | : :STRUCT ( -- , Create a 'C' structure ) | |
57 | \ Check pairs | |
58 | ob-state @ | |
59 | warning" :STRUCT - Previous :STRUCT or :CLASS unfinished!" | |
60 | ob_def_struct ob-state ! ( set pair flags ) | |
61 | \ | |
62 | \ Create new struct defining word. | |
63 | CREATE | |
64 | here ob-current-class ! ( set current ) | |
65 | 0 , ( initial ivar offset ) | |
66 | 0 , ( location for #byte to last ) | |
67 | DOES> <:STRUCT> | |
68 | ; | |
69 | ||
70 | : ;STRUCT ( -- , terminate structure ) | |
71 | ob-state @ ob_def_struct = NOT | |
72 | abort" ;STRUCT - Missing :STRUCT above!" | |
73 | false ob-state ! | |
74 | ||
75 | \ Point to last member. | |
76 | latest ob-current-class @ body> >name - ( byte difference of NFAs ) | |
77 | ob-current-class @ cell+ ! | |
78 | \ | |
79 | \ Even up byte offset in case last member was BYTE. | |
80 | ob-current-class @ dup @ even-up swap ! | |
81 | ; | |
82 | ||
83 | \ Member reference words. | |
84 | : .. ( object <member> -- member_address , calc addr of member ) | |
85 | ob.stats? drop state @ | |
86 | IF ?dup | |
87 | IF [compile] literal compile + | |
88 | THEN | |
89 | ELSE + | |
90 | THEN | |
91 | ; immediate | |
92 | ||
93 | ||
94 | : (S+C!) ( val addr offset -- ) + c! ; | |
95 | : (S+W!) ( val addr offset -- ) + w! ; | |
96 | : (S+!) ( val addr offset -- ) + ! ; | |
97 | : (S+REL!) ( ptr addr offset -- ) + >r if.use->rel r> ! ; | |
98 | ||
99 | : compile+!bytes ( offset size -- ) | |
cf39ac97 | 100 | \ ." compile+!bytes ( " over . dup . ." )" cr |
8e9db35f PB |
101 | swap [compile] literal \ compile offset into word |
102 | CASE | |
103 | cell OF compile (s+!) ENDOF | |
104 | 2 OF compile (s+w!) ENDOF | |
105 | 1 OF compile (s+c!) ENDOF | |
e14f2533 | 106 | -cell OF compile (s+rel!) ENDOF \ 00002 |
8e9db35f PB |
107 | -2 OF compile (s+w!) ENDOF |
108 | -1 OF compile (s+c!) ENDOF | |
109 | true abort" s! - illegal size!" | |
110 | ENDCASE | |
111 | ; | |
112 | ||
113 | : !BYTES ( value address size -- ) | |
114 | CASE | |
115 | cell OF ! ENDOF | |
e14f2533 | 116 | -cell OF ( aptr addr ) swap if.use->rel swap ! ENDOF \ 00002 |
8e9db35f PB |
117 | ABS |
118 | 2 OF w! ENDOF | |
119 | 1 OF c! ENDOF | |
120 | true abort" s! - illegal size!" | |
121 | ENDCASE | |
122 | ; | |
123 | ||
124 | \ These provide ways of setting and reading members values | |
125 | \ without knowing their size in bytes. | |
126 | : (S!) ( offset size -- , compile proper fetch ) | |
127 | state @ | |
128 | IF compile+!bytes | |
129 | ELSE ( -- value addr off size ) | |
130 | >r + r> !bytes | |
131 | THEN | |
132 | ; | |
133 | : S! ( value object <member> -- , store value in member ) | |
134 | ob.stats? | |
135 | (s!) | |
136 | ; immediate | |
137 | ||
138 | : @BYTES ( addr +/-size -- value ) | |
139 | CASE | |
140 | cell OF @ ENDOF | |
141 | 2 OF w@ ENDOF | |
142 | 1 OF c@ ENDOF | |
e14f2533 | 143 | -cell OF @ if.rel->use ENDOF \ 00002 |
8e9db35f PB |
144 | -2 OF w@ w->s ENDOF |
145 | -1 OF c@ b->s ENDOF | |
146 | true abort" s@ - illegal size!" | |
147 | ENDCASE | |
148 | ; | |
149 | ||
150 | : (S+UC@) ( addr offset -- val ) + c@ ; | |
151 | : (S+UW@) ( addr offset -- val ) + w@ ; | |
152 | : (S+@) ( addr offset -- val ) + @ ; | |
153 | : (S+REL@) ( addr offset -- val ) + @ if.rel->use ; | |
154 | : (S+C@) ( addr offset -- val ) + c@ b->s ; | |
155 | : (S+W@) ( addr offset -- val ) + w@ w->s ; | |
156 | ||
157 | : compile+@bytes ( offset size -- ) | |
cf39ac97 | 158 | \ ." compile+@bytes ( " over . dup . ." )" cr |
8e9db35f PB |
159 | swap [compile] literal \ compile offset into word |
160 | CASE | |
161 | cell OF compile (s+@) ENDOF | |
162 | 2 OF compile (s+uw@) ENDOF | |
163 | 1 OF compile (s+uc@) ENDOF | |
e14f2533 | 164 | -cell OF compile (s+rel@) ENDOF \ 00002 |
8e9db35f PB |
165 | -2 OF compile (s+w@) ENDOF |
166 | -1 OF compile (s+c@) ENDOF | |
167 | true abort" s@ - illegal size!" | |
168 | ENDCASE | |
169 | ; | |
170 | ||
171 | : (S@) ( offset size -- , compile proper fetch ) | |
172 | state @ | |
173 | IF compile+@bytes | |
174 | ELSE >r + r> @bytes | |
175 | THEN | |
176 | ; | |
177 | ||
178 | : S@ ( object <member> -- value , fetch value from member ) | |
179 | ob.stats? | |
180 | (s@) | |
181 | ; immediate | |
182 | ||
8e9db35f PB |
183 | exists? F* [IF] |
184 | \ 951112 Floating Point support | |
185 | : FLPT ( <name> -- , declare space for a floating point value. ) | |
186 | 1 floats bytes | |
187 | ; | |
188 | : (S+F!) ( val addr offset -- ) + f! ; | |
189 | : (S+F@) ( addr offset -- val ) + f@ ; | |
190 | ||
191 | : FS! ( value object <member> -- , fetch value from member ) | |
192 | ob.stats? | |
193 | 1 floats <> abort" FS@ with non-float!" | |
194 | state @ | |
195 | IF | |
196 | [compile] literal | |
197 | compile (s+f!) | |
198 | ELSE (s+f!) | |
199 | THEN | |
200 | ; immediate | |
201 | : FS@ ( object <member> -- value , fetch value from member ) | |
202 | ob.stats? | |
203 | 1 floats <> abort" FS@ with non-float!" | |
204 | state @ | |
205 | IF | |
206 | [compile] literal | |
207 | compile (s+f@) | |
208 | ELSE (s+f@) | |
209 | THEN | |
210 | ; immediate | |
211 | [THEN] | |
212 | ||
213 | 0 [IF] | |
214 | :struct mapper | |
215 | long map_l1 | |
216 | long map_l2 | |
8e9db35f PB |
217 | short map_s1 |
218 | ushort map_s2 | |
219 | byte map_b1 | |
220 | ubyte map_b2 | |
e14f2533 PB |
221 | aptr map_a1 |
222 | rptr map_r1 | |
223 | flpt map_f1 | |
8e9db35f PB |
224 | ;struct |
225 | mapper map1 | |
226 | ||
e14f2533 | 227 | ." compiling TT" cr |
8e9db35f | 228 | : TT |
e14f2533 PB |
229 | 123456 map1 s! map_l1 |
230 | map1 s@ map_l1 123456 - abort" map_l1 failed!" | |
231 | 987654 map1 s! map_l2 | |
232 | map1 s@ map_l2 987654 - abort" map_l2 failed!" | |
233 | ||
8e9db35f | 234 | -500 map1 s! map_s1 |
e14f2533 | 235 | map1 s@ map_s1 dup . cr -500 - abort" map_s1 failed!" |
8e9db35f PB |
236 | -500 map1 s! map_s2 |
237 | map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!" | |
e14f2533 | 238 | |
8e9db35f PB |
239 | -89 map1 s! map_b1 |
240 | map1 s@ map_b1 -89 - abort" map_s1 failed!" | |
241 | here map1 s! map_r1 | |
242 | map1 s@ map_r1 here - abort" map_r1 failed!" | |
243 | -89 map1 s! map_b2 | |
244 | map1 s@ map_b2 -89 $ FF and - abort" map_s2 failed!" | |
245 | 23.45 map1 fs! map_f1 | |
246 | map1 fs@ map_f1 f. ." =?= 23.45" cr | |
247 | ; | |
248 | ." Testing c_struct.fth" cr | |
249 | TT | |
250 | [THEN] |