format.c
1 //! @file format.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-2024 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 FORMAT statements.
25
26 #include <vif.h>
27
28 static void format_elem (char *lex, int_4 *elems)
29 {
30 if (lex == NULL || strlen (lex) == 0) {
31 return;
32 }
33 RECORD rstr, wstr;
34 int_4 width, digits, expwid;
35 if (LEQUAL ("a", lex)) {
36 if (sscanf (&lex[1], "%d", &width) != 1) {
37 _srecordf (rstr, "%%s");
38 _srecordf (wstr, "%%s");
39 } else if (width < 1) {
40 SYNTAX (1601, lex);
41 _srecordf (rstr, "%%s");
42 _srecordf (wstr, "%%s");
43 } else {
44 _srecordf (rstr, "%%%ds", width);
45 _srecordf (wstr, "%%-%ds", width);
46 }
47 code (nprocs, FMT, "FMT_CHAR");
48 (*elems)++;
49 } else if (LEQUAL ("i", lex)) {
50 if (sscanf (&lex[1], "%d", &width) != 1) {
51 EXPECT (1602, "width");
52 _srecordf (rstr, "%%d");
53 _srecordf (wstr, "%%d");
54 } else if (width < 1) {
55 SYNTAX (1603, lex);
56 _srecordf (rstr, "%%d");
57 _srecordf (wstr, "%%d");
58 } else {
59 _srecordf (rstr, "%%%dd", width);
60 _srecordf (wstr, "%%%dd", width);
61 }
62 code (nprocs, FMT, "FMT_INT");
63 (*elems)++;
64 } else if (LEQUAL ("l", lex)) {
65 if (sscanf (&lex[1], "%d", &width) != 1) {
66 EXPECT (1604, "width");
67 _srecordf (rstr, "%%s");
68 _srecordf (wstr, "%%s");
69 } else if (width < 1) {
70 SYNTAX (1605, lex);
71 _srecordf (rstr, "%%s");
72 _srecordf (wstr, "%%s");
73 } else {
74 _srecordf (rstr, "%%%ds", width);
75 _srecordf (wstr, "%%-%ds", width);
76 }
77 code (nprocs, FMT, "FMT_INT");
78 (*elems)++;
79 } else if (LEQUAL ("d", lex) || LEQUAL ("e", lex) || LEQUAL ("g", lex) || LEQUAL ("n", lex)) {
80 width = digits = expwid = 0;
81 if (sscanf (&lex[1], "%d.%d.%d", &width, &digits, &expwid) == 3) {
82 ;
83 } else if (sscanf (&lex[1], "%d.%d", &width, &digits) == 2) {
84 ;
85 } else {
86 EXPECT (1606, "width, decimals, [width]");
87 }
88 if (width < 0 || digits < 0) {
89 SYNTAX (1607, lex);
90 }
91 // Reading a REAL - specify width only!
92 _srecordf (rstr, "%%%de", width);
93 // Writing a REAL - specify all.
94 if (tolower (lex[0]) == 'n') {
95 if (islower (lex[0])) {
96 _srecordf (wstr, "%%%d.%d.%dn", width, digits, expwid);
97 } else {
98 _srecordf (wstr, "%%%d.%d.%dN", width, digits, expwid);
99 }
100 } else {
101 if (islower (lex[0])) {
102 _srecordf (wstr, "%%%d.%d.%de", width, digits, expwid);
103 } else {
104 _srecordf (wstr, "%%%d.%d.%dE", width, digits, expwid);
105 }
106 }
107 code (nprocs, FMT, "FMT_REAL");
108 (*elems)++;
109 } else if (LEQUAL ("f", lex)) {
110 sscanf (&lex[1], "%d.%d", &width, &digits);
111 if (sscanf (&lex[1], "%d.%d", &width, &digits) != 2) {
112 EXPECT (1608, "width, decimals");
113 _srecordf (rstr, "%%f");
114 _srecordf (wstr, "%%f");
115 } else if (width < 1 || digits < 0) {
116 SYNTAX (1609, lex);
117 _srecordf (rstr, "%%f");
118 _srecordf (wstr, "%%f");
119 } else {
120 _srecordf (rstr, "%%%df", width);
121 _srecordf (wstr, "%%%d.%df", width, digits);
122 }
123 code (nprocs, FMT, "FMT_REAL");
124 (*elems)++;
125 } else {
126 SYNTAX (1610, lex);
127 rstr[0] = wstr[0] = '\0';
128 (*elems)++;
129 }
130 RECORD fstr;
131 code (nprocs, FMT, ", ");
132 _srecordf (fstr, "\"%s\"", rstr);
133 code (nprocs, FMT, fstr);
134 code (nprocs, FMT, ",");
135 _srecordf (fstr, "\"%s\"", wstr);
136 code (nprocs, FMT, fstr);
137 code (nprocs, FMT, ",\n");
138 }
139
140 static void format_scale (int_4 N)
141 {
142 code (nprocs, FMT, "FMT_TEXT,");
143 code (nprocs, FMT, "\"\"");
144 code (nprocs, FMT, ",");
145 if (N == 0) {
146 code (nprocs, FMT, "\"0\"");
147 } else if (N == 1) {
148 code (nprocs, FMT, "\"1\"");
149 } else if (N == 2) {
150 code (nprocs, FMT, "\"2\"");
151 } else if (N == 3) {
152 code (nprocs, FMT, "\"3\"");
153 } else {
154 code (nprocs, FMT, "\"1\"");
155 }
156 }
157
158 static void format_x (int_4 N)
159 {
160 RECORD idf, str;
161 str[0] = '\0';
162 bufcat (str, "\"", RECLN);
163 for (int_4 k = 0; k < N && k < RECLN; k ++) {
164 bufcat (str, " ", RECLN);
165 }
166 bufcat (str, "\"", RECLN);
167 _srecordf (idf, "_dc_%d", code_uniq_str (str));
168 code (nprocs, FMT, "FMT_TEXT,");
169 code (nprocs, FMT, idf);
170 code (nprocs, FMT, ",");
171 code (nprocs, FMT, idf);
172 code (nprocs, FMT, ",\n");
173 }
174
175 static void format_nl (int_4 N)
176 {
177 RECORD str;
178 _srecordf (str, "\"\\n\"");
179 for (int_4 k = 0; k < N; k ++) {
180 code (nprocs, FMT, "FMT_TEXT,");
181 code (nprocs, FMT, str);
182 code (nprocs, FMT, ",");
183 code (nprocs, FMT, str);
184 code (nprocs, FMT, ",\n");
185 }
186 }
187
188 static void format_text (int_4 N, char *lex)
189 {
190 RECORD idf;
191 _srecordf (idf, "_dc_%d", code_uniq_str (lex));
192 for (int_4 k = 0; k < N; k ++) {
193 code (nprocs, FMT, "FMT_TEXT, ");
194 code (nprocs, FMT, idf);
195 code (nprocs, FMT, ", ");
196 code (nprocs, FMT, idf);
197 code (nprocs, FMT, ",\n");
198 }
199 }
200
201 void format_list (int_4 *nest, int_4 *elems)
202 {
203 int_4 rc;
204 int_4 crd = curlin, col = curcol;
205 while (WITHIN && (rc = scan_fmt ()) != END_OF_LINE) {
206 if ((*nest) == 0 && (*elems) == 0 && !TOKEN ("(")) {
207 SYNTAX (1611, "symbol outside parentheses");
208 } else if (TOKEN (",")) {
209 ;
210 } else {
211 int_4 k, N;
212 if (rc != INT_NUMBER) {
213 N = 1;
214 } else {
215 sscanf (curlex, "%d", &N);
216 crd = curlin;
217 col = curcol;
218 rc = scan_fmt ();
219 }
220 if (TOKEN ("p")) {
221 format_scale (N);
222 code (nprocs, FMT, ",\n");
223 (*elems)++;
224 } else if (TOKEN ("x")) {
225 format_x (N);
226 (*elems)++;
227 } else if (TOKEN ("/")) {
228 format_nl (N);
229 (*elems)++;
230 } else if (LEQUAL ("\"", curlex)) {
231 format_text (N, curlex);
232 (*elems)++;
233 } else {
234 for (k = 0; k < N; k ++) {
235 if (TOKEN ("(")) {
236 (*nest) ++;
237 format_list (nest, elems);
238 if (k < N - 1) {
239 curlin = crd;
240 curcol = col;
241 rc = scan_fmt ();
242 }
243 } else if (TOKEN (")")) {
244 (*nest) --;
245 return;
246 } else {
247 format_elem (curlex, elems);
248 }
249 }
250 }
251 }
252 crd = curlin; col = curcol;
253 }
254 }
255
256 char *format_str_list (char *fmt, int_4 *nest, int_4 *elems)
257 {
258 #define LETTER(ch) (tolower (fmt[0]) == ch)
259 if (fmt[0] == '(') {
260 fmt++;
261 } else {
262 EXPECT (1612, "(");
263 }
264 while (fmt[0] != ')' && fmt[0] != '\0') {
265 if (fmt[0] == ',') {
266 fmt++;
267 }
268 while (isspace (fmt[0])) {
269 fmt++;
270 }
271 int_4 N;
272 if (!isdigit (fmt[0])) {
273 N = 1;
274 } else {
275 char *end;
276 N = strtol (fmt, &end, 10);
277 fmt = end;
278 }
279 if (LETTER ('p')) {
280 format_scale (N);
281 code (nprocs, FMT, ",\n");
282 (*elems)++;
283 fmt++;
284 } else if (LETTER ('x')) {
285 format_x (N);
286 (*elems)++;
287 fmt++;
288 } else if (fmt[0] == '/') {
289 format_nl (N);
290 (*elems)++;
291 fmt++;
292 } else if (LETTER ('h')) {
293 fmt++;
294 RECORD str;
295 RECCLR (str);
296 int_4 k = 0;
297 str[k++] = '"';
298 for (int_4 M = 0; M < N && fmt[0] != '\0'; M++) {
299 str[k++] = (fmt++)[0];
300 }
301 str[k++] = '"';
302 format_text (1, str);
303 (*elems)++;
304 } else if (fmt[0] == '\"') {
305 fmt++;
306 RECORD str;
307 RECCLR (str);
308 int_4 k = 0;
309 str[k++] = '"';
310 int_4 go_on = TRUE;
311 while (go_on) {
312 if (fmt[0] == '\0') {
313 go_on = FALSE;
314 } else if (fmt[0] == '"') {
315 if ((++fmt)[0] == '"') {
316 str[k++] = '"';
317 fmt++;
318 } else {
319 go_on = FALSE;
320 }
321 } else {
322 str[k++] = (fmt++)[0];
323 }
324 }
325 str[k++] = '"';
326 format_text (N, str);
327 (*elems)++;
328 } else if (fmt[0] == '\'') {
329 fmt++;
330 RECORD str;
331 RECCLR (str);
332 int_4 k = 0;
333 str[k++] = '"';
334 int_4 go_on = TRUE;
335 while (go_on) {
336 if (fmt[0] == '\0') {
337 go_on = FALSE;
338 } else if (fmt[0] == '\'') {
339 if ((++fmt)[0] == '\'') {
340 str[k++] = '\'';
341 fmt++;
342 } else {
343 go_on = FALSE;
344 }
345 } else {
346 str[k++] = (fmt++)[0];
347 }
348 }
349 str[k++] = '"';
350 format_text (N, str);
351 (*elems)++;
352 } else {
353 for (int_4 k = 0; k < N; k++) {
354 char *sav = fmt, *rtn = NULL;
355 if (fmt[0] == '(') {
356 (*nest)++;
357 rtn = format_str_list (fmt, nest, elems);
358 } else if (fmt[0] == ')') {
359 break;
360 } else if (strchr ("adefgiln", tolower (fmt[0])) == NULL) {
361 SYNTAX (1613, fmt++);
362 } else {
363 RECORD lex;
364 RECCLR (lex);
365 char *p = lex;
366 do {
367 (p++)[0] = (fmt++)[0];
368 while (isdigit (fmt[0])) {
369 (p++)[0] = (fmt++)[0];
370 }
371 } while (fmt[0] == '.');
372 format_elem (lex, elems);
373 }
374 if (k < N - 1) {
375 fmt = sav;
376 } else if (rtn != NULL) {
377 fmt = rtn;
378 }
379 }
380 }
381 }
382 if (fmt[0] != ')') {
383 EXPECT (1614, ")");
384 return fmt;
385 } else if (*nest > 0) {
386 (*nest)--;
387 }
388 return &fmt[1];
389 #undef LETTER
390 }
391
392 void format (LBL *statlbl)
393 {
394 int_4 nest = 0, elems = 0;
395 RECORD str;
396 if (statlbl == NULL) {
397 SYNTAX (1615, "format without label");
398 }
399 code (nprocs, FMT, "\n");
400 _srecordf (str, "static FORMAT %s[] = {\n", edit_fmt (statlbl->num));
401 code (nprocs, FMT, str);
402 format_list (&nest, &elems);
403 code (nprocs, FMT, "NULL, NULL, NULL\n");
404 code (nprocs, FMT, "};\n");
405 if (nest != 0) {
406 SYNTAX (1616, "unbalanced parentheses");
407 }
408 if (elems == 0) {
409 SYNTAX (1617, "empty format");
410 }
411 skip_card ();
412 }
413
414 int_4 format_str (char *fmt)
415 {
416 int_4 nest = 0, elems = 0;
417 int_4 lab = source[curlin].isn + 100000;
418 RECORD str;
419 if (fmt[0] == '"') {
420 fmt++;
421 }
422 if (fmt[strlen (fmt) - 1] == '"') {
423 fmt[strlen (fmt) - 1] = '\0';
424 }
425 code (nprocs, FMT, "\n");
426 _srecordf (str, "static FORMAT %s[] = {\n", edit_fmt (lab));
427 code (nprocs, FMT, str);
428 (void) format_str_list (fmt, &nest, &elems);
429 code (nprocs, FMT, "NULL, NULL, NULL\n");
430 code (nprocs, FMT, "};\n");
431 if (nest != 0) {
432 SYNTAX (1618, "unbalanced parentheses");
433 }
434 if (elems == 0) {
435 SYNTAX (1619, "empty format");
436 }
437 return lab;
438 }
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
