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