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