tidy.c
1 //! @file yidy.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 //! Vintage Fortran tidying tool.
25
26 #include <vif.h>
27
28 #define ALLOW_ANON (nprocs >= 0)
29
30 void tidy_executable (void);
31 void tidy_statements (LBL *, int_4);
32
33 void tidy_to_upper (void)
34 {
35 // Make uppercase, backwards.
36 if (tidy) {
37 char *p = curlex, *q = &(CUR_LIN.text[curcol - 1]);
38 while (*p != '\0') {
39 if (isspace (*q)) {
40 q--;
41 } else {
42 *q = toupper (*q);
43 q--;
44 p++;
45 }
46 }
47 }
48 }
49
50 void tidy_to_lower (void)
51 {
52 // Make lowercase, backwards.
53 if (tidy) {
54 char *p = curlex, *q = &(CUR_LIN.text[curcol - 1]);
55 while (*p != '\0') {
56 if (isspace (*q)) {
57 q--;
58 } else {
59 *q = tolower (*q);
60 q--;
61 p++;
62 }
63 }
64 }
65 }
66
67 void tidy_skip_card (void)
68 {
69 if (prelin == curlin) {
70 int_4 rc;
71 do {
72 rc = scan (EXPECT_NONE);
73 }
74 while (rc != END_OF_LINE && rc != END_OF_MODULE);
75 } else if (CUR_LIN.text == NO_TEXT) {
76 return;
77 } else if (strlen (CUR_LIN.text) >= 6 && POS(5) != ' ') {
78 int_4 rc;
79 do {
80 rc = scan (EXPECT_NONE);
81 }
82 while (rc != END_OF_LINE && rc != END_OF_MODULE);
83 }
84 }
85
86 LBL *find_relabel (char *lab)
87 {
88 int_4 k, num;
89 sscanf (lab, "%d", &num);
90 for (k = 0; k < nlabels; k++) {
91 LBL *L = &labels[k];
92 if (num == L->num) {
93 return L;
94 }
95 }
96 FATAL (3201, "no such label", curlex);
97 }
98
99 void replace_label (int_4 label)
100 {
101 NEW_RECORD (repl);
102 _srecordf (repl, "%d", label);
103 int_4 len_orig = strlen (curlex), len_repl = strlen (repl);
104 int_4 delta = len_repl - len_orig;
105 char *p = CUR_LIN.text;
106 if ((strlen (p) + delta) > RECLN) {
107 FATAL (3202, "cannot replace label", NO_TEXT);
108 }
109 NEW_RECORD (sub);
110 RECCPY (sub, p);
111 int_4 k = 0;
112 // Recalibrate current position.
113 while (curcol >= 0 && !isdigit (CUR_COL)) {
114 curcol--;
115 }
116 curcol++;
117 //
118 for (; k < curcol - len_orig; k++) {
119 p[k] = sub[k];
120 }
121 for (int_4 n = 0; repl[n] != '\0'; n++, k++) {
122 p[k] = repl[n];
123 }
124 for (int_4 n = curcol; sub[n] != '\0'; n++, k++) {
125 p[k] = sub[n];
126 }
127 for (; sub[k] != '\0'; k++) {
128 p[k] = '\0';
129 }
130 CUR_LIN.len += delta;
131 curcol += delta;
132 }
133
134 void tidy_prescan (void)
135 {
136 SAVE_POS (1);
137 int_4 rc, go_on = TRUE;
138 while (go_on) {
139 rc = scan (EXPECT_NONE);
140 if (rc == END_OF_MODULE) {
141 go_on = FALSE;
142 }
143 if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
144 go_on = FALSE;
145 } else if (rc != TEXT) {
146 tidy_to_lower ();
147 }
148 }
149 RESTORE_POS (1);
150 }
151
152 void tidy_subprogram (void)
153 {
154 SAVE_POS (1);
155 int_4 rc = scan (EXPECT_NONE);
156 if (rc == WORD) {
157 if (TOKEN ("program")) {
158 tidy_to_upper ();
159 tidy_skip_card ();
160 return;
161 } else if (TOKEN ("subroutine")) {
162 tidy_to_upper ();
163 tidy_skip_card ();
164 return;
165 } else if (TOKEN ("block")) {
166 tidy_to_upper ();
167 rc = scan (EXPECT_NONE);
168 if (TOKEN ("data")) {
169 tidy_to_upper ();
170 }
171 tidy_skip_card ();
172 return;
173 } else if (TOKEN ("function")) {
174 tidy_to_upper ();
175 tidy_skip_card ();
176 return;
177 } else {
178 if (ALLOW_ANON) {
179 tidy_skip_card ();
180 }
181 }
182 } else if (rc == DECLAR) {
183 tidy_to_upper ();
184 tidy_subprogram ();
185 }
186 RESTORE_POS (1);
187 }
188
189 static void tidy_decls (void)
190 {
191 int_4 go_on = TRUE;
192 while (go_on) {
193 SAVE_POS (1);
194 int_4 rc = scan (EXPECT_NONE);
195 if (rc == DECLAR) {
196 tidy_to_upper ();
197 tidy_skip_card ();
198 } else if (TOKEN ("implicit") && IS_NOT_ASSIGNMENT) {
199 tidy_to_upper ();
200 rc = scan (EXPECT_NONE);
201 if (rc == DECLAR) {
202 tidy_to_upper ();
203 }
204 tidy_skip_card ();
205 } else if (TOKEN ("save") && IS_NOT_ASSIGNMENT) {
206 tidy_to_upper ();
207 tidy_skip_card ();
208 } else if (TOKEN ("automatic") && IS_NOT_ASSIGNMENT) {
209 tidy_to_upper ();
210 tidy_skip_card ();
211 } else if (TOKEN ("parameter") && IS_NOT_ASSIGNMENT) {
212 tidy_to_upper ();
213 tidy_skip_card ();
214 } else if (TOKEN ("common") && IS_NOT_ASSIGNMENT) {
215 tidy_to_upper ();
216 tidy_skip_card ();
217 } else if (TOKEN ("dimension") && IS_NOT_ASSIGNMENT) {
218 tidy_to_upper ();
219 tidy_skip_card ();
220 } else if (TOKEN ("equivalence") && IS_NOT_ASSIGNMENT) {
221 tidy_to_upper ();
222 tidy_skip_card ();
223 } else if (TOKEN ("external") && IS_NOT_ASSIGNMENT) {
224 tidy_to_upper ();
225 tidy_skip_card ();
226 } else if (TOKEN ("intrinsic") && IS_NOT_ASSIGNMENT) {
227 tidy_to_upper ();
228 tidy_skip_card ();
229 } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
230 tidy_to_upper ();
231 tidy_skip_card ();
232 } else if (rc == WORD && IS_MACRO_DECLARATION) {
233 tidy_skip_card ();
234 } else if (strlen (curlex) > 0) {
235 // Backspace and done.
236 RESTORE_POS (1);
237 go_on = FALSE;
238 }
239 }
240 }
241
242 void tidy_vif_extensions(void)
243 {
244 if (TOKEN ("exit")) {
245 tidy_to_upper ();
246 tidy_skip_card ();
247 } else if (TOKEN ("break")) {
248 tidy_to_upper ();
249 tidy_skip_card ();
250 } else if (TOKEN ("cycle")) {
251 tidy_to_upper ();
252 tidy_skip_card ();
253 } else {
254 ERROR (3203, "syntax", curlex);
255 tidy_skip_card ();
256 }
257 }
258
259 void tidy_jump (void)
260 {
261 int_4 rc = scan (EXPECT_LABEL);
262 if (rc == LABEL) {
263 // GOTO label
264 LBL *L = find_relabel (curlex);
265 replace_label (L->renum);
266 tidy_skip_card ();
267 } else if (TOKEN ("(")) {
268 // GOTO (...), expr
269 rc = scan (EXPECT_LABEL);
270 while (rc == LABEL) {
271 LBL *L = find_relabel (curlex);
272 replace_label (L->renum);
273 rc = scan (EXPECT_NONE);
274 if (TOKEN (",")) {
275 rc = scan (EXPECT_LABEL);
276 }
277 };
278 CHECKPOINT (3204, ")");
279 tidy_skip_card ();
280 } else if (rc == WORD) {
281 // GOTO idf [, (...)]
282 IDENT *idf = find_local (curlex, NO_MODE);
283 if (idf == NO_IDENT ) {
284 return;
285 }
286 if (idf->mode.type != INTEGER) {
287 EXPECT (3205, "integer variable");
288 }
289 EXPR var; MODE mode;
290 var.str[0] = '\0';
291 factor_variable (&var, idf, &mode, curlex);
292 rc = scan (EXPECT_NONE);
293 if (TOKEN (",") || TOKEN ("(")) {
294 // Emit indicated labels.
295 if (TOKEN (",")) {
296 rc = scan (EXPECT_NONE);
297 }
298 CHECKPOINT (3206, "(");
299 rc = scan (EXPECT_LABEL);
300 while (rc == LABEL) {
301 LBL *L = find_relabel (curlex);
302 replace_label (L->renum);
303 rc = scan (EXPECT_LABEL);
304 if (TOKEN (",")) {
305 rc = scan (EXPECT_LABEL);
306 }
307 }
308 CHECKPOINT (3207, ")");
309 tidy_skip_card ();
310 } else {
311 // Default, emit all labels.
312 tidy_skip_card ();
313 }
314 }
315 }
316
317 void tidy_block_if (EXPR *reg, int_4 depth)
318 {
319 // Block IF.
320 int_4 rc;
321 tidy_skip_card ();
322 NEW_RECORD (str);
323 if (reg->mode.type != LOGICAL) {
324 EXPECT (3208, "logical expression");
325 }
326 tidy_statements (NO_LABEL, depth + 1);
327 while (TOKEN ("elseif")) {
328 EXPR reh;
329 rc = scan ("(");
330 rc = scan (EXPECT_NONE);
331 express (&reh, NOTYPE, NOLEN);
332 rc = scan (")");
333 rc = scan ("THEN");
334 if (reh.mode.type != LOGICAL) {
335 EXPECT (3209, "logical expression");
336 }
337 tidy_statements (NO_LABEL, depth + 1);
338 }
339 if (TOKEN ("else")) {
340 tidy_skip_card ();
341 tidy_statements (NO_LABEL, depth + 1);
342 }
343 if (TOKEN ("endif")) {
344 tidy_skip_card ();
345 } else {
346 EXPECT (3210, "endif");
347 }
348 (void) rc;
349 }
350
351 void tidy_arith_if (EXPR *reg)
352 {
353 // Arithmetic IF.
354 int_4 rc;
355 NEW_RECORD (str);
356 NEW_RECORD (tmp);
357 LBL *L;
358 // Gather the labels
359 L = find_relabel (curlex);
360 replace_label (L->renum);
361 rc = scan (",");
362 rc = scan (EXPECT_NONE);
363 if (rc != INT_NUMBER) {
364 EXPECT (3211, "label");
365 return;
366 }
367 L = find_relabel (curlex);
368 replace_label (L->renum);
369 rc = scan (",");
370 if (rc == END_OF_LINE) {
371 // CRAY FORTRAN two-branch arithmetic statement.
372 ;
373 } else {
374 // ANSI FORTRAN three-branch arithmetic statement.
375 rc = scan (EXPECT_NONE);
376 if (rc != INT_NUMBER) {
377 EXPECT (3212, "label");
378 return;
379 }
380 L = find_relabel (curlex);
381 replace_label (L->renum);
382 }
383 tidy_skip_card ();
384 }
385
386 void tidy_conditional (int_4 depth, logical_4 block_allowed)
387 {
388 int_4 rc = scan ("(");
389 EXPR reg;
390 rc = scan (EXPECT_NONE);
391 express (®, NOTYPE, NOLEN);
392 rc = scan (")");
393 rc = scan (EXPECT_NONE);
394 if (TOKEN ("then") && block_allowed) {
395 tidy_to_upper ();
396 tidy_block_if (®, depth);
397 } else if (rc == INT_NUMBER) {
398 tidy_arith_if (®);
399 } else {
400 // Logical IF.
401 NEW_RECORD (str);
402 if (reg.mode.type != LOGICAL) {
403 EXPECT (3213, "logical expression");
404 }
405 _srecordf (str, "if (%s) {\n", reg.str);
406 if (TOKEN ("if") && IS_NOT_ASSIGNMENT) {
407 tidy_to_upper ();
408 tidy_conditional (depth, FALSE);
409 } else if (TOKEN ("do") && IS_NOT_ASSIGNMENT) {
410 SYNTAX (3214, "invalid statement in logical IF");
411 } else if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
412 SYNTAX (3215, "invalid statement in logical IF");
413 } else {
414 tidy_executable ();
415 }
416 }
417 }
418
419 void tidy_do_loop (LBL * curlbl, int_4 depth)
420 {
421 LBL *L;
422 NEW_RECORD (str);
423 int_4 rc = scan (EXPECT_LABEL);
424 if (rc != LABEL) {
425 L = NO_LABEL;
426 } else {
427 L = find_relabel (curlex);
428 replace_label (L->renum);
429 if (curlbl != NO_LABEL && L->line > curlbl->line) {
430 ERROR (3216, "incorrect loop nesting", NO_TEXT);
431 return;
432 }
433 rc = scan (EXPECT_NONE);
434 }
435 if (TOKEN ("repeat")) {
436 tidy_to_upper ();
437 tidy_skip_card ();
438 tidy_statements (L, depth + 1);
439 } else if (TOKEN ("while")) {
440 tidy_to_upper ();
441 tidy_skip_card ();
442 } else {
443 tidy_skip_card ();
444 tidy_statements (L, depth + 1);
445 }
446 }
447
448 static void tidy_io_specs (char *proc)
449 {
450 int_4 rc, parm = 1;
451 // We accept that only a unit specification follows.
452 if (curret == INT_NUMBER) {
453 if (EQUAL (proc, "print")) {
454 LBL *L = find_relabel (curlex);
455 replace_label (L->renum);
456 return;
457 }
458 if (EQUAL (proc, "accept")) {
459 LBL *L = find_relabel (curlex);
460 replace_label (L->renum);
461 return;
462 }
463 }
464 if (curret == WORD) {
465 return;
466 }
467 if (TOKEN ("(")) {
468 rc = scan (EXPECT_NONE);
469 } else {
470 EXPECT (3217, "(");
471 return;
472 }
473 //
474 while (!TOKEN (")") && rc != END_OF_MODULE) {
475 // ([UNIT], [FMT] [, FMT=n | FILE=expr | FORM=str | action=str | DISP=str | END=n | ERR=n])
476 if (TOKEN ("unit") && lookahead ("=")) {
477 rc = scan ("=");
478 rc = scan (EXPECT_NONE);
479 } else if (TOKEN ("rec") && lookahead ("=")) {
480 EXPR rec;
481 rc = scan ("=");
482 rc = scan (EXPECT_NONE);
483 express (&rec, INTEGER, 4);
484 } else if (TOKEN ("file") && lookahead ("=")) {
485 EXPR reg;
486 rc = scan ("=");
487 rc = scan (EXPECT_NONE);
488 if (express (®, CHARACTER, NOLEN)) {
489 ;
490 }
491 } else if (TOKEN ("form") && lookahead ("=")) {
492 rc = scan ("=");
493 rc = scan (EXPECT_NONE);
494 if (MATCH ("formatted")) {
495 ;
496 } else if (MATCH ("unformatted")) {
497 ;
498 } else {
499 SYNTAX (3218, curlex);
500 }
501 } else if ((TOKEN ("action") || TOKEN ("access")) && lookahead ("=")) {
502 rc = scan ("=");
503 rc = scan (EXPECT_NONE);
504 if (MATCH ("read")) {
505 ;
506 } else if (MATCH ("write")) {
507 ;
508 } else if (MATCH ("readwrite")) {
509 ;
510 } else if (MATCH ("direct")) {
511 ;
512 } else {
513 SYNTAX (3219, curlex);
514 }
515 } else if ((TOKEN ("disp") || TOKEN ("status")) && lookahead ("=")) {
516 // Straight from JCL :-)
517 rc = scan ("=");
518 rc = scan (EXPECT_NONE);
519 if (MATCH ("old")) {
520 ;
521 } else if (MATCH ("new")) {
522 ;
523 } else if (MATCH ("keep")) {
524 ;
525 } else if (MATCH ("delete")) {
526 ;
527 } else if (MATCH ("unknown")) {
528 ;
529 } else {
530 SYNTAX (3220, curlex);
531 }
532 } else if ((TOKEN ("lrecl") || TOKEN ("recl")) && lookahead ("=")) {
533 EXPR rec;
534 rc = scan ("=");
535 rc = scan (EXPECT_NONE);
536 express (&rec, INTEGER, 4);
537 } else if (TOKEN ("fmt") && lookahead ("=")) {
538 rc = scan ("=");
539 rc = scan (EXPECT_NONE);
540 if (TOKEN ("*")) {
541 ;
542 } else if (rc == INT_NUMBER) {
543 ;
544 } else if (rc == WORD) {
545 EXPR fmt;
546 express (&fmt, NOTYPE, NOLEN);
547 ;
548 } else if (rc == TEXT) {
549 (void) format_str (curlex);
550 } else {
551 SYNTAX (3221, curlex);
552 }
553 } else if (TOKEN ("end") && lookahead ("=")) {
554 rc = scan ("=");
555 if ((rc = scan (EXPECT_LABEL)) == LABEL) {
556 LBL *L = find_relabel (curlex);
557 replace_label (L->renum);
558 } else {
559 EXPECT (3222, "label");
560 }
561 } else if (TOKEN ("err") && lookahead ("=")) {
562 rc = scan ("=");
563 if ((rc = scan (EXPECT_LABEL)) == LABEL) {
564 LBL *L = find_relabel (curlex);
565 replace_label (L->renum);
566 } else {
567 EXPECT (3223, "label");
568 }
569 } else if (TOKEN ("iostat") && lookahead ("=")) {
570 rc = scan ("=");
571 rc = scan (EXPECT_NONE);
572 } else {
573 if (EQUAL (proc, "encode") || EQUAL (proc, "decode")) {
574 if (parm == 1 && rc == INT_NUMBER) {
575 ;
576 } else if (parm == 2 && TOKEN ("*")) {
577 ;
578 } else if (parm == 2 && rc == WORD) {
579 EXPR fmt;
580 express (&fmt, NOTYPE, NOLEN);
581 } else if (parm == 2 && rc == TEXT) {
582 (void) format_str (curlex);
583 } else if (parm == 2 && rc == INT_NUMBER) {
584 LBL *L = find_relabel (curlex);
585 replace_label (L->renum);
586 } else if (parm == 3) {
587 ;
588 } else {
589 SYNTAX (3224, curlex);
590 }
591 } else {
592 if (parm == 1) {
593 ;
594 } else if (parm == 2 && TOKEN ("*")) {
595 ;
596 } else if (parm == 2 && rc == WORD) {
597 EXPR fmt;
598 express (&fmt, NOTYPE, NOLEN);
599 } else if (parm == 2 && rc == TEXT) {
600 (void) format_str (curlex);
601 } else if (parm == 2 && rc == INT_NUMBER) {
602 LBL *L = find_relabel (curlex);
603 replace_label (L->renum);
604 } else {
605 SYNTAX (3225, curlex);
606 }
607 }
608 }
609 // Next item.
610 parm++;
611 rc = scan (EXPECT_NONE);
612 if (TOKEN (",")) {
613 rc = scan (EXPECT_NONE);
614 } else if (TOKEN (")")) {
615 ;
616 } else {
617 SYNTAX (3226, curlex);
618 }
619 }
620 }
621 static LBL *relbl = NO_LABEL;
622
623 void tidy_executable (void)
624 {
625 int_4 rc = curret;
626 if (TOKEN ("call") && IS_NOT_ASSIGNMENT) {
627 tidy_to_upper ();
628 tidy_skip_card ();
629 } else if (TOKEN ("continue") && IS_NOT_ASSIGNMENT) {
630 tidy_to_upper ();
631 tidy_skip_card ();
632 } else if (TOKEN ("goto") && IS_NOT_ASSIGNMENT) {
633 tidy_to_upper ();
634 tidy_jump ();
635 } else if (TOKEN ("pause") && IS_NOT_ASSIGNMENT) {
636 tidy_to_upper ();
637 tidy_skip_card ();
638 } else if (TOKEN ("return") && IS_NOT_ASSIGNMENT) {
639 tidy_to_upper ();
640 tidy_skip_card ();
641 } else if (TOKEN ("entry") && IS_NOT_ASSIGNMENT) {
642 ERROR (3227, "obsolete feature", "entry");
643 tidy_skip_card ();
644 } else if (TOKEN ("stop") && IS_NOT_ASSIGNMENT) {
645 tidy_to_upper ();
646 tidy_skip_card ();
647 } else if (TOKEN ("open") && IS_NOT_ASSIGNMENT) {
648 tidy_io_specs ("open");
649 tidy_skip_card ();
650 } else if (TOKEN ("close") && IS_NOT_ASSIGNMENT) {
651 tidy_io_specs ("close");
652 tidy_skip_card ();
653 } else if (TOKEN ("endfile") && IS_NOT_ASSIGNMENT) {
654 tidy_io_specs ("endfile");
655 tidy_skip_card ();
656 } else if (TOKEN ("backspace") && IS_NOT_ASSIGNMENT) {
657 tidy_io_specs ("backspace");
658 tidy_skip_card ();
659 } else if (TOKEN ("rewind") && IS_NOT_ASSIGNMENT) {
660 tidy_io_specs ("rewind");
661 tidy_skip_card ();
662 } else if (TOKEN ("decode") && IS_NOT_ASSIGNMENT) {
663 tidy_io_specs ("decode");
664 tidy_skip_card ();
665 } else if (TOKEN ("encode") && IS_NOT_ASSIGNMENT) {
666 tidy_io_specs ("encode");
667 tidy_skip_card ();
668 } else if (TOKEN ("read") && IS_NOT_ASSIGNMENT) {
669 tidy_io_specs ("read");
670 tidy_skip_card ();
671 } else if (TOKEN ("accept") && IS_NOT_ASSIGNMENT) {
672 tidy_io_specs ("accept");
673 tidy_skip_card ();
674 } else if (TOKEN ("write") && IS_NOT_ASSIGNMENT) {
675 tidy_io_specs ("write");
676 tidy_skip_card ();
677 } else if (TOKEN ("print") && IS_NOT_ASSIGNMENT) {
678 tidy_io_specs ("print");
679 tidy_skip_card ();
680 } else if (TOKEN ("punch") && IS_NOT_ASSIGNMENT) {
681 tidy_io_specs ("punch");
682 tidy_skip_card ();
683 } else if (rc == WORD) {
684 SAVE_POS (1);
685 rc = scan (EXPECT_NONE);
686 if (rc == END_OF_LINE || rc == END_OF_MODULE) {
687 RESTORE_POS (1);
688 tidy_vif_extensions ();
689 } else {
690 UNSCAN;
691 tidy_skip_card ();
692 }
693 }
694 }
695
696 void tidy_statements (LBL * dolbl, int_4 depth)
697 {
698 int_4 rc;
699 while ((rc = scan (EXPECT_NONE)) != END_OF_MODULE) {
700 // FORTRAN statements.
701 if (rc == LABEL) {
702 NEW_RECORD (str);
703 relbl = find_relabel (curlex);
704 if (relbl == NO_LABEL) {
705 ERROR (3228, "no such label", curlex);
706 }
707 NEW_RECORD (rep);
708 _srecordf (rep, "%5d", relbl->renum);
709 for (int_4 k = 0; k < 5; k++) {
710 CUR_LIN.text[k] = rep[k];
711 }
712 rc = scan (EXPECT_NONE);
713 if (TOKEN ("continue")) {
714 tidy_to_upper ();
715 continue; // Sic!
716 }
717 }
718 if (rc == DECLAR) {
719 tidy_to_upper ();
720 tidy_skip_card ();
721 } else if (TOKEN ("assign")) {
722 tidy_to_upper ();
723 rc = scan (EXPECT_LABEL);
724 if (rc != LABEL) {
725 SYNTAX (3229, "label expected");
726 } else {
727 LBL *L = find_relabel (curlex);
728 replace_label (L->renum);
729 }
730 rc = scan (EXPECT_NONE);
731 if (TOKEN ("to")) {
732 tidy_to_upper ();
733 }
734 tidy_skip_card ();
735 } else if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
736 tidy_to_upper ();
737 if (depth != 0) {
738 SYNTAX (3230, "end must end a subprogram");
739 }
740 tidy_skip_card ();
741 return;
742 } else if (TOKEN ("elseif") && IS_NOT_ASSIGNMENT) {
743 tidy_to_upper ();
744 if (depth > 0) {
745 return;
746 } else {
747 SYNTAX (3231, "stray symbol");
748 }
749 } else if (TOKEN ("else") && IS_NOT_ASSIGNMENT) {
750 tidy_to_upper ();
751 if (depth > 0) {
752 return;
753 } else {
754 SYNTAX (3232, "stray symbol");
755 }
756 } else if (TOKEN ("endif") && IS_NOT_ASSIGNMENT) {
757 tidy_to_upper ();
758 if (depth > 0) {
759 return;
760 } else {
761 SYNTAX (3233, "stray symbol");
762 }
763 } else if (TOKEN ("until") && IS_NOT_ASSIGNMENT) {
764 tidy_to_upper ();
765 tidy_skip_card ();
766 } else if (TOKEN ("if") && IS_NOT_ASSIGNMENT) {
767 tidy_to_upper ();
768 tidy_conditional (depth, TRUE);
769 } else if (TOKEN ("do") && IS_NOT_ASSIGNMENT) {
770 tidy_to_upper ();
771 tidy_do_loop (dolbl, depth);
772 tidy_skip_card ();
773 } else if (TOKEN ("enddo") && IS_NOT_ASSIGNMENT) {
774 tidy_to_upper ();
775 if (dolbl != NO_LABEL) {
776 ERROR (3234, "misplaced end do", NO_TEXT);
777 }
778 if (depth > 0) {
779 return;
780 } else {
781 SYNTAX (3235, "stray symbol");
782 }
783 } else if (TOKEN ("format") && IS_NOT_ASSIGNMENT) {
784 tidy_to_upper ();
785 tidy_skip_card ();
786 } else {
787 tidy_executable ();
788 }
789 // Return for DO loop (ending label reached).
790 if (dolbl != NO_LABEL && relbl != NO_LABEL && dolbl->num == relbl->num) {
791 if (depth == 0) {
792 BUG ("nesting");
793 }
794 return;
795 }
796 }
797 }
798
799 void write_tidy (char *name)
800 {
801 // Object code to file.
802 FILE *obj;
803 if ((obj = fopen (name, "w")) == NULL) {
804 FATAL (3236, "cannot open for writing", name);
805 exit (EXIT_FAILURE);
806 };
807 for (int_4 k = 1; k < nftnlines; k++) {
808 fprintf (obj, "%s\n", source[k].text);
809 }
810 fclose (obj);
811 }
812
813 void tidy_source (char *modname)
814 {
815 tidy_prescan ();
816 tidy_subprogram ();
817 tidy_decls ();
818 tidy_statements (NO_LABEL, 0);
819 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
