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 macro_depth = 0;
332 express (&reh, NOTYPE, NOLEN);
333 rc = scan (")");
334 rc = scan ("THEN");
335 if (reh.mode.type != LOGICAL) {
336 EXPECT (3209, "logical expression");
337 }
338 tidy_statements (NO_LABEL, depth + 1);
339 }
340 if (TOKEN ("else")) {
341 tidy_skip_card ();
342 tidy_statements (NO_LABEL, depth + 1);
343 }
344 if (TOKEN ("endif")) {
345 tidy_skip_card ();
346 } else {
347 EXPECT (3210, "endif");
348 }
349 (void) rc;
350 }
351
352 void tidy_arith_if (EXPR *reg)
353 {
354 // Arithmetic IF.
355 int_4 rc;
356 NEW_RECORD (str);
357 NEW_RECORD (tmp);
358 LBL *L;
359 // Gather the labels
360 L = find_relabel (curlex);
361 replace_label (L->renum);
362 rc = scan (",");
363 rc = scan (EXPECT_NONE);
364 if (rc != INT_NUMBER) {
365 EXPECT (3211, "label");
366 return;
367 }
368 L = find_relabel (curlex);
369 replace_label (L->renum);
370 rc = scan (",");
371 if (rc == END_OF_LINE) {
372 // CRAY FORTRAN two-branch arithmetic statement.
373 ;
374 } else {
375 // ANSI FORTRAN three-branch arithmetic statement.
376 rc = scan (EXPECT_NONE);
377 if (rc != INT_NUMBER) {
378 EXPECT (3212, "label");
379 return;
380 }
381 L = find_relabel (curlex);
382 replace_label (L->renum);
383 }
384 tidy_skip_card ();
385 }
386
387 void tidy_conditional (int_4 depth, logical_4 block_allowed)
388 {
389 int_4 rc = scan ("(");
390 EXPR reg;
391 rc = scan (EXPECT_NONE);
392 macro_depth = 0;
393 express (®, NOTYPE, NOLEN);
394 rc = scan (")");
395 rc = scan (EXPECT_NONE);
396 if (TOKEN ("then") && block_allowed) {
397 tidy_to_upper ();
398 tidy_block_if (®, depth);
399 } else if (rc == INT_NUMBER) {
400 tidy_arith_if (®);
401 } else {
402 // Logical IF.
403 NEW_RECORD (str);
404 if (reg.mode.type != LOGICAL) {
405 EXPECT (3213, "logical expression");
406 }
407 _srecordf (str, "if (%s) {\n", reg.str);
408 if (TOKEN ("if") && IS_NOT_ASSIGNMENT) {
409 tidy_to_upper ();
410 tidy_conditional (depth, FALSE);
411 } else if (TOKEN ("do") && IS_NOT_ASSIGNMENT) {
412 SYNTAX (3214, "invalid statement in logical IF");
413 } else if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
414 SYNTAX (3215, "invalid statement in logical IF");
415 } else {
416 tidy_executable ();
417 }
418 }
419 }
420
421 void tidy_do_loop (LBL * curlbl, int_4 depth)
422 {
423 LBL *L;
424 NEW_RECORD (str);
425 int_4 rc = scan (EXPECT_LABEL);
426 if (rc != LABEL) {
427 L = NO_LABEL;
428 } else {
429 L = find_relabel (curlex);
430 replace_label (L->renum);
431 if (curlbl != NO_LABEL && L->line > curlbl->line) {
432 ERROR (3216, "incorrect loop nesting", NO_TEXT);
433 return;
434 }
435 rc = scan (EXPECT_NONE);
436 }
437 if (TOKEN ("repeat")) {
438 tidy_to_upper ();
439 tidy_skip_card ();
440 tidy_statements (L, depth + 1);
441 } else if (TOKEN ("while")) {
442 tidy_to_upper ();
443 tidy_skip_card ();
444 } else {
445 tidy_skip_card ();
446 tidy_statements (L, depth + 1);
447 }
448 }
449
450 static void tidy_io_specs (char *proc)
451 {
452 int_4 rc, parm = 1;
453 // We accept that only a unit specification follows.
454 if (curret == INT_NUMBER) {
455 if (EQUAL (proc, "print")) {
456 LBL *L = find_relabel (curlex);
457 replace_label (L->renum);
458 return;
459 }
460 if (EQUAL (proc, "accept")) {
461 LBL *L = find_relabel (curlex);
462 replace_label (L->renum);
463 return;
464 }
465 }
466 if (curret == WORD) {
467 return;
468 }
469 if (TOKEN ("(")) {
470 rc = scan (EXPECT_NONE);
471 } else {
472 EXPECT (3217, "(");
473 return;
474 }
475 //
476 while (!TOKEN (")") && rc != END_OF_MODULE) {
477 // ([UNIT], [FMT] [, FMT=n | FILE=expr | FORM=str | action=str | DISP=str | END=n | ERR=n])
478 if (TOKEN ("unit") && lookahead ("=")) {
479 rc = scan ("=");
480 rc = scan (EXPECT_NONE);
481 } else if (TOKEN ("rec") && lookahead ("=")) {
482 EXPR rec;
483 rc = scan ("=");
484 rc = scan (EXPECT_NONE);
485 macro_depth = 0;
486 express (&rec, INTEGER, 4);
487 } else if (TOKEN ("file") && lookahead ("=")) {
488 EXPR reg;
489 rc = scan ("=");
490 rc = scan (EXPECT_NONE);
491 macro_depth = 0;
492 if (express (®, CHARACTER, NOLEN)) {
493 ;
494 }
495 } else if (TOKEN ("form") && lookahead ("=")) {
496 rc = scan ("=");
497 rc = scan (EXPECT_NONE);
498 if (MATCH ("formatted")) {
499 ;
500 } else if (MATCH ("unformatted")) {
501 ;
502 } else {
503 SYNTAX (3218, curlex);
504 }
505 } else if ((TOKEN ("action") || TOKEN ("access")) && lookahead ("=")) {
506 rc = scan ("=");
507 rc = scan (EXPECT_NONE);
508 if (MATCH ("read")) {
509 ;
510 } else if (MATCH ("write")) {
511 ;
512 } else if (MATCH ("readwrite")) {
513 ;
514 } else if (MATCH ("direct")) {
515 ;
516 } else {
517 SYNTAX (3219, curlex);
518 }
519 } else if ((TOKEN ("disp") || TOKEN ("status")) && lookahead ("=")) {
520 // Straight from JCL :-)
521 rc = scan ("=");
522 rc = scan (EXPECT_NONE);
523 if (MATCH ("old")) {
524 ;
525 } else if (MATCH ("new")) {
526 ;
527 } else if (MATCH ("keep")) {
528 ;
529 } else if (MATCH ("delete")) {
530 ;
531 } else if (MATCH ("unknown")) {
532 ;
533 } else {
534 SYNTAX (3220, curlex);
535 }
536 } else if ((TOKEN ("lrecl") || TOKEN ("recl")) && lookahead ("=")) {
537 EXPR rec;
538 rc = scan ("=");
539 rc = scan (EXPECT_NONE);
540 macro_depth = 0;
541 express (&rec, INTEGER, 4);
542 } else if (TOKEN ("fmt") && lookahead ("=")) {
543 rc = scan ("=");
544 rc = scan (EXPECT_NONE);
545 if (TOKEN ("*")) {
546 ;
547 } else if (rc == INT_NUMBER) {
548 ;
549 } else if (rc == WORD) {
550 EXPR fmt;
551 macro_depth = 0;
552 express (&fmt, NOTYPE, NOLEN);
553 ;
554 } else if (rc == TEXT) {
555 (void) format_str (curlex);
556 } else {
557 SYNTAX (3221, curlex);
558 }
559 } else if (TOKEN ("end") && lookahead ("=")) {
560 rc = scan ("=");
561 if ((rc = scan (EXPECT_LABEL)) == LABEL) {
562 LBL *L = find_relabel (curlex);
563 replace_label (L->renum);
564 } else {
565 EXPECT (3222, "label");
566 }
567 } else if (TOKEN ("err") && lookahead ("=")) {
568 rc = scan ("=");
569 if ((rc = scan (EXPECT_LABEL)) == LABEL) {
570 LBL *L = find_relabel (curlex);
571 replace_label (L->renum);
572 } else {
573 EXPECT (3223, "label");
574 }
575 } else if (TOKEN ("iostat") && lookahead ("=")) {
576 rc = scan ("=");
577 rc = scan (EXPECT_NONE);
578 } else {
579 if (EQUAL (proc, "encode") || EQUAL (proc, "decode")) {
580 if (parm == 1 && rc == INT_NUMBER) {
581 ;
582 } else if (parm == 2 && TOKEN ("*")) {
583 ;
584 } else if (parm == 2 && rc == WORD) {
585 EXPR fmt;
586 macro_depth = 0;
587 express (&fmt, NOTYPE, NOLEN);
588 } else if (parm == 2 && rc == TEXT) {
589 (void) format_str (curlex);
590 } else if (parm == 2 && rc == INT_NUMBER) {
591 LBL *L = find_relabel (curlex);
592 replace_label (L->renum);
593 } else if (parm == 3) {
594 ;
595 } else {
596 SYNTAX (3224, curlex);
597 }
598 } else {
599 if (parm == 1) {
600 ;
601 } else if (parm == 2 && TOKEN ("*")) {
602 ;
603 } else if (parm == 2 && rc == WORD) {
604 EXPR fmt;
605 macro_depth = 0;
606 express (&fmt, NOTYPE, NOLEN);
607 } else if (parm == 2 && rc == TEXT) {
608 (void) format_str (curlex);
609 } else if (parm == 2 && rc == INT_NUMBER) {
610 LBL *L = find_relabel (curlex);
611 replace_label (L->renum);
612 } else {
613 SYNTAX (3225, curlex);
614 }
615 }
616 }
617 // Next item.
618 parm++;
619 rc = scan (EXPECT_NONE);
620 if (TOKEN (",")) {
621 rc = scan (EXPECT_NONE);
622 } else if (TOKEN (")")) {
623 ;
624 } else {
625 SYNTAX (3226, curlex);
626 }
627 }
628 }
629 static LBL *relbl = NO_LABEL;
630
631 void tidy_executable (void)
632 {
633 int_4 rc = curret;
634 if (TOKEN ("call") && IS_NOT_ASSIGNMENT) {
635 tidy_to_upper ();
636 tidy_skip_card ();
637 } else if (TOKEN ("continue") && IS_NOT_ASSIGNMENT) {
638 tidy_to_upper ();
639 tidy_skip_card ();
640 } else if (TOKEN ("goto") && IS_NOT_ASSIGNMENT) {
641 tidy_to_upper ();
642 tidy_jump ();
643 } else if (TOKEN ("pause") && IS_NOT_ASSIGNMENT) {
644 tidy_to_upper ();
645 tidy_skip_card ();
646 } else if (TOKEN ("return") && IS_NOT_ASSIGNMENT) {
647 tidy_to_upper ();
648 tidy_skip_card ();
649 } else if (TOKEN ("entry") && IS_NOT_ASSIGNMENT) {
650 ERROR (3227, "obsolete feature", "entry");
651 tidy_skip_card ();
652 } else if (TOKEN ("stop") && IS_NOT_ASSIGNMENT) {
653 tidy_to_upper ();
654 tidy_skip_card ();
655 } else if (TOKEN ("open") && IS_NOT_ASSIGNMENT) {
656 tidy_io_specs ("open");
657 tidy_skip_card ();
658 } else if (TOKEN ("close") && IS_NOT_ASSIGNMENT) {
659 tidy_io_specs ("close");
660 tidy_skip_card ();
661 } else if (TOKEN ("endfile") && IS_NOT_ASSIGNMENT) {
662 tidy_io_specs ("endfile");
663 tidy_skip_card ();
664 } else if (TOKEN ("backspace") && IS_NOT_ASSIGNMENT) {
665 tidy_io_specs ("backspace");
666 tidy_skip_card ();
667 } else if (TOKEN ("rewind") && IS_NOT_ASSIGNMENT) {
668 tidy_io_specs ("rewind");
669 tidy_skip_card ();
670 } else if (TOKEN ("decode") && IS_NOT_ASSIGNMENT) {
671 tidy_io_specs ("decode");
672 tidy_skip_card ();
673 } else if (TOKEN ("encode") && IS_NOT_ASSIGNMENT) {
674 tidy_io_specs ("encode");
675 tidy_skip_card ();
676 } else if (TOKEN ("read") && IS_NOT_ASSIGNMENT) {
677 tidy_io_specs ("read");
678 tidy_skip_card ();
679 } else if (TOKEN ("accept") && IS_NOT_ASSIGNMENT) {
680 tidy_io_specs ("accept");
681 tidy_skip_card ();
682 } else if (TOKEN ("write") && IS_NOT_ASSIGNMENT) {
683 tidy_io_specs ("write");
684 tidy_skip_card ();
685 } else if (TOKEN ("print") && IS_NOT_ASSIGNMENT) {
686 tidy_io_specs ("print");
687 tidy_skip_card ();
688 } else if (TOKEN ("punch") && IS_NOT_ASSIGNMENT) {
689 tidy_io_specs ("punch");
690 tidy_skip_card ();
691 } else if (rc == WORD) {
692 SAVE_POS (1);
693 rc = scan (EXPECT_NONE);
694 if (rc == END_OF_LINE || rc == END_OF_MODULE) {
695 RESTORE_POS (1);
696 tidy_vif_extensions ();
697 } else {
698 UNSCAN;
699 tidy_skip_card ();
700 }
701 }
702 }
703
704 void tidy_statements (LBL * dolbl, int_4 depth)
705 {
706 int_4 rc;
707 while ((rc = scan (EXPECT_NONE)) != END_OF_MODULE) {
708 // FORTRAN statements.
709 if (rc == LABEL) {
710 NEW_RECORD (str);
711 relbl = find_relabel (curlex);
712 if (relbl == NO_LABEL) {
713 ERROR (3228, "no such label", curlex);
714 }
715 NEW_RECORD (rep);
716 _srecordf (rep, "%5d", relbl->renum);
717 for (int_4 k = 0; k < 5; k++) {
718 CUR_LIN.text[k] = rep[k];
719 }
720 rc = scan (EXPECT_NONE);
721 if (TOKEN ("continue")) {
722 tidy_to_upper ();
723 continue; // Sic!
724 }
725 }
726 if (rc == DECLAR) {
727 tidy_to_upper ();
728 tidy_skip_card ();
729 } else if (TOKEN ("assign")) {
730 tidy_to_upper ();
731 rc = scan (EXPECT_LABEL);
732 if (rc != LABEL) {
733 SYNTAX (3229, "label expected");
734 } else {
735 LBL *L = find_relabel (curlex);
736 replace_label (L->renum);
737 }
738 rc = scan (EXPECT_NONE);
739 if (TOKEN ("to")) {
740 tidy_to_upper ();
741 }
742 tidy_skip_card ();
743 } else if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
744 tidy_to_upper ();
745 if (depth != 0) {
746 SYNTAX (3230, "end must end a subprogram");
747 }
748 tidy_skip_card ();
749 return;
750 } else if (TOKEN ("elseif") && IS_NOT_ASSIGNMENT) {
751 tidy_to_upper ();
752 if (depth > 0) {
753 return;
754 } else {
755 SYNTAX (3231, "stray symbol");
756 }
757 } else if (TOKEN ("else") && IS_NOT_ASSIGNMENT) {
758 tidy_to_upper ();
759 if (depth > 0) {
760 return;
761 } else {
762 SYNTAX (3232, "stray symbol");
763 }
764 } else if (TOKEN ("endif") && IS_NOT_ASSIGNMENT) {
765 tidy_to_upper ();
766 if (depth > 0) {
767 return;
768 } else {
769 SYNTAX (3233, "stray symbol");
770 }
771 } else if (TOKEN ("until") && IS_NOT_ASSIGNMENT) {
772 tidy_to_upper ();
773 tidy_skip_card ();
774 } else if (TOKEN ("if") && IS_NOT_ASSIGNMENT) {
775 tidy_to_upper ();
776 tidy_conditional (depth, TRUE);
777 } else if (TOKEN ("do") && IS_NOT_ASSIGNMENT) {
778 tidy_to_upper ();
779 tidy_do_loop (dolbl, depth);
780 tidy_skip_card ();
781 } else if (TOKEN ("enddo") && IS_NOT_ASSIGNMENT) {
782 tidy_to_upper ();
783 if (dolbl != NO_LABEL) {
784 ERROR (3234, "misplaced end do", NO_TEXT);
785 }
786 if (depth > 0) {
787 return;
788 } else {
789 SYNTAX (3235, "stray symbol");
790 }
791 } else if (TOKEN ("format") && IS_NOT_ASSIGNMENT) {
792 tidy_to_upper ();
793 tidy_skip_card ();
794 } else {
795 tidy_executable ();
796 }
797 // Return for DO loop (ending label reached).
798 if (dolbl != NO_LABEL && relbl != NO_LABEL && dolbl->num == relbl->num) {
799 if (depth == 0) {
800 BUG ("nesting");
801 }
802 return;
803 }
804 }
805 }
806
807 void write_tidy (char *name)
808 {
809 // Object code to file.
810 FILE *obj;
811 if ((obj = fopen (name, "w")) == NULL) {
812 FATAL (3236, "cannot open for writing", name);
813 exit (EXIT_FAILURE);
814 };
815 for (int_4 k = 1; k < nftnlines; k++) {
816 fprintf (obj, "%s\n", source[k].text);
817 }
818 fclose (obj);
819 }
820
821 void tidy_source (char *modname)
822 {
823 tidy_prescan ();
824 tidy_subprogram ();
825 tidy_decls ();
826 tidy_statements (NO_LABEL, 0);
827 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
