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", C_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 express (&from, idf->mode.type, idf->mode.len);
224 rc = scan (",");
225 rc = scan (EXPECT_NONE);
226 express (&to, idf->mode.type, idf->mode.len);
227 rc = scan (EXPECT_NONE);
228 if (TOKEN (",")) {
229 rc = scan (EXPECT_NONE);
230 express (&by, idf->mode.type, idf->mode.len);
231 _srecordf (loop, "for (%s = %s; %s <= %s; %s += %s) {\n", lid, from.str, lid, to.str, lid, by.str);
232 rc = scan (EXPECT_NONE);
233 } else {
234 _srecordf (loop, "for (%s = %s; %s <= %s; %s++) {\n", lid, from.str, lid, to.str, lid);
235 }
236 patch (lpatch, loop);
237 if (TOKEN (")")) {
238 // Implied DO loop closed by ')'.
239 (*nest)--;
240 code (nprocs, BODY, "}; // implied DO \n");
241 } else {
242 EXPECT (805, ")");
243 }
244 return;
245 }
246 }
247 } else {
248 data_elem (data, datk, datn, mode, items);
249 }
250 }
251 }
252
253 void do_data (int_4 *nest)
254 {
255 int_4 rc, go_on = TRUE;
256 NEW_RECORD (str);
257 _srecordf (str, "if (__calls[%d].calls == 0) {\n", nprocs - 1);
258 code (nprocs, BODY, str);
259 while (go_on) {
260 int_4 items = 0, dpatch;
261 NEW_RECORD (data); NEW_RECORD (datk); NEW_RECORD (datn);
262 MODE mode;
263 _srecordf (data, "_data_l_%d", nglobtmps);
264 _srecordf (datk, "_data_k_%d", nglobtmps);
265 _srecordf (datn, "_data_n_%d", nglobtmps++);
266 add_local (datk, INTEGER, 4, NOUNIQ, NOPATCH, NOARG, LOCAL, TEMP);
267 _srecordf (str, "%s = 0;\n", datk);
268 code (nprocs, BODY, str);
269 data_list (data, datk, datn, &mode, ERR, nest, &items);
270 if (!TOKEN ("/")) {
271 EXPECT (806, "/");
272 }
273 mode.dim = 0;
274 code (nprocs, DATA, "\n");
275 cpp_direct (nprocs, curlin, DATA);
276 _srecordf (str, "#define %s ", datn);
277 code (nprocs, DATA, str);
278 dpatch = code (nprocs, DATA, NO_TEXT);
279 code (nprocs, DATA, "\n");
280 _srecordf (str, "static %s %s[%s] = {\n", wtype (&mode, NOARG, NOFUN), data, datn);
281 code (nprocs, DATA, str);
282 items = 0;
283 const_list (&mode, &items);
284 _srecordf (str, "%d", items);
285 patch (dpatch, str);
286 code (nprocs, DATA, "\n");
287 code (nprocs, DATA, "};\n");
288 if (!TOKEN ("/")) {
289 EXPECT (807, "/");
290 }
291 rc = scan (EXPECT_NONE);
292 go_on = TOKEN (",");
293 }
294 code (nprocs, BODY, "}\n");
295 if (WITHIN) {
296 SYNTAX (808, curlex);
297 }
298 (void) rc;
299 }
300
301 void decl_data (void)
302 {
303 int_4 go_on = TRUE;
304 while (go_on) {
305 SAVE_POS (1);
306 int_4 rc = scan (EXPECT_NONE);
307 if (rc == DECLAR) {
308 skip_card (FALSE);
309 } else if (TOKEN ("implicit") && IS_NOT_ASSIGNMENT) {
310 skip_card (FALSE);
311 } else if (TOKEN ("save") && IS_NOT_ASSIGNMENT) {
312 skip_card (FALSE);
313 } else if (TOKEN ("automatic") && IS_NOT_ASSIGNMENT) {
314 skip_card (FALSE);
315 } else if (TOKEN ("parameter") && IS_NOT_ASSIGNMENT) {
316 skip_card (FALSE);
317 } else if (TOKEN ("common") && IS_NOT_ASSIGNMENT) {
318 skip_card (FALSE);
319 } else if (TOKEN ("dimension") && IS_NOT_ASSIGNMENT) {
320 skip_card (FALSE);
321 } else if (TOKEN ("equivalence") && IS_NOT_ASSIGNMENT) {
322 skip_card (FALSE);
323 } else if (TOKEN ("external") && IS_NOT_ASSIGNMENT) {
324 skip_card (FALSE);
325 } else if (TOKEN ("intrinsic") && IS_NOT_ASSIGNMENT) {
326 skip_card (FALSE);
327 } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
328 int_4 nest = 0;
329 do_data (&nest);
330 skip_card (FALSE);
331 } else if (rc == WORD && IS_MACRO_DECLARATION) {
332 skip_card (FALSE);
333 } else if (strlen (curlex) > 0) {
334 // Backspace and done.
335 RESTORE_POS (1);
336 go_on = FALSE;
337 }
338 }
339 }
340
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
