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