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