data.c
1 //! @file data.c
2 //! @author J. Marcel van der Veer
3 //
4 //! @section Copyright
5 //
6 // This file is part of VIF - vintage FORTRAN compiler.
7 // Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
8 //
9 //! @section License
10 //
11 // This program is free software; you can redistribute it and/or modify it
12 // under the terms of the GNU General Public License as published by the
13 // Free Software Foundation; either version 3 of the License, or
14 // (at your option) any later version.
15 //
16 // This program is distributed in the hope that it will be useful, but
17 // WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 // or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 // more details. You should have received a copy of the GNU General Public
20 // License along with this program. If not, see <http://www.gnu.org/licenses/>.
21
22 //! @section Synopsis
23 //!
24 //! Compile DATA.
25
26 #include <vif.h>
27
28 //
29 // DATA STATEMENT
30 //
31
32 void const_list (MODE * mode, int_4 *items)
33 {
34 while (WITHIN) {
35 int_4 rc = scan (EXPECT_NONE);
36 if (!WITHIN) {
37 ;
38 } else {
39 int_8 repeat = 1;
40 if (curret == INT_NUMBER) {
41 repeat = strtoll (curlex, NO_REF_TEXT, 10);
42 rc = scan (EXPECT_NONE);
43 if (TOKEN ("*")) {
44 rc = scan (EXPECT_NONE);
45 } else {
46 repeat = 1;
47 UNSCAN;
48 }
49 }
50 EXPR reg;
51 factor (®);
52 if (reg.variant != EXPR_CONST) {
53 EXPECT (801, "constant");
54 } else if (!accept_mode (reg.mode.type, reg.mode.len, mode->type, mode->len)) {
55 MODE_ERROR (802, qtype (&(reg.mode)), qtype (mode));
56 }
57 for (int_4 k = 0; k < repeat; k++) {
58 if (reg.mode.type == CHARACTER && mode->type == INTEGER && mode->len == 4) {
59 NEW_RECORD (str); NEW_RECORD (buf);
60 _srecordf (str, "%d", _str_to_int4 (get_uniq_str (reg.str, buf)));
61 code (nprocs, DATA, str);
62 } else if (reg.mode.type == CHARACTER && mode->type == REAL && mode->len == 8) {
63 NEW_RECORD (str); NEW_RECORD (buf);
64 _srecordf (str, "%g", _str_to_real8 (get_uniq_str (reg.str, buf)));
65 code (nprocs, DATA, str);
66 } else {
67 code (nprocs, DATA, reg.str);
68 }
69 if (k < repeat - 1) {
70 code (nprocs, DATA, ",\n");
71 }
72 }
73 (*items) += (int_4) repeat;
74 rc = scan (EXPECT_NONE);
75 if (TOKEN ("/")) {
76 return;
77 } else if (TOKEN (",")) {
78 code (nprocs, DATA, ",\n");
79 }
80 }
81 (void) rc;
82 }
83 }
84
85 void data_elem (char *data, char *datk, char *datn, MODE * mode, int_4 *items)
86 {
87 #define CIRCULAR\
88 {\
89 _srecordf (str, "if (%s >= %s) {\n", datk, datn);\
90 code (nprocs, BODY, str);\
91 _srecordf (str, "%s = 0;\n", datk);\
92 code (nprocs, BODY, str);\
93 code (nprocs, BODY, "}\n");\
94 }
95 //
96 EXPR reg;
97 factor (®);
98 if ((reg.idf != NO_IDENT) && reg.idf->mode.save == AUTOMATIC) {
99 ERROR (803, "variable is automatic", F_NAME (reg.idf));
100 }
101 if (reg.variant == EXPR_VAR && IS_SCALAR (reg.mode)) {
102 NEW_RECORD (str);
103 *mode = reg.idf->mode;
104 CIRCULAR;
105 if (mode->type == CHARACTER) {
106 if (mode->len == 0) {
107 _srecordf (str, "strcpy (%s, %s[%s++]);\n", reg.str, data, datk);
108 } else {
109 _srecordf (str, "bufcpy (%s, %s[%s++], %d);\n", reg.str, data, datk, mode->len);
110 }
111 } else {
112 _srecordf (str, "%s = %s[%s++];\n", reg.str, data, datk);
113 }
114 code (nprocs, BODY, str);
115 (*items)++;
116 } else if (reg.variant == EXPR_SLICE) {
117 NEW_RECORD (str);
118 *mode = reg.idf->mode;
119 CIRCULAR;
120 if (mode->type == CHARACTER) {
121 if (mode->len == 0) {
122 _srecordf (str, "strcpy (%s, %s[%s++]);\n", reg.str, data, datk);
123 } else {
124 _srecordf (str, "bufcpy (%s, %s[%s++], %d);\n", reg.str, data, datk, mode->len);
125 }
126 } else {
127 _srecordf (str, "%s = %s[%s++];\n", reg.str, data, datk);
128 }
129 code (nprocs, BODY, str);
130 (*items)++;
131 } else if (reg.variant == EXPR_VAR && IS_ROW (reg.mode)) {
132 NEW_RECORD (str); NEW_RECORD (tmpa); NEW_RECORD (tmpk);
133 IDENT *ptr;
134 *mode = reg.idf->mode;
135 mode->dim = 0;
136 _srecordf (tmpa, "_arr_%d", nloctmps++);
137 ptr = add_local (tmpa, mode->type, mode->len, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
138 ptr->alias = reg.idf;
139 _srecordf (tmpk, "_k_%d", nloctmps++);
140 add_local (tmpk, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
141 _srecordf (str, "for (%s = (%s *) %s, %s = 0; %s < ", tmpa, wtype (mode, NOARG, NOFUN), reg.str, tmpk, tmpk);
142 code (nprocs, BODY, str);
143 code_row_len (reg.idf);
144 _srecordf (str, "; %s++, %s++) {\n", tmpa, tmpk);
145 code (nprocs, BODY, str);
146 CIRCULAR;
147 if (mode->type == CHARACTER) {
148 if (mode->len == 0) {
149 _srecordf (str, "strcpy (*(%s), %s[%s++]);\n", tmpa, data, datk);
150 } else {
151 _srecordf (str, "bufcpy (*(%s), %s[%s++], %d);\n", tmpa, data, datk, mode->len);
152 }
153 } else {
154 _srecordf (str, "%s[%s] = %s[%s++];\n", reg.str, tmpk, data, datk);
155 }
156 code (nprocs, BODY, str);
157 code (nprocs, BODY, "}\n");
158 (*mode) = reg.idf->mode;
159 (*items)++;
160 } else {
161 ERROR (804, "cannot initialise", reg.str);
162 }
163 #undef CIRCULAR
164 }
165
166 void data_list (char *data, char *datk, char *datn, MODE * mode, int_4 lpatch, int_4 *nest, int_4 *items)
167 {
168 while (WITHIN) {
169 int_4 rc = scan (EXPECT_NONE);
170 if (!WITHIN) {
171 ;
172 } else if (TOKEN ("/")) {
173 return;
174 } else if (TOKEN (",")) {
175 if (*nest == 0) {
176 code (nprocs, DATA, "\n");
177 }
178 } else if (TOKEN ("(")) {
179 SAVE_POS (1);
180 // Quick lookahead.
181 int_4 loop = impl_do ();
182 // Restore.
183 RESTORE_POS (1);
184 UNSCAN;
185 rc = scan ("(");
186 // Decide.
187 if (loop) {
188 (*nest)++;
189 int_4 where = code (nprocs, BODY, NO_TEXT);
190 data_list (data, datk, datn, mode, where, nest, items);
191 } else {
192 data_elem (data, datk, datn, mode, items);
193 }
194 } else if (TOKEN (")")) {
195 // Expression closed by ')'
196 (*nest)--;
197 return;
198 } else if (rc == WORD) {
199 if (*nest == 0) {
200 data_elem (data, datk, datn, mode, items);
201 } else {
202 // Implied do-loop?
203 SAVE_POS (2);
204 rc = scan (EXPECT_NONE);
205 if (!TOKEN ("=")) {
206 // Not an implied do-loop.
207 RESTORE_POS (2);
208 UNSCAN;
209 rc = scan (EXPECT_NONE);
210 data_elem (data, datk, datn, mode, items);
211 } else {
212 // Implied do-loop!
213 NEW_RECORD (lid); NEW_RECORD (loop);
214 EXPR from, to, by;
215 MODE nmode;
216 IDENT *idf = impl_decl (prelex, &nmode);
217 if (idf->arg || idf->alias != NO_IDENT) {
218 _srecordf (lid, "*%s", C_NAME (idf));
219 } else {
220 (void) idf_full_c_name (lid, idf);
221 }
222 rc = scan (EXPECT_NONE);
223 macro_depth = 0;
224 express (&from, idf->mode.type, idf->mode.len);
225 rc = scan (",");
226 rc = scan (EXPECT_NONE);
227 macro_depth = 0;
228 express (&to, idf->mode.type, idf->mode.len);
229 rc = scan (EXPECT_NONE);
230 if (TOKEN (",")) {
231 rc = scan (EXPECT_NONE);
232 macro_depth = 0;
233 express (&by, idf->mode.type, idf->mode.len);
234 _srecordf (loop, "for (%s = %s; %s <= %s; %s += %s) {\n", lid, from.str, lid, to.str, lid, by.str);
235 rc = scan (EXPECT_NONE);
236 } else {
237 _srecordf (loop, "for (%s = %s; %s <= %s; %s++) {\n", lid, from.str, lid, to.str, lid);
238 }
239 patch (lpatch, loop);
240 if (TOKEN (")")) {
241 // Implied DO loop closed by ')'.
242 (*nest)--;
243 code (nprocs, BODY, "}; // implied DO \n");
244 } else {
245 EXPECT (805, ")");
246 }
247 return;
248 }
249 }
250 } else {
251 data_elem (data, datk, datn, mode, items);
252 }
253 }
254 }
255
256 void do_data (int_4 *nest)
257 {
258 int_4 rc, go_on = TRUE;
259 NEW_RECORD (str);
260 _srecordf (str, "if (__calls[%d].calls == 0) {\n", nprocs - 1);
261 code (nprocs, BODY, str);
262 while (go_on) {
263 int_4 items = 0, dpatch;
264 NEW_RECORD (data); NEW_RECORD (datk); NEW_RECORD (datn);
265 MODE mode;
266 _srecordf (data, "_data_l_%d", nglobtmps);
267 _srecordf (datk, "_data_k_%d", nglobtmps);
268 _srecordf (datn, "_data_n_%d", nglobtmps++);
269 add_local (datk, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
270 _srecordf (str, "%s = 0;\n", datk);
271 code (nprocs, BODY, str);
272 data_list (data, datk, datn, &mode, ERR, nest, &items);
273 if (!TOKEN ("/")) {
274 EXPECT (806, "/");
275 }
276 mode.dim = 0;
277 code (nprocs, DATA, "\n");
278 cpp_direct (nprocs, curlin, DATA);
279 _srecordf (str, "#define %s ", datn);
280 code (nprocs, DATA, str);
281 dpatch = code (nprocs, DATA, NO_TEXT);
282 code (nprocs, DATA, "\n");
283 _srecordf (str, "static %s %s[%s] = {\n", wtype (&mode, NOARG, NOFUN), data, datn);
284 code (nprocs, DATA, str);
285 items = 0;
286 const_list (&mode, &items);
287 _srecordf (str, "%d", items);
288 patch (dpatch, str);
289 code (nprocs, DATA, "\n");
290 code (nprocs, DATA, "};\n");
291 if (!TOKEN ("/")) {
292 EXPECT (807, "/");
293 }
294 rc = scan (EXPECT_NONE);
295 go_on = TOKEN (",");
296 }
297 code (nprocs, BODY, "}\n");
298 if (WITHIN) {
299 SYNTAX (808, curlex);
300 }
301 (void) rc;
302 }
303
304 void decl_data (void)
305 {
306 int_4 go_on = TRUE;
307 while (go_on) {
308 SAVE_POS (1);
309 int_4 rc = scan (EXPECT_NONE);
310 if (rc == DECLAR) {
311 skip_card (FALSE);
312 } else if (TOKEN ("implicit") && IS_NOT_ASSIGNMENT) {
313 skip_card (FALSE);
314 } else if (TOKEN ("save") && IS_NOT_ASSIGNMENT) {
315 skip_card (FALSE);
316 } else if (TOKEN ("automatic") && IS_NOT_ASSIGNMENT) {
317 skip_card (FALSE);
318 } else if (TOKEN ("parameter") && IS_NOT_ASSIGNMENT) {
319 skip_card (FALSE);
320 } else if (TOKEN ("common") && IS_NOT_ASSIGNMENT) {
321 skip_card (FALSE);
322 } else if (TOKEN ("dimension") && IS_NOT_ASSIGNMENT) {
323 skip_card (FALSE);
324 } else if (TOKEN ("equivalence") && IS_NOT_ASSIGNMENT) {
325 skip_card (FALSE);
326 } else if (TOKEN ("external") && IS_NOT_ASSIGNMENT) {
327 skip_card (FALSE);
328 } else if (TOKEN ("intrinsic") && IS_NOT_ASSIGNMENT) {
329 skip_card (FALSE);
330 } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
331 int_4 nest = 0;
332 do_data (&nest);
333 skip_card (FALSE);
334 } else if (rc == WORD && IS_MACRO_DECLARATION) {
335 skip_card (FALSE);
336 } else if (strlen (curlex) > 0) {
337 // Backspace and done.
338 RESTORE_POS (1);
339 go_on = FALSE;
340 }
341 }
342 }
343
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
