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