renum.c
1 //! @file renum.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 statement renumbering tool.
25 //
26 // I wrote a first version in Pascal, in the 1980's.
27 // That explains the unity lower bounds in this code.
28
29 #include <vif.h>
30
31 #define MODLEN 5000 // Max size of a subprogram
32
33 typedef RECORD DECK[MODLEN];
34
35 static RECORD name;
36
37 static int_4 routines, errors;
38 static int_4 old_label[MODLEN];
39
40 static void renum_jcl (RECORD *b, int_4 *flin, int_4 *size)
41 {
42 if (b[*flin - 1][0] == '/' && b[*flin - 1][1] == '*') {
43 return;
44 } else if (b[*flin - 1][0] == '/' && b[*flin - 1][1] == '/') {
45 RECORD step, snam, oper, parm;
46 int_4 k = 0, l = 2, N = 0, fn;
47 // Parse step and snam field.
48 RECCLR (step);
49 RECCLR (snam);
50 RECCLR (oper);
51 RECCLR (parm);
52 while (N <= RECLN && (isalpha (b[*flin - 1][l]) || (strlen (snam) > 0 ? isdigit (b[*flin - 1][l]) : FALSE))) {
53 snam[k++] = tolower (b[*flin - 1][l]);
54 l++;
55 N++;
56 }
57 if (b[*flin - 1][l] == '.') {
58 strcpy (step, snam);
59 l++;
60 k = 0;
61 N = 0;
62 while (N <= RECLN && (isalpha (b[*flin - 1][l]) || (strlen (snam) > 0 ? isdigit (b[*flin - 1][l]) : FALSE))) {
63 snam[k++] = tolower (b[*flin - 1][l]);
64 l++;
65 N++;
66 }
67 }
68 // Parse operation field.
69 while (isspace (b[*flin - 1][l])) {
70 l++;
71 }
72 k = 0;
73 while (N <= RECLN && (isalpha (b[*flin - 1][l]) || (strlen (oper) > 0 ? isdigit (b[*flin - 1][l]) : FALSE))) {
74 oper[k++] = tolower (b[*flin - 1][l]);
75 l++;
76 N++;
77 }
78 // Parse parameter field.
79 while (isspace (b[*flin - 1][l])) {
80 l++;
81 }
82 k = 0;
83 while (N <= RECLN && b[*flin - 1][l] != '\0' && isprint (b[*flin - 1][l])) {
84 parm[k++] = b[*flin - 1][l];
85 l++;
86 N++;
87 }
88 // Match FT..F001.
89 if (sscanf(snam, "ft%02df001", &fn) == 1 && LEQUAL ("dd", oper)) {
90 if (LEQUAL ("*", parm)) {
91 while (*flin <= *size && !LEQUAL ("/*", b[*flin - 1])) {
92 (*flin)++;
93 }
94 }
95 }
96 }
97 }
98
99 static int_4 P_eof (FILE * f)
100 {
101 if (feof (f)) {
102 return TRUE;
103 }
104 int_4 ch = getc (f);
105 if (ch == EOF) {
106 return TRUE;
107 }
108 ungetc (ch, f);
109 return FALSE;
110 }
111
112 static int_4 P_eoln (FILE *f)
113 {
114 int_4 ch = getc (f);
115 if (ch == EOF) {
116 return TRUE;
117 }
118 ungetc (ch, f);
119 return (ch == '\n');
120 }
121
122 static void write_sym (char *s)
123 {
124 for (int_4 i = 1; i <= RECLN && s[i - 1] != ' '; i++) {
125 putchar (s[i - 1]);
126 }
127 putchar ('\n');
128 }
129
130 static void cram_symbol (char *b, char *s)
131 {
132 RECCLR (s);
133 for (int_4 i = 0, j = 0; i <= RECLN; i++) {
134 if (b[i] != ' ') {
135 s[j++] = b[i];
136 }
137 }
138 }
139
140 static int_4 blank_card (char *a)
141 {
142 int_4 eq = TRUE;
143 for (int_4 i = 0; i <= RECLN; i++) {
144 eq = (eq && a[i] == ' ');
145 }
146 return eq;
147 }
148
149 static void fill_buffer (FILE **f, RECORD *fsrc, int_4 *i)
150 {
151 int_4 j, kontinue = TRUE;
152 RECORD current_card, s;
153 RECCLR (s);
154 *i = 0;
155 while (kontinue) {
156 if (P_eof (*f) || *i >= MODLEN) {
157 continue;
158 }
159 memset (current_card, ' ', RECLN);
160 j = 0;
161 while (!P_eoln (*f) && j <= RECLN) {
162 j++;
163 current_card[j - 1] = getc (*f);
164 if (current_card[j - 1] == '\n') {
165 current_card[j - 1] = ' ';
166 }
167 }
168 cram_symbol (current_card, s);
169 kontinue = !EQUAL (s, "end");
170 if (!blank_card (current_card)) {
171 (*i)++;
172 for (j = 0; j <= RECLN; j++) {
173 fsrc[*i - 1][j] = current_card[j];
174 }
175 }
176 (void) fscanf (*f, "%*[^\n]");
177 getc (*f);
178 if (P_eof (*f)) {
179 kontinue = FALSE;
180 }
181 }
182 }
183
184 static void write_buffer (FILE **f, RECORD *fsrc, int_4 size)
185 {
186 int_4 i, j, last;
187
188 if (routines > 1) {
189 putc ('\n', *f);
190 }
191 for (i = 0; i < size; i++) {
192 last = strlen (fsrc[i]);
193 while (last > 0 && fsrc[i][last - 1] == ' ') {
194 last--;
195 }
196 for (j = 0; j < last; j++) {
197 putc (fsrc[i][j], *f);
198 }
199 putc ('\n', *f);
200 }
201 fflush (*f);
202 }
203
204 static int_4 isidchar (char c)
205 {
206 return (isalpha (c) || c == '$');
207 }
208
209 static int_4 isspecial (char c)
210 {
211 return (((!isidchar (c)) & (!isdigit (c))) && c != ' ');
212 }
213
214 static int_4 read_label (RECORD *b, int_4 *flin, int_4 *size)
215 {
216 int_4 signif, labval, column, digit;
217
218 if (IS_JCL ((b[*flin - 1][0]))) {
219 renum_jcl (b, flin, size);
220 return 0;
221 } else if (IS_COMMENT ((b[*flin - 1][0]))) {
222 return 0;
223 } else {
224 signif = 1;
225 column = 5;
226 labval = 0;
227 while (column != 0) {
228 if (isdigit (b[*flin - 1][column - 1])) {
229 digit = b[*flin - 1][column - 1] - '0';
230 labval += signif * digit;
231 signif *= 10;
232 }
233 column--;
234 }
235 return labval;
236 }
237 }
238
239 static void write_label (RECORD *b, int_4 flin, int_4 lab)
240 {
241 int_4 i, digit;
242 int_4 column = 5, labval = lab;
243
244 do {
245 i = labval / 10;
246 digit = labval - i * 10;
247 labval = i;
248 b[flin - 1][column - 1] = (char) (digit + '0');
249 column--;
250 } while (labval != 0);
251 while (column != 0) {
252 b[flin - 1][column - 1] = ' ';
253 column--;
254 }
255 }
256
257 static void replace_label (RECORD *b, int_4 *flin, int_4 *first, int_4 *last, int_4 lab)
258 {
259 int_4 i;
260 int_4 j = 0;
261 int_4 k, digit, labval, FORLIM;
262
263 FORLIM = RECLN - *last;
264 for (i = 1; i <= FORLIM; i++) {
265 b[*flin - 1][*first + i - 1] = b[*flin - 1][*last + i - 2];
266 }
267 *last = *first + 1;
268 labval = lab;
269 do {
270 j++;
271 i = labval / 10;
272 digit = labval - i * 10;
273 labval = i;
274 b[*flin - 1][*first - 1] = (char) (digit + '0');
275 if (labval != 0) {
276 FORLIM = *first;
277 for (k = RECLN - 1; k >= FORLIM; k--) {
278 b[*flin - 1][k] = b[*flin - 1][k - 1];
279 }
280 (*last)++;
281 }
282 } while (labval != 0);
283 }
284
285 static void advance (RECORD *b, int_4 *eol, int_4 *cont, int_4 *flin, int_4 *column, int_4 *size)
286 {
287 if (*column != RECLN) {
288 (*column)++;
289 return;
290 }
291 do {
292 if (*flin == *size) {
293 *cont = FALSE;
294 } else {
295 (*flin)++;
296 }
297 } while (IS_COMMENT ((*b[*flin - 1])) && *cont);
298 if (!*cont) {
299 *column = 1;
300 *eol = TRUE;
301 return;
302 }
303 if (b[*flin - 1][5] != ' ') {
304 *column = 7;
305 return;
306 }
307 *column = 1;
308 *eol = TRUE;
309 *cont = FALSE;
310 }
311
312 static void scan_symbol (RECORD *b, char *s, int_4 *eol, int_4 *flin, int_4 *column, int_4 *first, int_4 *size)
313 {
314 int_4 i, cont = TRUE;
315 *eol = FALSE;
316 memset (s, ' ', RECLN);
317 while (b[*flin - 1][*column - 1] == ' ' && cont) {
318 advance (b, eol, &cont, flin, column, size);
319 }
320 if (cont && b[*flin - 1][*column - 1] == '\'') {
321 do {
322 advance (b, eol, &cont, flin, column, size);
323 while (cont && b[*flin - 1][*column - 1] != '\'') {
324 advance (b, eol, &cont, flin, column, size);
325 }
326 advance (b, eol, &cont, flin, column, size);
327 } while (cont && b[*flin - 1][*column - 1] == '\'');
328 }
329 *first = *column;
330 i = 0;
331 if (cont & isidchar (b[*flin - 1][*column - 1])) {
332 while ((isidchar (b[*flin - 1][*column - 1]) || isdigit (b[*flin - 1][*column - 1])) && cont) {
333 i++;
334 s[i - 1] = b[*flin - 1][*column - 1];
335 advance (b, eol, &cont, flin, column, size);
336 }
337 // Provision for 'endif' or 'end if' etcetera.
338 if (tolower (s[0]) == 'e' && tolower (s[1]) == 'n' && tolower (s[2]) == 'd') {
339 while (b[*flin - 1][*column - 1] == ' ' && cont) {
340 advance (b, eol, &cont, flin, column, size);
341 }
342 while (isidchar (b[*flin - 1][*column - 1]) && cont) {
343 i++;
344 s[i - 1] = b[*flin - 1][*column - 1];
345 advance (b, eol, &cont, flin, column, size);
346 }
347 }
348 s[i] = '\0';
349 cont = FALSE;
350 }
351 if (cont && isdigit (b[*flin - 1][*column - 1])) {
352 while (isdigit (b[*flin - 1][*column - 1]) && cont) {
353 i++;
354 s[i - 1] = b[*flin - 1][*column - 1];
355 advance (b, eol, &cont, flin, column, size);
356 }
357 s[i] = '\0';
358 cont = FALSE;
359 }
360 if (!(cont & isspecial (b[*flin - 1][*column - 1]))) {
361 return;
362 }
363 s[0] = b[*flin - 1][*column - 1];
364 advance (b, eol, &cont, flin, column, size);
365 s[1] = '\0';
366 cont = FALSE;
367 }
368
369 static int_4 new_label (char *c)
370 {
371 int_4 flin = 1;
372 int_4 labval = atoi (c);
373 while (old_label[flin - 1] != labval && flin < MODLEN) {
374 flin++;
375 }
376 if (flin < MODLEN) {
377 return flin;
378 }
379 message (NO_FTN_LINE, ERR, "error", 0, "undefined label", c);
380 errors++;
381 return 0;
382 }
383
384 static void skip_to_comma (RECORD *b, char *s, int_4 *eol, int_4 *flin, int_4 *column, int_4 *first, int_4 *size)
385 {
386 int_4 nest = 0;
387 while (! (s[0] == ',' && nest == 0)) {
388 scan_symbol (b, s, eol, flin, column, first, size);
389 if (s[0] == '(') {
390 nest++;
391 } else if (s[0] == ')') {
392 if (nest == 0) {
393 return;
394 } else {
395 nest--;
396 }
397 }
398 }
399 }
400
401 static void relabel_io (RECORD *b, char *s, int_4 *eol, int_4 *flin, int_4 *column, int_4 *first, int_4 *size)
402 {
403 scan_symbol (b, s, eol, flin, column, first, size);
404 if (s[0] == '*') {
405 // print_4 *, ...
406 ;
407 } else if (isdigit (s[0])) {
408 // print_4 10, ...
409 replace_label (b, flin, first, column, new_label (s));
410 } else if (s[0] == '(') {
411 // print_4 (UNIT [,FMT=n],FILE=expr][,FORM=str][,ACTION=str][,DISP=str][,END=n][,ERR=n])
412 int_4 pos = 0;
413 do {
414 pos++;
415 scan_symbol (b, s, eol, flin, column, first, size);
416 if (s[0] == ',') {
417 ;
418 } else if (EQUAL (s, ")")) {
419 return;
420 } else if (EQUAL (s, "access")) {
421 skip_to_comma (b, s, eol, flin, column, first, size);
422 } else if (EQUAL (s, "action")) {
423 skip_to_comma (b, s, eol, flin, column, first, size);
424 } else if (EQUAL (s, "disp")) {
425 skip_to_comma (b, s, eol, flin, column, first, size);
426 } else if (EQUAL (s, "file")) {
427 skip_to_comma (b, s, eol, flin, column, first, size);
428 } else if (EQUAL (s, "form")) {
429 skip_to_comma (b, s, eol, flin, column, first, size);
430 } else if (EQUAL (s, "fmt") || EQUAL (s, "end") || EQUAL (s, "err")) {
431 scan_symbol (b, s, eol, flin, column, first, size);
432 scan_symbol (b, s, eol, flin, column, first, size);
433 replace_label (b, flin, first, column, new_label (s));
434 scan_symbol (b, s, eol, flin, column, first, size);
435 } else if (isdigit (s[0]) && pos == 2) {
436 replace_label (b, flin, first, column, new_label (s));
437 scan_symbol (b, s, eol, flin, column, first, size);
438 } else {
439 skip_to_comma (b, s, eol, flin, column, first, size);
440 }
441 } while (s[0] == ',');
442 }
443 }
444
445 static void relabel_goto (RECORD *b, char *s, int_4 *eol, int_4 *flin, int_4 *column, int_4 *first, int_4 *size)
446 {
447 do {
448 scan_symbol (b, s, eol, flin, column, first, size);
449 replace_label (b, flin, first, column, new_label (s));
450 scan_symbol (b, s, eol, flin, column, first, size);
451 } while (s[0] != ')');
452 }
453
454 static logical_4 relabel_statement (RECORD *b, char *s, int_4 *eol, int_4 *flin, int_4 *column, int_4 *first, int_4 *size)
455 {
456 if (EQUAL (s, "do")) {
457 scan_symbol (b, s, eol, flin, column, first, size);
458 if (isdigit (s[0])) {
459 replace_label (b, flin, first, column, new_label (s));
460 }
461 return TRUE;
462 }
463 if (EQUAL (s, "assign")) {
464 scan_symbol (b, s, eol, flin, column, first, size);
465 replace_label (b, flin, first, column, new_label (s));
466 return TRUE;
467 }
468 if (EQUAL (s, "read") || EQUAL (s, "accept")) {
469 relabel_io (b, s, eol, flin, column, first, size);
470 return TRUE;
471 }
472 if (EQUAL (s, "write") || EQUAL (s, "print") || EQUAL (s, "punch")) {
473 relabel_io (b, s, eol, flin, column, first, size);
474 return TRUE;
475 }
476 if (EQUAL (s, "goto") || EQUAL (s, "go")) {
477 if (EQUAL (s, "go")) {
478 scan_symbol (b, s, eol, flin, column, first, size);
479 }
480 scan_symbol (b, s, eol, flin, column, first, size);
481 if (s[0] == '(') {
482 relabel_goto (b, s, eol, flin, column, first, size);
483 } else if (isalpha (s[0])) {
484 scan_symbol (b, s, eol, flin, column, first, size);
485 if (s[0] == ',') {
486 scan_symbol (b, s, eol, flin, column, first, size);
487 }
488 relabel_goto (b, s, eol, flin, column, first, size);
489 } else {
490 replace_label (b, flin, first, column, new_label (s));
491 }
492 return TRUE;
493 }
494 if (EQUAL (s, "if")) {
495 scan_symbol (b, s, eol, flin, column, first, size);
496 int_4 nest = 1;
497 do {
498 scan_symbol (b, s, eol, flin, column, first, size);
499 if (s[0] == '(') {
500 nest++;
501 } else if (s[0] == ')') {
502 nest--;
503 }
504 } while (nest != 0);
505 scan_symbol (b, s, eol, flin, column, first, size);
506 if (isdigit (s[0])) {
507 replace_label (b, flin, first, column, new_label (s));
508 scan_symbol (b, s, eol, flin, column, first, size);
509 scan_symbol (b, s, eol, flin, column, first, size);
510 replace_label (b, flin, first, column, new_label (s));
511 scan_symbol (b, s, eol, flin, column, first, size);
512 if (EQUAL (s, ",")) {
513 scan_symbol (b, s, eol, flin, column, first, size);
514 replace_label (b, flin, first, column, new_label (s));
515 }
516 } else if (EQUAL (s, "goto") | EQUAL (s, "go")) {
517 relabel_statement (b, s, eol, flin, column, first, size);
518 } else if (EQUAL (s, "read") || EQUAL (s, "accept")) {
519 relabel_statement (b, s, eol, flin, column, first, size);
520 } else if (EQUAL (s, "write") || EQUAL (s, "print") || EQUAL (s, "punch")) {
521 relabel_statement (b, s, eol, flin, column, first, size);
522 } else if (EQUAL (s, "assign")) {
523 relabel_statement (b, s, eol, flin, column, first, size);
524 }
525 return TRUE;
526 }
527
528 return FALSE;
529 }
530
531 static void scan_statement (RECORD *b, int_4 size)
532 {
533 RECORD s;
534 RECCLR (s);
535 int_4 eol = FALSE, column, first;
536 int_4 flin = 1;
537 do {
538 column = 1;
539 do {
540 if (flin > size) {
541 eol = TRUE;
542 flin = size;
543 }
544 if (IS_JCL (b[flin -1][0])) {
545 renum_jcl (b, &flin, &size);
546 flin++;
547 } else {
548 scan_symbol (b, s, &eol, &flin, &column, &first, &size);
549 if (relabel_statement (b, s, &eol, &flin, &column, &first, &size)) {
550 /* skip */;
551 }
552 }
553 } while (!eol);
554 } while (flin < size);
555 }
556
557 static void scan_name (RECORD *b, int_4 size, char *n)
558 {
559 RECORD s;
560 int_4 eol, column, first, i;
561
562 int_4 flin = 1;
563 memset (n, ' ', RECLN);
564 memcpy (n, "anonymous", 9);
565 do {
566 column = 1;
567 if (IS_COMMENT (*(b[flin - 1]))) {
568 flin++;
569 } else {
570 do {
571 scan_symbol (b, s, &eol, &flin, &column, &first, &size);
572 if (EQUAL (s, "end")) {
573 eol = TRUE;
574 flin = size;
575 } else if (EQUAL (s, "program") || EQUAL (s, "subroutine") || EQUAL (s, "function")) {
576 memset (n, ' ', RECLN);
577 scan_symbol (b, s, &eol, &flin, &column, &first, &size);
578 i = 1;
579 while (i <= RECLN && s[i - 1] != '\0') {
580 n[i - 1] = tolower (s[i - 1]);
581 i++;
582 }
583 }
584 } while (!eol);
585 }
586 } while (flin < size);
587 }
588
589 void relabel (char *fname)
590 {
591 RECORD gname;
592 FILE *infile, *outfile;
593 int_4 number;
594 static DECK fsrc;
595 RECCLR (gname);
596 if ((infile = fopen (fname, "r")) == NO_FILE) {
597 FATAL (2501, "cannot open", fname);
598 };
599 strcpy (gname, fname);
600 for (int_4 k = (int_4) strlen (gname); k >= 0; k--) {
601 if (gname[k] == '.') {
602 gname[k] = '\0';
603 break;
604 }
605 }
606 //
607 strcat (gname, ".f~");
608 if ((outfile = fopen (gname, "w")) == NO_FILE) {
609 FATAL (2502, "cannot open", gname);
610 };
611 //
612 routines = 0;
613 errors = 0;
614 do {
615 int_4 size;
616 fill_buffer (&infile, fsrc, &size);
617 if (size > 0) {
618 for (int_4 i = 1; i <= size; i++) {
619 old_label[i - 1] = 0;
620 }
621 number = 0;
622 int_4 flin = 1;
623 while (flin <= size) {
624 int_4 labval = read_label (fsrc, &flin, &size);
625 if (labval != 0) {
626 number++;
627 write_label (fsrc, flin, number);
628 old_label[number - 1] = labval;
629 }
630 flin++;
631 }
632 if (number == 0) {
633 write_buffer (&outfile, fsrc, size);
634 } else {
635 routines++;
636 scan_name (fsrc, size, name);
637 scan_statement (fsrc, size);
638 write_buffer (&outfile, fsrc, size);
639 printf ("** ");
640 for (int_4 i = 1; i <= 10; i++) {
641 putchar (name[i - 1]);
642 }
643 printf (" ** renumbered subprogram %d\n", routines);
644 }
645 }
646 } while (!P_eof (infile));
647 fclose (infile);
648 fclose (outfile);
649 return;
650 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
