type.c
1 //! @file type.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 //! Type routines.
25
26 #include <vif.h>
27
28 void compute_row_size (RECORD buf, IDENT *idf)
29 {
30 RECORD str;
31 RECCLR (str);
32 for (int_4 n = 0; n < idf->mode.dim; n++) {
33 if (EQUAL (idf->len[n], "VARY")) {
34 _srecordf (buf, "VARY");
35 return;
36 } else {
37 fold_int_4 (buf, idf->len[n]);
38 }
39 if (isint_4 (buf, NO_REF_INTEGER)) {
40 bufcat (str, buf, RECLN);
41 } else {
42 bufcat (str,"(", RECLN);
43 bufcat (str, buf, RECLN);
44 bufcat (str,")", RECLN);
45 }
46 if (n < idf->mode.dim - 1) {
47 bufcat (str, " * ", RECLN);
48 }
49 }
50 fold_int_4 (buf, str);
51 }
52
53 void norm_mode (MODE *mode)
54 {
55 if (mode != NO_MODE && mode->type == CHARACTER) {
56 if (mode->len == 0) {
57 // CHARACTER*(*)
58 return;
59 }
60 for (int k = 0, lim = 2; k < MAX_STRLENS; k++, lim *= 2) {
61 if (mode->len < lim) {
62 strlens[k] = TRUE;
63 mode->len = lim - 1;
64 return;
65 }
66 }
67 RECORD str;
68 _srecordf (str, "%d", mode->len);
69 ERROR (3101, "character length overflow", str);
70 mode->len = MAX_STRLEN;
71 }
72 }
73
74 void default_impl (void)
75 {
76 int_4 k;
77 for (k = ord ('a'); k <= ord ('h'); k++) {
78 if (implicit_r8) {
79 f2c_type ("real*8", &(implic[k].mode), NOARG, NOFUN);
80 } else {
81 f2c_type ("real*4", &(implic[k].mode), NOARG, NOFUN);
82 }
83 implic[k].mode.save = STATIC;
84 }
85 for (k = ord ('i'); k <= ord ('n'); k++) {
86 f2c_type ("integer*4", &(implic[k].mode), NOARG, NOFUN);
87 implic[k].mode.save = STATIC;
88 }
89 for (k = ord ('o'); k <= ord ('z'); k++) {
90 if (implicit_r8) {
91 f2c_type ("real*8", &(implic[k].mode), NOARG, NOFUN);
92 } else {
93 f2c_type ("real*4", &(implic[k].mode), NOARG, NOFUN);
94 }
95 implic[k].mode.save = STATIC;
96 }
97 implic[k].mode.save = STATIC;
98 }
99
100 char *qtype (MODE * mode)
101 {
102 RECORD t;
103 RECCLR (t);
104 if (mode->type == NOTYPE) {
105 _srecordf (t, "%s", "void");
106 } else if (mode->type == ETYPE) {
107 _srecordf (t, "%s", "type error");
108 } else if (mode->len > 0) {
109 switch (mode->type) {
110 case INTEGER:
111 _srecordf (t, "%s*%d", "integer", mode->len);
112 break;
113 case LOGICAL:
114 _srecordf (t, "%s*%d", "logical", mode->len);
115 break;
116 case REAL:
117 _srecordf (t, "%s*%d", "real", mode->len);
118 break;
119 case COMPLEX:
120 _srecordf (t, "%s*%d", "complex", mode->len);
121 break;
122 case CHARACTER:
123 _srecordf (t, "%s*%d", "character", mode->len);
124 break;
125 }
126 } else {
127 switch (mode->type) {
128 case INTEGER:
129 _srecordf (t, "%s", "integer");
130 break;
131 case LOGICAL:
132 _srecordf (t, "%s", "logical");
133 break;
134 case REAL:
135 _srecordf (t, "%s", "real");
136 break;
137 case COMPLEX:
138 _srecordf (t, "%s", "complex");
139 break;
140 case CHARACTER:
141 _srecordf (t, "%s", "character");
142 break;
143 }
144 }
145 return f_stralloc (t);
146 }
147
148 char *wtype (MODE * mode, int_4 arg, int_4 fun)
149 {
150 switch (mode->type) {
151 case INTEGER:{
152 if (mode->len == 2) {
153 return (arg ? "int_2 _p_ " : "int_2");
154 } else if (mode->len == 4) {
155 return (arg ? "int_4 _p_ " : "int_4");
156 } else if (mode->len == 8) {
157 return (arg ? "int_8 _p_ " : "int_8");
158 } else {
159 return "notype";
160 }
161 }
162 case LOGICAL:
163 if (arg) {
164 return "logical_4 _p_ ";
165 } else {
166 return "logical_4";
167 }
168 case REAL:
169 if (mode->len == 4) {
170 return (arg ? "real_4 _p_ " : "real_4");
171 } else if (mode->len == 8) {
172 return (arg ? "real_8 _p_ " : "real_8");
173 } else if (mode->len == 16) {
174 return (arg ? "real_16 _p_ " : "real_16");
175 } else if (mode->len == 32) {
176 return (arg ? "real_32 _p_ " : "real_32");
177 } else {
178 return "notype";
179 }
180 case COMPLEX:
181 if (mode->len == 8) {
182 return (arg ? "complex_8 _p_ " : "complex_8");
183 } else if (mode->len == 16) {
184 return (arg ? "complex_16 _p_ " : "complex_16");
185 } else if (mode->len == 32) {
186 return (arg ? "complex_32 _p_ " : "complex_32");
187 } else if (mode->len == 64) {
188 return (arg ? "complex_64 _p_ " : "complex_64");
189 } else {
190 return "notype";
191 }
192 case CHARACTER:{
193 if (fun || arg) {
194 return "char _p_ ";
195 } else {
196 RECORD str;
197 _srecordf (str, "char_%d", mode->len);
198 return f_stralloc (str);
199 }
200 }
201 case NOTYPE: { // C routine type
202 return "int_4";
203 }
204 default: {
205 return "notype";
206 }
207 }
208 }
209
210 char *f2c_type (char *ftype, MODE * mode, int_4 arg, int_4 fun)
211 {
212 MODE m = (MODE) {.type = NOTYPE,.len = NOLEN,.dim = 0 };
213 int_4 found = FALSE;
214 #define TEST(name, f_type, f_len, f_trunc)\
215 if (EQUAL (ftype, name)) {\
216 m = (MODE) {.type = f_type, .len = f_trunc, .dim = 0};\
217 found = TRUE;\
218 }
219 TEST ("none", NOTYPE, 0, 0);
220 TEST ("logical", LOGICAL, 4, 4);
221 TEST ("logical*1", LOGICAL, 1, 4);
222 TEST ("logical*2", LOGICAL, 2, 4);
223 TEST ("logical*4", LOGICAL, 4, 4);
224 TEST ("logical*8", LOGICAL, 8, 4);
225 TEST ("integer", INTEGER, 4, 4);
226 TEST ("integer*1", INTEGER, 2, 2);
227 TEST ("integer*2", INTEGER, 2, 2);
228 TEST ("integer*4", INTEGER, 4, 4);
229 TEST ("integer*8", INTEGER, 8, 8);
230 if (implicit_r8) {
231 TEST ("real", REAL, 8, 8);
232 } else {
233 TEST ("real", REAL, 4, 4);
234 }
235 TEST ("real*4", REAL, 4, 4);
236 TEST ("real*8", REAL, 8, 8);
237 TEST ("real*16", REAL, 16, 16);
238 TEST ("real*32", REAL, 32, 32);
239 if (implicit_r8) {
240 TEST ("complex", COMPLEX, 16, 16);
241 } else {
242 TEST ("complex", COMPLEX, 8, 8);
243 }
244 TEST ("complex*8", COMPLEX, 8, 8);
245 TEST ("complex*16", COMPLEX, 16, 16);
246 TEST ("complex*32", COMPLEX, 32, 32);
247 TEST ("complex*64", COMPLEX, 64, 64);
248 TEST ("character", CHARACTER, 1, 1);
249 if (LEQUAL ("character*", ftype)) {
250 int_4 len;
251 if (strcmp (ftype, "character*(*)") == 0) {
252 m = (MODE) {.type = CHARACTER, .len = 0, .dim = 0};
253 found = TRUE;
254 } else {
255 char *op = strchr (ftype, '('), *cl = strrchr(ftype, ')');
256 if (op != NO_TEXT && cl != NO_TEXT) {
257 RECORD fact;
258 _srecordf (fact, "%s", ++op);
259 if (strlen (fact) > 0 && fact[strlen (fact) - 1] == ')') {
260 fact[strlen (fact) - 1] = '\0';
261 }
262 if (!isint_4 (fact, &len)) {
263 MODE pm;
264 IDENT *idf = find_local (fact, &pm);
265 if (idf->parm != NO_TEXT && idf->mode.type == INTEGER) {
266 (void) isint_4 (idf->parm, &len);
267 } else {
268 ERROR (3102, "invalid length", fact);
269 len = MAX_STRLEN;
270 }
271 }
272 } else {
273 sscanf (ftype, "character*%d", &len);
274 }
275 m = (MODE) {.type = CHARACTER, .len = len, .dim = 0};
276 found = TRUE;
277 }
278 if (found && m.len > 1) {
279 norm_mode (&m);
280 }
281 }
282 if (mode != NO_MODE) {
283 *mode = m;
284 }
285 if (found) {
286 return (wtype (&m, arg, fun));
287 } else {
288 ERROR (3103, "unknown type", ftype);
289 return "notype";
290 }
291 }
292
293 char *ptr_to_array (IDENT * idf, int_4 constant, int_4 cast, int_4 formal)
294 {
295 RECORD str, name;
296 if (formal) {
297 _srecordf (name, "%s", edit_f (C_NAME (idf)));
298 } else {
299 _srecordf (name, "%s", C_NAME (idf));
300 }
301 if (idf->mode.dim <= 1) {
302 if (cast) {
303 _srecordf (str, "(%s _p_)", wtype (&idf->mode, NOARG, NOFUN));
304 } else if (constant) {
305 _srecordf (str, "_p_ const %s", name);
306 } else {
307 _srecordf (str, "_p_ %s", name);
308 }
309 } else {
310 if (cast) {
311 _srecordf (str, "(%s (_p_)", wtype (&idf->mode, NOARG, NOFUN));
312 } else if (constant) {
313 _srecordf (str, "(_p_ const %s)", name);
314 } else {
315 _srecordf (str, "(_p_ %s)", name);
316 }
317 if (cast) {
318 bufcat (str, ")", RECLN);
319 }
320 }
321 return f_stralloc (str);
322 }
323
324 int_4 accept_mode (int_4 Lt, int_4 Ll, int_4 Rt, int_4 Rl)
325 {
326 // Whether L is acceptable to R.
327 if (Rt == REAL && Lt == REAL) {
328 return Ll <= Rl;
329 }
330 if (Rt == INTEGER && Lt == INTEGER) {
331 return Ll <= Rl;
332 }
333 if (Rt == LOGICAL && Lt == LOGICAL) {
334 return Ll <= Rl;
335 }
336 if (Rt == REAL && Lt == INTEGER) {
337 return Ll <= Rl;
338 }
339 if (Rt == COMPLEX && Lt == REAL) {
340 return 2 * Ll <= Rl;
341 }
342 if (Rt == COMPLEX && Lt == INTEGER) {
343 return 2 * Ll <= Rl;
344 }
345 if (Rt == INTEGER && Lt == CHARACTER) {
346 return Rl == 4;
347 }
348 if (Rt == INTEGER && Lt == REAL) {
349 return FALSE;
350 }
351 // Generic cases.
352 if (Rt == NOTYPE) {
353 return TRUE;
354 } else if (Lt != Rt) {
355 return FALSE;
356 } else if (Rl == NOLEN) {
357 return TRUE;
358 }
359 return Ll <= Rl;
360 }
361
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
