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.
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 NEW_RECORD (rstr); NEW_RECORD (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 (1801, 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 (1802, "width");
52 _srecordf (rstr, "%%d");
53 _srecordf (wstr, "%%d");
54 } else if (width < 1) {
55 SYNTAX (1803, 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 (1804, "width");
67 _srecordf (rstr, "%%s");
68 _srecordf (wstr, "%%s");
69 } else if (width < 1) {
70 SYNTAX (1805, 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 (1806, "width, decimals, [width]");
87 }
88 if (width < 0 || digits < 0) {
89 SYNTAX (1807, 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 (1808, "width, decimals");
113 _srecordf (rstr, "%%f");
114 _srecordf (wstr, "%%f");
115 } else if (width < 1 || digits < 0) {
116 SYNTAX (1809, 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 (1810, lex);
127 rstr[0] = wstr[0] = '\0';
128 (*elems)++;
129 }
130 NEW_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 NEW_RECORD (idf); NEW_RECORD (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 NEW_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_term (int_4 N)
189 {
190 NEW_RECORD (str);
191 _srecordf (str, "FMT_TERM");
192 code (nprocs, FMT, "FMT_TEXT, ");
193 code (nprocs, FMT, str);
194 code (nprocs, FMT, ", ");
195 code (nprocs, FMT, str);
196 code (nprocs, FMT, ",\n");
197 }
198
199 static void format_text (int_4 N, char *lex)
200 {
201 NEW_RECORD (idf);
202 _srecordf (idf, "_dc_%d", code_uniq_str (lex));
203 for (int_4 k = 0; k < N; k ++) {
204 code (nprocs, FMT, "FMT_TEXT, ");
205 code (nprocs, FMT, idf);
206 code (nprocs, FMT, ", ");
207 code (nprocs, FMT, idf);
208 code (nprocs, FMT, ",\n");
209 }
210 }
211
212 void format_list (int_4 *nest, int_4 *elems)
213 {
214 #define LETTER(ch) (tolower (curlex[0]) == ch)
215 int_4 rc;
216 int_4 crd = curlin, col = curcol;
217 while (WITHIN && (rc = scan_fmt ()) != END_OF_LINE) {
218 if ((*nest) == 0 && (*elems) == 0 && !TOKEN ("(")) {
219 SYNTAX (1811, "symbol outside parentheses");
220 } else if (TOKEN (",")) {
221 ;
222 } else {
223 int_4 k, N;
224 if (rc != INT_NUMBER) {
225 N = 1;
226 } else {
227 sscanf (curlex, "%d", &N);
228 crd = curlin;
229 col = curcol;
230 rc = scan_fmt ();
231 }
232 if (LETTER ('p')) {
233 format_scale (N);
234 code (nprocs, FMT, ",\n");
235 (*elems)++;
236 curlin = crd;
237 curcol = col + 1; // continue after 'P'
238 } else if (TOKEN ("x")) {
239 format_x (N);
240 (*elems)++;
241 } else if (TOKEN (":")) {
242 format_term (N);
243 (*elems)++;
244 } else if (TOKEN ("/")) {
245 format_nl (N);
246 (*elems)++;
247 } else if (LEQUAL ("\"", curlex)) {
248 format_text (N, curlex);
249 (*elems)++;
250 } else {
251 for (k = 0; k < N; k ++) {
252 if (TOKEN ("(")) {
253 (*nest) ++;
254 format_list (nest, elems);
255 if (k < N - 1) {
256 curlin = crd;
257 curcol = col;
258 rc = scan_fmt ();
259 }
260 } else if (TOKEN (")")) {
261 (*nest) --;
262 return;
263 } else {
264 format_elem (curlex, elems);
265 }
266 }
267 }
268 }
269 crd = curlin; col = curcol;
270 }
271 #undef LETTER
272 }
273
274 char *format_str_list (char *fmt, int_4 *nest, int_4 *elems)
275 {
276 #define LETTER(ch) (tolower (fmt[0]) == ch)
277 if (fmt[0] == '(') {
278 fmt++;
279 } else {
280 EXPECT (1812, "(");
281 }
282 while (fmt[0] != ')' && fmt[0] != '\0') {
283 if (fmt[0] == ',') {
284 fmt++;
285 }
286 while (isspace (fmt[0])) {
287 fmt++;
288 }
289 int_4 N;
290 if (!isdigit (fmt[0])) {
291 N = 1;
292 } else {
293 char *end;
294 N = strtol (fmt, &end, 10);
295 fmt = end;
296 }
297 if (LETTER ('p')) {
298 format_scale (N);
299 code (nprocs, FMT, ",\n");
300 (*elems)++;
301 fmt++;
302 } else if (LETTER ('x')) {
303 format_x (N);
304 (*elems)++;
305 fmt++;
306 } else if (fmt[0] == ':') {
307 format_term (N);
308 (*elems)++;
309 fmt++;
310 } else if (fmt[0] == '/') {
311 format_nl (N);
312 (*elems)++;
313 fmt++;
314 } else if (LETTER ('h')) {
315 fmt++;
316 NEW_RECORD (str);
317 int_4 k = 0;
318 str[k++] = '"';
319 for (int_4 M = 0; M < N && fmt[0] != '\0'; M++) {
320 str[k++] = (fmt++)[0];
321 }
322 str[k++] = '"';
323 format_text (1, str);
324 (*elems)++;
325 } else if (fmt[0] == '\"') {
326 fmt++;
327 NEW_RECORD (str);
328 int_4 k = 0;
329 str[k++] = '"';
330 int_4 go_on = TRUE;
331 while (go_on) {
332 if (fmt[0] == '\0') {
333 go_on = FALSE;
334 } else if (fmt[0] == '"') {
335 if ((++fmt)[0] == '"') {
336 str[k++] = '"';
337 fmt++;
338 } else {
339 go_on = FALSE;
340 }
341 } else {
342 str[k++] = (fmt++)[0];
343 }
344 }
345 str[k++] = '"';
346 format_text (N, str);
347 (*elems)++;
348 } else if (fmt[0] == '\'') {
349 fmt++;
350 NEW_RECORD (str);
351 int_4 k = 0;
352 str[k++] = '"';
353 int_4 go_on = TRUE;
354 while (go_on) {
355 if (fmt[0] == '\0') {
356 go_on = FALSE;
357 } else if (fmt[0] == '\'') {
358 if ((++fmt)[0] == '\'') {
359 str[k++] = '\'';
360 fmt++;
361 } else {
362 go_on = FALSE;
363 }
364 } else {
365 str[k++] = (fmt++)[0];
366 }
367 }
368 str[k++] = '"';
369 format_text (N, str);
370 (*elems)++;
371 } else {
372 for (int_4 k = 0; k < N; k++) {
373 char *sav = fmt, *rtn = NO_TEXT;
374 if (fmt[0] == '(') {
375 (*nest)++;
376 rtn = format_str_list (fmt, nest, elems);
377 } else if (fmt[0] == ')') {
378 break;
379 } else if (strchr ("adefgiln", tolower (fmt[0])) == NO_TEXT) {
380 SYNTAX (1813, fmt++);
381 } else {
382 NEW_RECORD (lex);
383 char *p = lex;
384 do {
385 (p++)[0] = (fmt++)[0];
386 while (isdigit (fmt[0])) {
387 (p++)[0] = (fmt++)[0];
388 }
389 } while (fmt[0] == '.');
390 format_elem (lex, elems);
391 }
392 if (k < N - 1) {
393 fmt = sav;
394 } else if (rtn != NO_TEXT) {
395 fmt = rtn;
396 }
397 }
398 }
399 }
400 if (fmt[0] != ')') {
401 EXPECT (1814, ")");
402 return fmt;
403 } else if (*nest > 0) {
404 (*nest)--;
405 }
406 return &fmt[1];
407 #undef LETTER
408 }
409
410 void format (LBL *statlbl)
411 {
412 int_4 nest = 0, elems = 0;
413 NEW_RECORD (str);
414 if (statlbl == NO_LABEL) {
415 SYNTAX (1815, "format without label");
416 }
417 code (nprocs, FMT, "\n");
418 _srecordf (str, "static FORMAT %s[] = {\n", edit_fmt (statlbl->num));
419 code (nprocs, FMT, str);
420 format_list (&nest, &elems);
421 code (nprocs, FMT, "NULL, NULL, NULL\n");
422 code (nprocs, FMT, "};\n");
423 if (nest != 0) {
424 SYNTAX (1816, "unbalanced parentheses");
425 }
426 if (elems == 0) {
427 SYNTAX (1817, "empty format");
428 }
429 skip_card (FALSE);
430 }
431
432 int_4 format_str (char *fmt)
433 {
434 int_4 nest = 0, elems = 0;
435 int_4 lab = CUR_LIN.isn + 100000;
436 NEW_RECORD (str);
437 if (fmt[0] == '"') {
438 fmt++;
439 }
440 if (fmt[strlen (fmt) - 1] == '"') {
441 fmt[strlen (fmt) - 1] = '\0';
442 }
443 code (nprocs, FMT, "\n");
444 _srecordf (str, "static FORMAT %s[] = {\n", edit_fmt (lab));
445 code (nprocs, FMT, str);
446 (void) format_str_list (fmt, &nest, &elems);
447 code (nprocs, FMT, "NULL, NULL, NULL\n");
448 code (nprocs, FMT, "};\n");
449 if (nest != 0) {
450 SYNTAX (1818, "unbalanced parentheses");
451 }
452 if (elems == 0) {
453 SYNTAX (1819, "empty format");
454 }
455 return lab;
456 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
