fpp.c
1 //! @file fpp.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 //! Fortran preprocessor.
25
26 #include <vif.h>
27
28 void fpp (char *, char *, int_4 nest);
29
30 int_4 register_file(char *name)
31 {
32 for (int_4 k = 1; k <= nfiles; k++) {
33 if (strcmp (files[k].text, name) == 0) {
34 return k;
35 }
36 }
37 nfiles++;
38 if (nfiles >= MAX_SOURCE_FILES) {
39 FATAL (2001, "too many source files", NO_TEXT);
40 }
41 files[nfiles].num = nfiles;
42 files[nfiles].text = f_stralloc (name);
43 return nfiles;
44 }
45
46 void get_source (char *name, int_4 nest)
47 {
48 FILE *in;
49 char *ext;
50 int_4 lines = 1, nisn = 0, actfile, cntrls = 0;
51 if (nest > MAX_NEST) {
52 FATAL (2002, "include nesting too deep", name);
53 }
54 if (strlen (name) < 3) {
55 FATAL (2003, "source file name", name);
56 }
57 ext = &name[strlen (name) - 2];
58 if (EQUAL (ext, ".f") || EQUAL (ext, ".F")) {
59 ;// Ok
60 } else if (EQUAL (ext, ".f66") || EQUAL (ext, ".F66")) {
61 ;// Ok
62 } else if (EQUAL (ext, ".f77") || EQUAL (ext, ".F77")) {
63 ;// Ok
64 } else if (EQUAL (ext, ".ftn") || EQUAL (ext, ".FTN")) {
65 ;// Ok
66 } else if (EQUAL (ext, ".h") || EQUAL (ext, ".H")) {
67 ;// Ok
68 } else {
69 FATAL (2004, "source file format", name);
70 }
71 if ((in = fopen (name, "r")) == NO_FILE) {
72 FATAL (2005, "cannot read", name);
73 };
74 NEW_RECORD (path);
75 _srecordf (path, "%s", dirname (name));
76 actfile = register_file(name);
77 while (!feof (in)) {
78 NEW_RECORD (fetch);
79 if (fgets (fetch, RECLN, in) != NO_TEXT) {
80 int_4 len = strlen (fetch);
81 if (len > 0) {
82 for (int k = 0; k < len; k++) {
83 if (fetch[k] == EOF || fetch[k] == '\0' || fetch[k] == '\n') {
84 ;
85 } else if (fetch[k] == '\r' && fetch[k + 1] == '\n') {
86 // Assume ms-dos that has \r\n line ends.
87 fetch[k] = '\n';
88 fetch[k + 1] = '\0';
89 len--;
90 } else {
91 if (!isprint (fetch[k])) {
92 cntrls++;
93 fetch[k] = '?';
94 }
95 }
96 }
97 if (fetch[0] == '#') {
98 int_4 savfile = actfile;
99 fpp (fetch, path, nest);
100 actfile = savfile;
101 lines++;
102 } else {
103 if (fetch[len - 1] == '\n') {
104 fetch[--len] = '\0';
105 }
106 if (nftnlines == MAX_FTN_LINES - 1) { // One less - always terminating NULL line.
107 MAX_FTN_LINES += INCREMENT;
108 source = (FTN_LINE *) f_realloc (source, MAX_FTN_LINES * sizeof (FTN_LINE));
109 memset (&source[nftnlines], 0, INCREMENT * sizeof (FTN_LINE));
110 }
111 source[nftnlines].file = &files[actfile];
112 source[nftnlines].num = lines;
113 source[nftnlines].len = len;
114 source[nftnlines].jcl = FALSE;
115 source[nftnlines].text = f_stralloc (fetch);
116 if (fetch[0] == '\0' || IS_COMMENT (fetch[0])) {
117 source[nftnlines].isn = 0;
118 } else if (nisn > 0 && fetch[5] != ' ') {
119 source[nftnlines].isn = nisn;
120 } else {
121 source[nftnlines].isn = ++nisn;
122 }
123 lines++;
124 nftnlines++;
125 }
126 }
127 }
128 }
129 files[nfiles].len = lines - 1;
130 fclose (in);
131 if (cntrls > 0) {
132 WARNING (2006, "source has unrecognized characters", NO_TEXT);
133 }
134 }
135
136 void fpp (char *cmd, char *path, int_4 nest)
137 {
138 if (cmd[0] == '#') {
139 cmd++;
140 }
141 while (cmd[0] == ' ') {
142 cmd++;
143 }
144 if (LEQUAL ("echo", cmd)) {
145 cmd = &cmd[strlen ("echo")];
146 while (cmd[0] == ' ') {
147 cmd++;
148 }
149 int_4 N = strlen (cmd);
150 if (N > 0 && cmd[N - 1] == '\n') {
151 cmd[N - 1] = '\0';
152 }
153 ECHO (2007, cmd, NO_TEXT);
154 } else if (LEQUAL ("pragma", cmd)) {
155 cmd = &cmd[strlen ("pragma")];
156 while (cmd[0] == ' ') {
157 cmd++;
158 }
159 int_4 N = strlen (cmd);
160 if (N > 0 && cmd[N - 1] == '\n') {
161 cmd[N - 1] = '\0';
162 }
163 option (cmd);
164 } else if (LEQUAL ("include", cmd)) {
165 NEW_RECORD (fn);
166 (void) strtok (cmd, "'");
167 char *str = strtok (NO_TEXT, "'");
168 if (str != NO_TEXT) {
169 _srecordf (fn, "%s/%s", path, str);
170 get_source (fn, nest + 1);
171 } else {
172 FATAL (2008, "filename required", cmd);
173 }
174 } else {
175 FATAL (2009, "preprocessor directive", cmd);
176 }
177 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
