table.c
1 //! @file table.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 //! Symbol table routines.
25
26 #include <vif.h>
27
28 int_4 ord (char ch)
29 {
30 return (ch - 'a');
31 }
32
33 char *edit_name (char *name)
34 {
35 static RECORD idf, idf2;
36 char *buf = idf;
37 strcpy (buf, name);
38 int_4 len = strlen (buf);
39 while (len > 1 && buf[len - 1] == '_') {
40 buf[len - 1] = '\0';
41 len = strlen (buf);
42 }
43 while (len > 1 && buf[0] == '_') {
44 buf++;
45 len = strlen (buf);
46 }
47 RECCPY (idf2, buf);
48 return idf2;
49 }
50
51 char *edit_f (char *name)
52 {
53 static RECORD buf;
54 _srecordf (buf, "_%s", edit_name (name));
55 return buf;
56 }
57
58 char *edit_i (char *name)
59 {
60 static RECORD buf;
61 _srecordf (buf, "__%s", edit_name (name));
62 return buf;
63 }
64
65 char *edit_v (char *name)
66 {
67 static RECORD buf;
68 _srecordf (buf, "%s_", edit_name (name));
69 return buf;
70 }
71
72 char *edit_vn (char *name, int_4 num)
73 {
74 static RECORD buf;
75 _srecordf (buf, "%s_%d_", edit_name (name), num);
76 return buf;
77 }
78
79 char *edit_tmp (int_4 num)
80 {
81 static RECORD buf;
82 _srecordf (buf, "$%d_", num);
83 return buf;
84 }
85
86 char *edit_fmt (int_4 num)
87 {
88 static RECORD buf;
89 if (num >= 100000) { // Anonymous text formats
90 _srecordf (buf, "$f_%d_", num);
91 return buf;
92 }
93 LBL *L = NO_LABEL;
94 for (int_4 k = 0; k < nlabels; k++) {
95 if (num == labels[k].num) {
96 L = &labels[k];
97 break;
98 }
99 }
100 if (L == NO_LABEL) {
101 _srecordf (buf, "%d", num);
102 ERROR (3101, "undefined label", buf);
103 return NO_TEXT;
104 } else if (!L->format) {
105 _srecordf (buf, "%d", num);
106 ERROR (3102, "not a format label", buf);
107 return NO_TEXT;
108 } else {
109 L->jumped++;
110 _srecordf (buf, "$f_%d_", num);
111 return buf;
112 }
113 }
114
115 char *edit_unit (int_4 num)
116 {
117 static RECORD buf;
118 _srecordf (buf, "$u_%d_", num);
119 return buf;
120 }
121
122 char *encode (char *buf, char *name)
123 {
124 bufcpy (buf, name, RECLN);
125 int_4 len = (int_4) strlen (buf);
126 if (buf[0] == '_' || buf[len - 1] == '_') {
127 return buf;
128 }
129 bufcpy (buf, edit_v (name), RECLN);
130 return buf;
131 }
132
133 char *c_name (char *name)
134 {
135 NEW_RECORD (safe);
136 (void) encode (safe, name);
137 return f_stralloc (safe);
138 }
139
140 logical_4 same_name (char *name, char * id)
141 {
142 if (name == NO_TEXT || id == NO_TEXT) return FALSE;
143 NEW_RECORD (u);
144 NEW_RECORD (v);
145 (void) encode (u, name);
146 (void) encode (v, id);
147 return EQUAL (u, v);
148 }
149
150 LBL *find_label (char *lab)
151 {
152 int_4 k, num;
153 sscanf (lab, "%d", &num);
154 for (k = 0; k < nlabels; k++) {
155 LBL *L = &labels[k];
156 if (num == L->num) {
157 return L;
158 }
159 }
160 return NO_LABEL;
161 }
162
163 void impl_type (char *name, MODE * mode)
164 {
165 int_4 k = ord (tolower (name[0]));
166 (*mode) = implic[k].mode;
167 }
168
169 int_4 add_block (char *name)
170 {
171 int_4 k;
172 for (k = 0; k < ncommons; k++) {
173 if (same_name (name, commons[k])) {
174 return k;
175 }
176 }
177 if (ncommons >= MAX_COMMONS) {
178 FATAL (3103, "too many common blocks", NO_TEXT);
179 }
180 k = ncommons++;
181 commons[k] = c_name (name);
182 return k;
183 }
184
185 IDENT *find_local (char *name, MODE * mode)
186 {
187 int_4 k;
188 if (!IS_VAR (name)) {
189 ERROR (3104, "not a variable name", curlex);
190 return NO_IDENT;
191 }
192 // Search backwards, do not change.
193 for (k = nlocals - 1; k >= 0; k--) {
194 IDENT *idf = &locals[k];
195 if (idf->nest >= 0 && (EQUAL (name, C_NAME (idf)) || EQUAL (name, FTN_NAME (idf)))) {
196 if (macro_nest > 0 ? TRUE : idf->nest == 0) {
197 if (mode != NO_MODE) {
198 (*mode) = idf->mode;
199 }
200 idf->used = TRUE;
201 return idf;
202 }
203 }
204 }
205 return NO_IDENT;
206 }
207
208 IDENT *void_decl (char *name, MODE * mode)
209 {
210 if (!IS_VAR (name)) {
211 ERROR (3105, "not a variable name", curlex);
212 return NO_IDENT;
213 }
214 // Apparently a normal local variable.
215 IDENT *idf = find_local (name, mode);
216 if (idf == NO_IDENT) {
217 if (nlocals >= MAX_IDENTS) {
218 FATAL (3106, "too many identifiers", NO_TEXT);
219 return NO_IDENT;
220 }
221 idf = &locals[nlocals++];
222 memset (idf, 0, sizeof (IDENT));
223 idf->line = curlin;
224 C_NAME (idf) = c_name (name);
225 FTN_NAME (idf) = f_stralloc (name);
226 idf->external = FALSE;
227 idf->mode.type = NOTYPE;
228 idf->mode.len = 0;
229 if (mode != NO_MODE) {
230 *mode = idf->mode;
231 }
232 }
233 return idf;
234 }
235
236 IDENT *add_local (char *name, int_4 type, int_4 len, int_4 uniq, int_4 apatch, int_4 arg, int_4 blck, int_4 src)
237 {
238 MODE mode;
239 if (!IS_VAR (name)) {
240 ERROR (3107, "not a variable name", curlex);
241 return NO_IDENT;
242 }
243 IDENT *idf = find_local (name, &mode);
244 if (type == CHARACTER) {
245 MODE m = {.type = type, .len = len};
246 norm_mode (&m);
247 len = m.len;
248 if (idf == NO_IDENT) {
249 if (len == 0 && arg == FALSE) {
250 ERROR (3108, "variable length character must be argument", name);
251 }
252 } else {
253 if (len == 0 && idf->arg == FALSE) {
254 ERROR (3109, "variable length character must be argument", name);
255 }
256 }
257 }
258 if (idf != NO_IDENT) {
259 if (uniq) {
260 if (idf->mode.type == NOTYPE) {
261 if (type != NOTYPE) {
262 // Do not overwrite 'dim', respect previous dimension statement.
263 idf->mode.type = type;
264 idf->mode.len = len;
265 } else {
266 idf->patch2 = apatch;
267 }
268 } else if (idf->parm != NO_TEXT) {
269 if (accept_mode (idf->mode.type, idf->mode.len, type, len)) {
270 idf->mode = PLAIN_MODE (type, len);
271 } else {
272 MODE err = PLAIN_MODE (type, len);
273 MODE_ERROR (3110, qtype (&err), qtype (&(idf->mode)));
274 }
275 } else if (NOT_LOCAL (idf)) {
276 idf->mode = PLAIN_MODE (type, len);
277 } else if (idf->external) {
278 idf->mode = PLAIN_MODE (type, len);
279 } else if (idf->mode.type == type && idf->mode.len == len) {
280 /* Let it pass */
281 } else {
282 ERROR (3111, "multiple definition", name);
283 }
284 }
285 return idf;
286 }
287 if (nlocals >= MAX_IDENTS) {
288 FATAL (3112, "too many identifiers", NO_TEXT);
289 return NO_IDENT;
290 }
291 idf = &locals[nlocals++];
292 memset (idf, 0, sizeof (IDENT));
293 idf->line = curlin;
294 C_NAME (idf) = c_name (name);
295 FTN_NAME (idf) = f_stralloc (name);
296 idf->arg = arg;
297 idf->common = blck;
298 idf->external = FALSE;
299 idf->mode = PLAIN_MODE (type, len);
300 idf->patch1 = apatch;
301 idf->source = src;
302 return idf;
303 }
304
305 IDENT *add_nest (char *name, int_4 nest, MODE *mode)
306 {
307 if (!IS_VAR (name)) {
308 ERROR (3113, "not a variable name", curlex);
309 return NO_IDENT;
310 }
311 if (nlocals >= MAX_IDENTS) {
312 FATAL (3114, "too many identifiers", NO_TEXT);
313 return NO_IDENT;
314 }
315 // Already declared? Take this mode.
316 IDENT *pre = find_local (name, mode);
317 //
318 IDENT *idf = &locals[nlocals++];
319 memset (idf, 0, sizeof (IDENT));
320 idf->line = curlin;
321 C_NAME (idf) = c_name (name);
322 FTN_NAME (idf) = f_stralloc (name);
323 idf->arg = NOARG;
324 idf->external = FALSE;
325 idf->common = 0;
326 idf->patch1 = NOPATCH;
327 idf->source = TEMP;
328 idf->nest = nest;
329 if (pre == NO_IDENT) {
330 impl_type (name, &idf->mode);
331 *mode = idf->mode;
332 } else {
333 *mode = pre->mode;
334 idf->mode = *mode;
335 }
336 return idf;
337 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
