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 code (nprocs, BODY, "\n");
178 }
179 } else if (TOKEN ("(")) {
180 SAVE_POS (1);
181 // Quick lookahead.
182 int_4 loop = impl_do ();
183 // Restore.
184 RESTORE_POS (1);
185 UNSCAN;
186 rc = scan ("(");
187 // Decide.
188 if (loop) {
189 (*nest)++;
190 int_4 where = code (nprocs, BODY, NO_TEXT);
191 data_list (data, datk, datn, mode, where, nest, items);
192 } else {
193 data_elem (data, datk, datn, mode, items);
194 }
195 } else if (TOKEN (")")) {
196 // Expression closed by ')'
197 (*nest)--;
198 return;
199 } else if (rc == WORD) {
200 if (*nest == 0) {
201 data_elem (data, datk, datn, mode, items);
202 } else {
203 // Implied do-loop?
204 SAVE_POS (2);
205 rc = scan (EXPECT_NONE);
206 if (!TOKEN ("=")) {
207 // Not an implied do-loop.
208 RESTORE_POS (2);
209 UNSCAN;
210 rc = scan (EXPECT_NONE);
211 data_elem (data, datk, datn, mode, items);
212 } else {
213 // Implied do-loop!
214 NEW_RECORD (lid); NEW_RECORD (loop);
215 EXPR from, to, by;
216 MODE nmode;
217 IDENT *idf = impl_decl (prelex, &nmode);
218 if (idf->arg || idf->alias != NO_IDENT) {
219 _srecordf (lid, "*%s", C_NAME (idf));
220 } else {
221 (void) idf_full_c_name (lid, idf);
222 }
223 rc = scan (EXPECT_NONE);
224 macro_depth = 0;
225 express (&from, idf->mode.type, idf->mode.len);
226 rc = scan (",");
227 rc = scan (EXPECT_NONE);
228 macro_depth = 0;
229 express (&to, idf->mode.type, idf->mode.len);
230 rc = scan (EXPECT_NONE);
231 if (TOKEN (",")) {
232 rc = scan (EXPECT_NONE);
233 macro_depth = 0;
234 express (&by, idf->mode.type, idf->mode.len);
235 _srecordf (loop, "for (%s = %s; %s <= %s; %s += %s) {\n", lid, from.str, lid, to.str, lid, by.str);
236 rc = scan (EXPECT_NONE);
237 } else {
238 _srecordf (loop, "for (%s = %s; %s <= %s; %s++) {\n", lid, from.str, lid, to.str, lid);
239 }
240 patch (lpatch, loop);
241 if (TOKEN (")")) {
242 // Implied DO loop closed by ')'.
243 (*nest)--;
244 code (nprocs, BODY, "}; // implied DO \n");
245 } else {
246 EXPECT (805, ")");
247 }
248 return;
249 }
250 }
251 } else {
252 data_elem (data, datk, datn, mode, items);
253 }
254 }
255 }
256
257 void do_data (int_4 *nest)
258 {
259 int_4 rc, go_on = TRUE;
260 NEW_RECORD (str);
261 _srecordf (str, "if (__calls[%d].calls == 0) {\n", nprocs - 1);
262 code (nprocs, BODY, str);
263 while (go_on) {
264 int_4 items = 0, dpatch;
265 NEW_RECORD (data); NEW_RECORD (datk); NEW_RECORD (datn);
266 MODE mode;
267 _srecordf (data, "_data_l_%d", nglobtmps);
268 _srecordf (datk, "_data_k_%d", nglobtmps);
269 _srecordf (datn, "_data_n_%d", nglobtmps++);
270 add_local (datk, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
271 _srecordf (str, "%s = 0;\n", datk);
272 code (nprocs, BODY, str);
273 data_list (data, datk, datn, &mode, ERR, nest, &items);
274 if (!TOKEN ("/")) {
275 EXPECT (806, "/");
276 }
277 mode.dim = 0;
278 code (nprocs, DATA, "\n");
279 cpp_direct (nprocs, curlin, DATA);
280 _srecordf (str, "#define %s ", datn);
281 code (nprocs, DATA, str);
282 dpatch = code (nprocs, DATA, NO_TEXT);
283 code (nprocs, DATA, "\n");
284 _srecordf (str, "static %s %s[%s] = {\n", wtype (&mode, NOARG, NOFUN), data, datn);
285 code (nprocs, DATA, str);
286 items = 0;
287 const_list (&mode, &items);
288 _srecordf (str, "%d", items);
289 patch (dpatch, str);
290 code (nprocs, DATA, "\n");
291 code (nprocs, DATA, "};\n");
292 if (!TOKEN ("/")) {
293 EXPECT (807, "/");
294 }
295 rc = scan (EXPECT_NONE);
296 go_on = TOKEN (",");
297 }
298 code (nprocs, BODY, "}\n");
299 if (WITHIN) {
300 SYNTAX (808, curlex);
301 }
302 (void) rc;
303 }
304
305 void decl_data (void)
306 {
307 int_4 go_on = TRUE;
308 while (go_on) {
309 SAVE_POS (1);
310 int_4 rc = scan (EXPECT_NONE);
311 if (rc == DECLAR) {
312 skip_card (FALSE);
313 } else if (TOKEN ("implicit") && IS_NOT_ASSIGNMENT) {
314 skip_card (FALSE);
315 } else if (TOKEN ("save") && IS_NOT_ASSIGNMENT) {
316 skip_card (FALSE);
317 } else if (TOKEN ("automatic") && IS_NOT_ASSIGNMENT) {
318 skip_card (FALSE);
319 } else if (TOKEN ("parameter") && IS_NOT_ASSIGNMENT) {
320 skip_card (FALSE);
321 } else if (TOKEN ("common") && IS_NOT_ASSIGNMENT) {
322 skip_card (FALSE);
323 } else if (TOKEN ("dimension") && IS_NOT_ASSIGNMENT) {
324 skip_card (FALSE);
325 } else if (TOKEN ("equivalence") && IS_NOT_ASSIGNMENT) {
326 skip_card (FALSE);
327 } else if (TOKEN ("external") && IS_NOT_ASSIGNMENT) {
328 skip_card (FALSE);
329 } else if (TOKEN ("intrinsic") && IS_NOT_ASSIGNMENT) {
330 skip_card (FALSE);
331 } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
332 int_4 nest = 0;
333 do_data (&nest);
334 skip_card (FALSE);
335 } else if (rc == WORD && IS_MACRO_DECLARATION) {
336 skip_card (FALSE);
337 } else if (strlen (curlex) > 0) {
338 // Backspace and done.
339 RESTORE_POS (1);
340 go_on = FALSE;
341 }
342 }
343 }
344
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
