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