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