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-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 FORMAT statements.
25
26 #include <vif.h>
27
28 static void format_elem (char *lex, int_4 *elems)
29 {
30 if (lex == NO_TEXT || 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 (curlex[0] == 'p') {
221 format_scale (N);
222 code (nprocs, FMT, ",\n");
223 (*elems)++;
224 if (_EXPCHAR (curlex[1])) {
225 format_elem (&curlex[1], elems);
226 }
227 } else if (TOKEN ("x")) {
228 format_x (N);
229 (*elems)++;
230 } else if (TOKEN ("/")) {
231 format_nl (N);
232 (*elems)++;
233 } else if (LEQUAL ("\"", curlex)) {
234 format_text (N, curlex);
235 (*elems)++;
236 } else {
237 for (k = 0; k < N; k ++) {
238 if (TOKEN ("(")) {
239 (*nest) ++;
240 format_list (nest, elems);
241 if (k < N - 1) {
242 curlin = crd;
243 curcol = col;
244 rc = scan_fmt ();
245 }
246 } else if (TOKEN (")")) {
247 (*nest) --;
248 return;
249 } else {
250 format_elem (curlex, elems);
251 }
252 }
253 }
254 }
255 crd = curlin; col = curcol;
256 }
257 }
258
259 char *format_str_list (char *fmt, int_4 *nest, int_4 *elems)
260 {
261 #define LETTER(ch) (tolower (fmt[0]) == ch)
262 if (fmt[0] == '(') {
263 fmt++;
264 } else {
265 EXPECT (1612, "(");
266 }
267 while (fmt[0] != ')' && fmt[0] != '\0') {
268 if (fmt[0] == ',') {
269 fmt++;
270 }
271 while (isspace (fmt[0])) {
272 fmt++;
273 }
274 int_4 N;
275 if (!isdigit (fmt[0])) {
276 N = 1;
277 } else {
278 char *end;
279 N = strtol (fmt, &end, 10);
280 fmt = end;
281 }
282 if (LETTER ('p')) {
283 format_scale (N);
284 code (nprocs, FMT, ",\n");
285 (*elems)++;
286 fmt++;
287 if (_EXPCHAR (tolower (fmt[0]))) {
288 format_elem (fmt, elems);
289 }
290 } else if (LETTER ('x')) {
291 format_x (N);
292 (*elems)++;
293 fmt++;
294 } else if (fmt[0] == '/') {
295 format_nl (N);
296 (*elems)++;
297 fmt++;
298 } else if (LETTER ('h')) {
299 fmt++;
300 RECORD str;
301 RECCLR (str);
302 int_4 k = 0;
303 str[k++] = '"';
304 for (int_4 M = 0; M < N && fmt[0] != '\0'; M++) {
305 str[k++] = (fmt++)[0];
306 }
307 str[k++] = '"';
308 format_text (1, str);
309 (*elems)++;
310 } else if (fmt[0] == '\"') {
311 fmt++;
312 RECORD str;
313 RECCLR (str);
314 int_4 k = 0;
315 str[k++] = '"';
316 int_4 go_on = TRUE;
317 while (go_on) {
318 if (fmt[0] == '\0') {
319 go_on = FALSE;
320 } else if (fmt[0] == '"') {
321 if ((++fmt)[0] == '"') {
322 str[k++] = '"';
323 fmt++;
324 } else {
325 go_on = FALSE;
326 }
327 } else {
328 str[k++] = (fmt++)[0];
329 }
330 }
331 str[k++] = '"';
332 format_text (N, str);
333 (*elems)++;
334 } else if (fmt[0] == '\'') {
335 fmt++;
336 RECORD str;
337 RECCLR (str);
338 int_4 k = 0;
339 str[k++] = '"';
340 int_4 go_on = TRUE;
341 while (go_on) {
342 if (fmt[0] == '\0') {
343 go_on = FALSE;
344 } else if (fmt[0] == '\'') {
345 if ((++fmt)[0] == '\'') {
346 str[k++] = '\'';
347 fmt++;
348 } else {
349 go_on = FALSE;
350 }
351 } else {
352 str[k++] = (fmt++)[0];
353 }
354 }
355 str[k++] = '"';
356 format_text (N, str);
357 (*elems)++;
358 } else {
359 for (int_4 k = 0; k < N; k++) {
360 char *sav = fmt, *rtn = NO_TEXT;
361 if (fmt[0] == '(') {
362 (*nest)++;
363 rtn = format_str_list (fmt, nest, elems);
364 } else if (fmt[0] == ')') {
365 break;
366 } else if (strchr ("adefgiln", tolower (fmt[0])) == NO_TEXT) {
367 SYNTAX (1613, fmt++);
368 } else {
369 RECORD lex;
370 RECCLR (lex);
371 char *p = lex;
372 do {
373 (p++)[0] = (fmt++)[0];
374 while (isdigit (fmt[0])) {
375 (p++)[0] = (fmt++)[0];
376 }
377 } while (fmt[0] == '.');
378 format_elem (lex, elems);
379 }
380 if (k < N - 1) {
381 fmt = sav;
382 } else if (rtn != NO_TEXT) {
383 fmt = rtn;
384 }
385 }
386 }
387 }
388 if (fmt[0] != ')') {
389 EXPECT (1614, ")");
390 return fmt;
391 } else if (*nest > 0) {
392 (*nest)--;
393 }
394 return &fmt[1];
395 #undef LETTER
396 }
397
398 void format (LBL *statlbl)
399 {
400 int_4 nest = 0, elems = 0;
401 RECORD str;
402 if (statlbl == NO_LABEL) {
403 SYNTAX (1615, "format without label");
404 }
405 code (nprocs, FMT, "\n");
406 _srecordf (str, "static FORMAT %s[] = {\n", edit_fmt (statlbl->num));
407 code (nprocs, FMT, str);
408 format_list (&nest, &elems);
409 code (nprocs, FMT, "NULL, NULL, NULL\n");
410 code (nprocs, FMT, "};\n");
411 if (nest != 0) {
412 SYNTAX (1616, "unbalanced parentheses");
413 }
414 if (elems == 0) {
415 SYNTAX (1617, "empty format");
416 }
417 skip_card (FALSE);
418 }
419
420 int_4 format_str (char *fmt)
421 {
422 int_4 nest = 0, elems = 0;
423 int_4 lab = CUR_LIN.isn + 100000;
424 RECORD str;
425 if (fmt[0] == '"') {
426 fmt++;
427 }
428 if (fmt[strlen (fmt) - 1] == '"') {
429 fmt[strlen (fmt) - 1] = '\0';
430 }
431 code (nprocs, FMT, "\n");
432 _srecordf (str, "static FORMAT %s[] = {\n", edit_fmt (lab));
433 code (nprocs, FMT, str);
434 (void) format_str_list (fmt, &nest, &elems);
435 code (nprocs, FMT, "NULL, NULL, NULL\n");
436 code (nprocs, FMT, "};\n");
437 if (nest != 0) {
438 SYNTAX (1618, "unbalanced parentheses");
439 }
440 if (elems == 0) {
441 SYNTAX (1619, "empty format");
442 }
443 return lab;
444 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
