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-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 //! 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 strcpy (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_v (char *name)
59 {
60 static RECORD buf;
61 _srecordf (buf, "%s_", edit_name (name));
62 return buf;
63 }
64
65 char *edit_vn (char *name, int_4 nest)
66 {
67 static RECORD buf;
68 _srecordf (buf, "%s_%d_", edit_name (name), nest);
69 return buf;
70 }
71
72 char *edit_tmp (int_4 nest)
73 {
74 static RECORD buf;
75 _srecordf (buf, "$%d_", nest);
76 return buf;
77 }
78
79 char *edit_fmt (int_4 nest)
80 {
81 static RECORD buf;
82 _srecordf (buf, "$f_%d_", nest);
83 return buf;
84 }
85
86 char *edit_unit (int_4 nest)
87 {
88 static RECORD buf;
89 _srecordf (buf, "$u_%d_", nest);
90 return buf;
91 }
92
93 char *encode (char *buf, char *name)
94 {
95 bufcpy (buf, name, RECLN);
96 int_4 len = (int_4) strlen (buf);
97 if (buf[0] == '_' || buf[len - 1] == '_') {
98 return buf;
99 }
100 bufcpy (buf, edit_v (name), RECLN);
101 return buf;
102 }
103
104 char *c_name (char *name)
105 {
106 RECORD safe;
107 RECCLR (safe);
108 (void) encode (safe, name);
109 return stralloc (safe);
110 }
111
112 int_4 same_name (char *name, char * id)
113 {
114 if (name == NULL || id == NULL) return FALSE;
115 RECORD u, v;
116 RECCLR (u);
117 RECCLR (v);
118 (void) encode (u, name);
119 (void) encode (v, id);
120 return EQUAL (u, v);
121 }
122
123 LBL *find_label (char *lab)
124 {
125 int_4 k, num;
126 sscanf (lab, "%d", &num);
127 for (k = 0; k < nlabels; k++) {
128 LBL *L = &labels[k];
129 if (num == L->num) {
130 return L;
131 }
132 }
133 return NULL;
134 }
135
136 void impl_type (char *name, MODE * mode)
137 {
138 int_4 k = ord (tolower (name[0]));
139 (*mode) = implic[k].mode;
140 }
141
142 int_4 add_block (char *name)
143 {
144 int_4 k;
145 for (k = 0; k < ncommons; k++) {
146 if (same_name (name, commons[k])) {
147 return k;
148 }
149 }
150 if (ncommons >= MAX_COMMONS) {
151 FATAL (2801, "too many common blocks", NULL);
152 }
153 k = ncommons++;
154 commons[k] = c_name (name);
155 return k;
156 }
157
158 IDENT *find_local (char *name, MODE * mode)
159 {
160 int_4 k;
161 if (!IS_VAR (name)) {
162 ERROR (2802, "not a variable name", curlex);
163 return NULL;
164 }
165 // Search backwards, do not change.
166 for (k = nlocals - 1; k >= 0; k--) {
167 IDENT *idf = &locals[k];
168 if (EQUAL (name, CID (idf)) || EQUAL (name, FID (idf))) {
169 if (macro_nest > 0 ? TRUE : idf->nest == 0) {
170 if (mode != NULL) {
171 (*mode) = idf->mode;
172 }
173 idf->used = TRUE;
174 return idf;
175 }
176 }
177 }
178 return NULL;
179 }
180
181 IDENT *void_decl (char *name, MODE * mode)
182 {
183 if (!IS_VAR (name)) {
184 ERROR (2803, "not a variable name", curlex);
185 return NULL;
186 }
187 // Apparently a normal local variable.
188 IDENT *idf = find_local (name, mode);
189 if (idf == NULL) {
190 if (nlocals >= MAX_IDENTS) {
191 FATAL (2804, "too many identifiers", NULL);
192 return NULL;
193 }
194 idf = &locals[nlocals++];
195 memset (idf, 0, sizeof (IDENT));
196 idf->line = curlin;
197 CID (idf) = c_name (name);
198 FID (idf) = stralloc (name);
199 idf->external = FALSE;
200 idf->mode.type = NOTYPE;
201 idf->mode.len = 0;
202 if (mode != NULL) {
203 *mode = idf->mode;
204 }
205 }
206 return idf;
207 }
208
209 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)
210 {
211 MODE mode;
212 if (!IS_VAR (name)) {
213 ERROR (2805, "not a variable name", curlex);
214 return NULL;
215 }
216 IDENT *idf = find_local (name, &mode);
217 if (type == CHARACTER) {
218 MODE m = {.type = type, .len = len};
219 norm_mode (&m);
220 len = m.len;
221 if (idf == NULL) {
222 if (len == 0 && arg == FALSE) {
223 ERROR (2806, "variable length character must be argument", name);
224 }
225 } else {
226 if (len == 0 && idf->arg == FALSE) {
227 ERROR (2807, "variable length character must be argument", name);
228 }
229 }
230 }
231 if (idf != NULL) {
232 if (uniq) {
233 if (idf->mode.type == NOTYPE) {
234 if (type != NOTYPE) {
235 // Do not overwrite 'dim', respect previous dimension statement.
236 idf->mode.type = type;
237 idf->mode.len = len;
238 } else {
239 idf->patch2 = apatch;
240 }
241 } else if (idf->parm != NULL) {
242 if (accept_mode (idf->mode.type, idf->mode.len, type, len)) {
243 idf->mode = PLAIN_MODE (type, len);
244 } else {
245 MODE err = PLAIN_MODE (type, len);
246 MODE_ERROR (2808, qtype (&err), qtype (&(idf->mode)));
247 }
248 } else if (idf->common > 0) {
249 idf->mode = PLAIN_MODE (type, len);
250 } else if (idf->external) {
251 idf->mode = PLAIN_MODE (type, len);
252 } else if (idf->mode.type == type && idf->mode.len == len) {
253 /* Let it pass */
254 } else {
255 ERROR (2809, "multiple definition", name);
256 }
257 }
258 return idf;
259 }
260 if (nlocals >= MAX_IDENTS) {
261 FATAL (2810, "too many identifiers", NULL);
262 return NULL;
263 }
264 idf = &locals[nlocals++];
265 memset (idf, 0, sizeof (IDENT));
266 idf->line = curlin;
267 CID (idf) = c_name (name);
268 FID (idf) = stralloc (name);
269 idf->arg = arg;
270 idf->common = blck;
271 idf->external = FALSE;
272 idf->mode = PLAIN_MODE (type, len);
273 idf->patch1 = apatch;
274 idf->source = src;
275 return idf;
276 }
277
278 IDENT *add_nest (char *name, int_4 nest, MODE *mode)
279 {
280 if (!IS_VAR (name)) {
281 ERROR (2811, "not a variable name", curlex);
282 return NULL;
283 }
284 if (nlocals >= MAX_IDENTS) {
285 FATAL (2812, "too many identifiers", NULL);
286 return NULL;
287 }
288 // Already declared? Take this mode.
289 IDENT *pre = find_local (name, mode);
290 //
291 IDENT *idf = &locals[nlocals++];
292 memset (idf, 0, sizeof (IDENT));
293 idf->line = curlin;
294 CID (idf) = c_name (name);
295 FID (idf) = stralloc (name);
296 idf->arg = NOARG;
297 idf->external = FALSE;
298 idf->common = 0;
299 idf->patch1 = NOPATCH;
300 idf->source = TEMP;
301 idf->nest = nest;
302 if (pre == NULL) {
303 impl_type (name, &idf->mode);
304 *mode = idf->mode;
305 } else {
306 *mode = pre->mode;
307 idf->mode = *mode;
308 }
309 return idf;
310 }
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
