expression.c
1 //! @file expression.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 //! Compile Fortran expressions.
25
26 #include <vif.h>
27
28 int_4 lhs_factor;
29
30 #define OP_ERROR(num, s) {\
31 NEW_RECORD (_str_);\
32 _srecordf (_str_, "%s %s %s",\
33 qtype (&lhs->mode), op, qtype (&rhs->mode));\
34 ERROR ((num), (s), _str_);\
35 return;\
36 }
37
38 logical_4 valid_expr (EXPR *reg)
39 {
40 if (strlen (reg->str) == 0) {
41 return FALSE;
42 }
43 if (reg->mode.type == ETYPE) {
44 return FALSE;
45 }
46 return TRUE;
47 }
48
49 char *const_1 (MODE * m)
50 {
51 if (m->type == INTEGER) {
52 return "1";
53 } else if (m->type == REAL) {
54 if (m->len == 8) {
55 return "1.0";
56 } else if (m->len == 16) {
57 return "1.0q";
58 }
59 } else if (m->type == COMPLEX) {
60 if (m->len == 16) {
61 return "1.0";
62 } else if (m->len == 32) {
63 return "1.0q";
64 }
65 }
66 return "1";
67 }
68
69 int_4 optimise_exp (char *str, EXPR * lhs, EXPR * rhs)
70 {
71 NEW_RECORD (tmp);
72 if (lhs->mode.type == INTEGER && lhs->variant == EXPR_CONST && rhs->mode.type == INTEGER && rhs->variant == EXPR_CONST) {
73 int_4 a, n;
74 sscanf (lhs->str, "%d", &a);
75 sscanf (rhs->str, "%d", &n);
76 _srecordf (str, "%d", _up_int_4 (a, n));
77 return TRUE;
78 }
79 int_4 simple = lhs->variant != EXPR_OTHER;
80 if (EQUAL (rhs->str, "2")) {
81 if (simple) {
82 _srecordf (str, "(%s * %s)", lhs->str, lhs->str);
83 } else {
84 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
85 add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
86 _srecordf (str, "(%s = %s, %s * %s)", tmp, lhs->str, tmp, tmp);
87 }
88 return TRUE;
89 } else if (simple && EQUAL (rhs->str, "-2")) {
90 _srecordf (str, "%s / (%s * %s)", const_1 (&lhs->mode), lhs->str, lhs->str);
91 return TRUE;
92 } else if (simple && EQUAL (rhs->str, "3")) {
93 _srecordf (str, "(%s * %s * %s)", lhs->str, lhs->str, lhs->str);
94 return TRUE;
95 } else if (simple && EQUAL (rhs->str, "-3")) {
96 _srecordf (str, "%s / (%s * %s * %s)", const_1 (&lhs->mode), lhs->str, lhs->str, lhs->str);
97 return TRUE;
98 } else if (simple && EQUAL (rhs->str, "4")) {
99 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
100 add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
101 _srecordf (str, "(%s = %s * %s, %s * %s)", tmp, lhs->str, lhs->str, tmp, tmp);
102 return TRUE;
103 } else if (simple && EQUAL (rhs->str, "-4")) {
104 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
105 add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
106 _srecordf (str, "(%s = %s * %s, %s / (%s * %s))", tmp, lhs->str, lhs->str, const_1 (&lhs->mode), tmp, tmp);
107 return TRUE;
108 } else if (simple && EQUAL (rhs->str, "5")) {
109 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
110 add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
111 _srecordf (str, "(%s = %s * %s, %s * %s * %s)", tmp, lhs->str, lhs->str, lhs->str, tmp, tmp);
112 return TRUE;
113 } else if (simple && EQUAL (rhs->str, "-5")) {
114 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
115 add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
116 _srecordf (str, "(%s = %s * %s, %s / (%s * %s * %s))", tmp, lhs->str, lhs->str, const_1 (&lhs->mode), lhs->str, tmp, tmp);
117 return TRUE;
118 } else if (simple && EQUAL (rhs->str, "6")) {
119 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
120 add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
121 _srecordf (str, "(%s = %s * %s, %s * %s * %s)", tmp, lhs->str, lhs->str, tmp, tmp, tmp);
122 return TRUE;
123 } else if (simple && EQUAL (rhs->str, "-6")) {
124 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
125 add_local (tmp, lhs->mode.type, lhs->mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
126 _srecordf (str, "(%s = %s * %s, %s / (%s * %s * %s))", tmp, lhs->str, lhs->str, const_1 (&lhs->mode), tmp, tmp, tmp);
127 return TRUE;
128 } else {
129 return FALSE;
130 }
131 }
132
133 static void oper_char (EXPR * lhs, EXPR * rhs, char *op)
134 {
135 if (lhs->mode.type != rhs->mode.type) {
136 OP_ERROR (1401, "mixed mode expression");
137 } else {
138 char *routine = (use_strcasecmp ? "strcasecmp" : "strcmp");
139 if (EQUAL (op, "+") || EQUAL (op, "//")) {
140 int len;
141 if (lhs->mode.len == 0 || rhs->mode.len == 0) {
142 len = MAX_STRLEN;
143 } else {
144 len = lhs->mode.len + rhs->mode.len;
145 }
146 MODE m = {.type = CHARACTER, .len = (len > MAX_STRLEN ? MAX_STRLEN : len)};
147 norm_mode (&m);
148 NEW_RECORD (tmp);
149 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
150 add_local (tmp, CHARACTER, m.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
151 _srecordf (lhs->str, "concat (%s, %s, %s)", tmp, lhs->str, rhs->str);
152 lhs->mode = (MODE) {.type = CHARACTER, .len = m.len, .dim = 0};
153 } else if (EQUAL (op, ".eq.") || EQUAL (op, "==")) {
154 _srecordf (lhs->str, "(%s (%s, %s) == 0)", routine, lhs->str, rhs->str);
155 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
156 } else if (EQUAL (op, ".ne.") || EQUAL (op, "!=")) {
157 _srecordf (lhs->str, "(%s (%s, %s) != 0)", routine, lhs->str, rhs->str);
158 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
159 } else if (EQUAL (op, ".le.") || EQUAL (op, ".lle.") || EQUAL (op, "<=")) {
160 _srecordf (lhs->str, "(%s (%s, %s) <= 0)", routine, lhs->str, rhs->str);
161 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
162 } else if (EQUAL (op, ".ge.") || EQUAL (op, ".lge.") || EQUAL (op, ">=")) {
163 _srecordf (lhs->str, "(%s (%s, %s) >= 0)", routine, lhs->str, rhs->str);
164 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
165 } else if (EQUAL (op, ".lt.") || EQUAL (op, ".llt.") || EQUAL (op, "<")) {
166 _srecordf (lhs->str, "(%s (%s, %s) < 0)", routine, lhs->str, rhs->str);
167 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
168 } else if (EQUAL (op, ".gt.") || EQUAL (op, ".lgt.") || EQUAL (op, ">")) {
169 _srecordf (lhs->str, "(%s (%s, %s) > 0)", routine, lhs->str, rhs->str);
170 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
171 } else {
172 OP_ERROR (1402, "undefined operator");
173 }
174 }
175 }
176
177 static void oper_real_32 (EXPR * lhs, EXPR * rhs, char *op)
178 {
179 if (TYPE (lhs, REAL, 32)) {
180 if (TYPE (rhs, REAL, 32)) {
181 /* Ok */;
182 } else if (rhs->mode.type == REAL || rhs->mode.type == INTEGER) {
183 NEW_RECORD (tmp);
184 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
185 add_local (tmp, REAL, 32, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
186 _srecordf (rhs->str, "_quadtop (&%s, %s)", tmp, rhs->str);
187 rhs->mode = (MODE) {.type = REAL, .len = 32, .dim = 0};
188 }
189 } else if (TYPE (rhs, REAL, 32)) {
190 if (TYPE (lhs, REAL, 32)) {
191 /* Ok */;
192 } else if (lhs->mode.type == REAL || lhs->mode.type == INTEGER) {
193 NEW_RECORD (tmp);
194 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
195 add_local (tmp, REAL, 32, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
196 _srecordf (lhs->str, "_quadtop (&%s, %s)", tmp, lhs->str);
197 lhs->mode = (MODE) {.type = REAL, .len = 32, .dim = 0};
198 }
199 }
200 if (lhs->mode.type != rhs->mode.type) {
201 OP_ERROR (1403, "undefined operator");
202 } else if (lhs->mode.len != rhs->mode.len) {
203 OP_ERROR (1404, "undefined operator");
204 } else if (EQUAL (op, "+")) {
205 _srecordf (lhs->str, "xsum (%s, %s)", lhs->str, rhs->str);
206 } else if (EQUAL (op, "-")) {
207 _srecordf (lhs->str, "xsub (%s, %s)", lhs->str, rhs->str);
208 } else if (EQUAL (op, "*")) {
209 _srecordf (lhs->str, "xmul (%s, %s)", lhs->str, rhs->str);
210 } else if (EQUAL (op, "/")) {
211 _srecordf (lhs->str, "xdiv (%s, %s)", lhs->str, rhs->str);
212 } else if (EQUAL (op, ".eq.") || EQUAL (op, "==")) {
213 _srecordf (lhs->str, "xeq (%s, %s)", lhs->str, rhs->str);
214 lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
215 } else if (EQUAL (op, ".ne.") || EQUAL (op, "!=")) {
216 _srecordf (lhs->str, "xneq (%s, %s)", lhs->str, rhs->str);
217 lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
218 } else if (EQUAL (op, ".le.") || EQUAL (op, "<=")) {
219 _srecordf (lhs->str, "xle (%s, %s)", lhs->str, rhs->str);
220 lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
221 } else if (EQUAL (op, ".lt.") || EQUAL (op, "<")) {
222 _srecordf (lhs->str, "xlt (%s, %s)", lhs->str, rhs->str);
223 lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
224 } else if (EQUAL (op, ".ge.") || EQUAL (op, ">=")) {
225 _srecordf (lhs->str, "xge (%s, %s)", lhs->str, rhs->str);
226 lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
227 } else if (EQUAL (op, ".gt.") || EQUAL (op, ">")) {
228 _srecordf (lhs->str, "xgt (%s, %s)", lhs->str, rhs->str);
229 lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
230 } else {
231 OP_ERROR (1405, "undefined operator");
232 }
233 }
234
235 static void oper_complex_64 (EXPR * lhs, EXPR * rhs, char *op)
236 {
237 if (TYPE (lhs, COMPLEX, 64)) {
238 if (TYPE (rhs, COMPLEX, 64)) {
239 /* Ok */;
240 } else if (TYPE (rhs, REAL, 32)) {
241 NEW_RECORD (tmp);
242 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
243 add_local (tmp, COMPLEX, 64, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
244 _srecordf (rhs->str, "_coctotop (&%s, %s)", tmp, rhs->str);
245 rhs->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
246 } else if (rhs->mode.type == INTEGER || rhs->mode.type == REAL) {
247 NEW_RECORD (tmp);
248 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
249 add_local (tmp, COMPLEX, 64, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
250 _srecordf (rhs->str, "_cquadtop (&%s, %s)", tmp, rhs->str);
251 rhs->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
252 }
253 } else if (TYPE (rhs, COMPLEX, 64)) {
254 if (TYPE (lhs, REAL, 32)) {
255 NEW_RECORD (tmp);
256 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
257 add_local (tmp, COMPLEX, 64, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
258 _srecordf (lhs->str, "_coctotop (&%s, %s)", tmp, lhs->str);
259 lhs->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
260 } else if (lhs->mode.type == INTEGER || lhs->mode.type == REAL) {
261 NEW_RECORD (tmp);
262 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
263 add_local (tmp, COMPLEX, 64, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
264 _srecordf (lhs->str, "_cquadtop (&%s, %s)", tmp, lhs->str);
265 lhs->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
266 }
267 }
268 if (lhs->mode.type != rhs->mode.type) {
269 OP_ERROR (1406, "undefined operator");
270 } else if (lhs->mode.len != rhs->mode.len) {
271 OP_ERROR (1407, "undefined operator");
272 } else if (EQUAL (op, "+")) {
273 _srecordf (lhs->str, "cxsum (%s, %s)", lhs->str, rhs->str);
274 } else if (EQUAL (op, "-")) {
275 _srecordf (lhs->str, "cxsub (%s, %s)", lhs->str, rhs->str);
276 } else if (EQUAL (op, "*")) {
277 _srecordf (lhs->str, "cxmul (%s, %s)", lhs->str, rhs->str);
278 } else if (EQUAL (op, "/")) {
279 _srecordf (lhs->str, "cxdiv (%s, %s)", lhs->str, rhs->str);
280 } else if (EQUAL (op, ".eq.")) {
281 _srecordf (lhs->str, "cxeq (%s, %s)", lhs->str, rhs->str);
282 } else if (EQUAL (op, ".ne.")) {
283 _srecordf (lhs->str, "cxneq (%s, %s)", lhs->str, rhs->str);
284 } else {
285 OP_ERROR (1408, "undefined operator");
286 }
287 }
288
289 int_4 mix_len (EXPR * lhs, EXPR * rhs)
290 {
291 return _max (lhs->mode.len, rhs->mode.len);
292 }
293
294 void power (EXPR * lhs, EXPR * rhs, char *op)
295 {
296 NEW_RECORD (str);
297 if (rhs->mode.type != INTEGER) {
298 if (TYPE (lhs, REAL, 4) && TYPE (rhs, REAL, 4)) {
299 _srecordf (lhs->str, "powl (%s, %s)", lhs->str, rhs->str);
300 } else if (TYPE (lhs, REAL, 4) && TYPE (rhs, REAL, 8)) {
301 _srecordf (lhs->str, "powl (%s, (real_4) %s)", lhs->str, rhs->str);
302 } else if (TYPE (lhs, REAL, 8) && TYPE (rhs, REAL, 8)) {
303 _srecordf (lhs->str, "pow (%s, %s)", lhs->str, rhs->str);
304 } else if (TYPE (lhs, REAL, 8) && TYPE (rhs, REAL, 4)) {
305 _srecordf (lhs->str, "pow (%s, (real_8) %s)", lhs->str, rhs->str);
306 } else if (TYPE (lhs, REAL, 16) && TYPE (rhs, REAL, 16)) {
307 _srecordf (lhs->str, "powq (%s, %s)", lhs->str, rhs->str);
308 } else if (TYPE (lhs, REAL, 32) && TYPE (rhs, REAL, 32)) {
309 _srecordf (lhs->str, "xpow (%s, %s)", lhs->str, rhs->str);
310 } else {
311 OP_ERROR (1409, "undefined operator");
312 }
313 } else if (TYPE (lhs, COMPLEX, 64)) {
314 _srecordf (lhs->str, "cxpwr (%s, %s)", lhs->str, rhs->str);
315 } else if (TYPE (lhs, REAL, 32)) {
316 _srecordf (lhs->str, "xpwr (%s, %s)", lhs->str, rhs->str);
317 } else {
318 if (optimise_exp (str, lhs, rhs)) {
319 RECCPY (lhs->str, str);
320 return;
321 } else {
322 NEW_RECORD (proc);
323 if (lhs->mode.type == INTEGER) {
324 if (lhs->mode.len == 4) {
325 RECCPY (proc, "_up_int_4");
326 } else if (lhs->mode.len == 8) {
327 RECCPY (proc, "_up_int_8");
328 }
329 } else if (lhs->mode.type == REAL) {
330 if (lhs->mode.len == 4) {
331 RECCPY (proc, "_up_real_4");
332 } else if (lhs->mode.len == 8) {
333 RECCPY (proc, "_up_real_8");
334 } else if (lhs->mode.len == 16) {
335 RECCPY (proc, "_up_real_16");
336 }
337 } else if (lhs->mode.type == COMPLEX) {
338 if (lhs->mode.len == 8) {
339 RECCPY (proc, "_up_complex_8");
340 } else if (lhs->mode.len == 16) {
341 RECCPY (proc, "_up_complex");
342 } else if (lhs->mode.len == 32) {
343 RECCPY (proc, "_up_complex_32");
344 }
345 } else {
346 OP_ERROR (1410, "not an arithmetic operand");
347 }
348 _srecordf (lhs->str, "%s (%s, %s)", proc, lhs->str, rhs->str);
349 return;
350 }
351 }
352 }
353
354 void oper (EXPR * lhs, EXPR * rhs, char *op)
355 {
356 //
357 if (lhs->mode.type == ETYPE || rhs->mode.type == ETYPE) {
358 lhs->mode.type = ETYPE;
359 return;
360 }
361 //
362 if (EQUAL (op, ".not.") || EQUAL (op, "!")) {
363 _srecordf (lhs->str, "! (%s)", rhs->str);\
364 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};\
365 return;
366 }
367 //
368 #define MIXED(p, f_op, q, r, c_op) {\
369 if ((lhs->mode.type == (p) && rhs->mode.type == (q)) ||\
370 (lhs->mode.type == (q) && rhs->mode.type == (p))) {\
371 if (EQUAL (op, f_op)) {\
372 _srecordf (lhs->str, "%s %s %s", lhs->str, c_op, rhs->str);\
373 lhs->mode = (MODE) {.type = r, .len = mix_len (lhs, rhs), .dim = 0};\
374 return;\
375 }\
376 }}
377 //
378 #define LOGIC(p, f_op, q, c_op) {\
379 if ((lhs->mode.type == (p) && rhs->mode.type == (q)) ||\
380 (lhs->mode.type == (q) && rhs->mode.type == (p))) {\
381 if (EQUAL (op, f_op)) {\
382 _srecordf (lhs->str, "%s %s %s", lhs->str, c_op, rhs->str);\
383 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};\
384 return;\
385 }\
386 }}
387 //
388 if (lhs->mode.type == CHARACTER) {
389 oper_char (lhs, rhs, op);
390 } else if ((TYPE (lhs, COMPLEX, 64)) || (TYPE (rhs, COMPLEX, 64))) {
391 oper_complex_64 (lhs, rhs, op);
392 } else if ((TYPE (lhs, REAL, 32)) || (TYPE (rhs, REAL, 32))) {
393 oper_real_32 (lhs, rhs, op);
394 } else if (EQUAL (op, "**")) {
395 power (lhs, rhs, op);
396 } else {
397 MIXED (INTEGER, "+", INTEGER, INTEGER, "+");
398 MIXED (INTEGER, "+", REAL, REAL, "+");
399 MIXED (INTEGER, "+", COMPLEX, COMPLEX, "+");
400 MIXED (INTEGER, "-", INTEGER, INTEGER, "-");
401 MIXED (INTEGER, "-", REAL, REAL, "-");
402 MIXED (INTEGER, "-", COMPLEX, COMPLEX, "-");
403 MIXED (INTEGER, "*", INTEGER, INTEGER, "*");
404 MIXED (INTEGER, "*", REAL, REAL, "*");
405 MIXED (INTEGER, "*", COMPLEX, COMPLEX, "*");
406 MIXED (INTEGER, "/", INTEGER, INTEGER, "/");
407 MIXED (INTEGER, ".mod.", INTEGER, INTEGER, "%");
408 MIXED (INTEGER, "*%", INTEGER, INTEGER, "%");
409 MIXED (INTEGER, "/", REAL, REAL, "/");
410 MIXED (INTEGER, "/", COMPLEX, COMPLEX, "/");
411 MIXED (INTEGER, ".eq.", INTEGER, LOGICAL, "==");
412 MIXED (INTEGER, ".eq.", REAL, LOGICAL, "==");
413 MIXED (INTEGER, ".eq.", COMPLEX, LOGICAL, "==");
414 MIXED (INTEGER, ".ne.", INTEGER, LOGICAL, "!=");
415 MIXED (INTEGER, ".ne.", REAL, LOGICAL, "!=");
416 MIXED (INTEGER, ".ne.", COMPLEX, LOGICAL, "!=");
417 MIXED (INTEGER, ".le.", INTEGER, LOGICAL, "<=");
418 MIXED (INTEGER, ".le.", REAL, LOGICAL, "<=");
419 MIXED (INTEGER, ".ge.", INTEGER, LOGICAL, ">=");
420 MIXED (INTEGER, ".ge.", REAL, LOGICAL, ">=");
421 MIXED (INTEGER, ".lt.", INTEGER, LOGICAL, "<");
422 MIXED (INTEGER, ".lt.", REAL, LOGICAL, "<");
423 MIXED (INTEGER, ".gt.", INTEGER, LOGICAL, ">");
424 MIXED (INTEGER, ".gt.", REAL, LOGICAL, ">");
425 MIXED (INTEGER, "==", INTEGER, LOGICAL, "==");
426 MIXED (INTEGER, "==", REAL, LOGICAL, "==");
427 MIXED (INTEGER, "==", COMPLEX, LOGICAL, "==");
428 MIXED (INTEGER, "!=", INTEGER, LOGICAL, "!=");
429 MIXED (INTEGER, "!=", REAL, LOGICAL, "!=");
430 MIXED (INTEGER, "!=", COMPLEX, LOGICAL, "!=");
431 MIXED (INTEGER, "<=", INTEGER, LOGICAL, "<=");
432 MIXED (INTEGER, "<=", REAL, LOGICAL, "<=");
433 MIXED (INTEGER, ">=", INTEGER, LOGICAL, ">=");
434 MIXED (INTEGER, ">=", REAL, LOGICAL, ">=");
435 MIXED (INTEGER, "<", INTEGER, LOGICAL, "<");
436 MIXED (INTEGER, "<", REAL, LOGICAL, "<");
437 MIXED (INTEGER, ">", INTEGER, LOGICAL, ">");
438 MIXED (INTEGER, ">", REAL, LOGICAL, ">");
439 //
440 MIXED (REAL, "+", REAL, REAL, "+");
441 MIXED (REAL, "+", COMPLEX, COMPLEX, "+");
442 MIXED (REAL, "-", REAL, REAL, "-");
443 MIXED (REAL, "-", COMPLEX, COMPLEX, "-");
444 MIXED (REAL, "*", REAL, REAL, "*");
445 MIXED (REAL, "*", COMPLEX, COMPLEX, "*");
446 MIXED (REAL, "/", REAL, REAL, "/");
447 MIXED (REAL, "/", COMPLEX, COMPLEX, "/");
448 MIXED (REAL, ".eq.", REAL, LOGICAL, "==");
449 MIXED (REAL, ".eq.", COMPLEX, LOGICAL, "==");
450 MIXED (REAL, ".ne.", REAL, LOGICAL, "!=");
451 MIXED (REAL, ".ne.", COMPLEX, LOGICAL, "!=");
452 MIXED (REAL, ".le.", REAL, LOGICAL, "<=");
453 MIXED (REAL, ".ge.", REAL, LOGICAL, ">=");
454 MIXED (REAL, ".lt.", REAL, LOGICAL, "<");
455 MIXED (REAL, ".gt.", REAL, LOGICAL, ">");
456 MIXED (REAL, "==", REAL, LOGICAL, "==");
457 MIXED (REAL, "==", COMPLEX, LOGICAL, "==");
458 MIXED (REAL, "!=", REAL, LOGICAL, "!=");
459 MIXED (REAL, "!=", COMPLEX, LOGICAL, "!=");
460 MIXED (REAL, "<=", REAL, LOGICAL, "<=");
461 MIXED (REAL, ">=", REAL, LOGICAL, ">=");
462 MIXED (REAL, "<", REAL, LOGICAL, "<");
463 MIXED (REAL, ">", REAL, LOGICAL, ">");
464 //
465 MIXED (COMPLEX, "+", COMPLEX, COMPLEX, "+");
466 MIXED (COMPLEX, "-", COMPLEX, COMPLEX, "-");
467 MIXED (COMPLEX, "*", COMPLEX, COMPLEX, "*");
468 MIXED (COMPLEX, "/", COMPLEX, COMPLEX, "/");
469 MIXED (COMPLEX, ".eq.", COMPLEX, LOGICAL, "==");
470 MIXED (COMPLEX, ".ne.", COMPLEX, LOGICAL, "!=");
471 MIXED (COMPLEX, "==", COMPLEX, LOGICAL, "==");
472 MIXED (COMPLEX, "!=", COMPLEX, LOGICAL, "!=");
473 //
474 LOGIC (LOGICAL, "==", LOGICAL, "==");
475 LOGIC (LOGICAL, "!=", LOGICAL, "!=");
476 LOGIC (LOGICAL, ".eq.", LOGICAL, "==");
477 LOGIC (LOGICAL, ".neq.", LOGICAL, "!=");
478 LOGIC (LOGICAL, ".and.", LOGICAL, "&&");
479 LOGIC (LOGICAL, "&", LOGICAL, "&&");
480 LOGIC (LOGICAL, ".or.", LOGICAL, "||");
481 LOGIC (LOGICAL, "|", LOGICAL, "||");
482 LOGIC (LOGICAL, ".xor.", LOGICAL, "^");
483 LOGIC (LOGICAL, "^", LOGICAL, "^");
484 LOGIC (LOGICAL, ".eqv.", LOGICAL, "==");
485 LOGIC (LOGICAL, ".neqv.", LOGICAL, "^");
486 //
487 OP_ERROR (1411, "undefined operator");
488 }
489 #undef MIXED
490 #undef LOGIC
491 }
492
493 int_4 oper_prio (char *op, int_4 prio)
494 {
495 if (TOKEN (")")) {
496 return FALSE;
497 } else if (TOKEN ("=")) {
498 return FALSE;
499 }
500 // According VAX FORTRAN.
501 switch (prio) {
502 case 1: {
503 return TOKEN (".eqv.") || TOKEN (".neqv.") || TOKEN (".xor.") || TOKEN ("^");
504 }
505 case 2: {
506 return TOKEN (".or.") || TOKEN ("|");
507 }
508 case 3: {
509 return TOKEN (".and.") || TOKEN ("&");
510 }
511 case 4: {
512 return TOKEN (".not.") || TOKEN ("!");
513 }
514 case 5: {
515 return TOKEN (".eq.") || TOKEN (".ne.") ||
516 TOKEN (".lt.") || TOKEN (".le.") ||
517 TOKEN (".gt.") || TOKEN (".ge.") ||
518 TOKEN ("==") || TOKEN ("!=") ||
519 TOKEN ("<") || TOKEN ("<=") ||
520 TOKEN (">") || TOKEN (">=");
521 }
522 case 6: {
523 return TOKEN ("+") || TOKEN ("-") || TOKEN ("//");
524 }
525 case 7: {
526 return TOKEN ("*") || TOKEN ("/") || TOKEN (".mod.") || TOKEN ("*%");
527 }
528 case 8: {
529 return TOKEN ("**");
530 }
531 }
532 return FALSE;
533 }
534
535 void exprio (EXPR * reg, int_4 prio, logical_4 no_dim_var)
536 {
537 if (prio == MAX_PRIO) {
538 if (TOKEN (".not.") || TOKEN ("!")) {
539 _srecordf (reg->str, "TRUE");
540 reg->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
541 reg->variant = EXPR_CONST;
542 UNSCAN;
543 } else {
544 factor (reg);
545 if (no_dim_var && reg->variant == EXPR_VAR) {
546 IDENT *idf = impl_decl (reg->str, NO_MODE);
547 if (idf != NO_IDENT && IS_ROW (idf->mode)) {
548 ERROR (1412, "dimensioned variable cannot be an operand", curlex);
549 }
550 }
551 }
552 } else {
553 int_4 rc;
554 EXPR lhs;
555 memset (&lhs, 0, sizeof (EXPR));
556 //
557 exprio (&lhs, prio + 1, no_dim_var);
558 rc = scan (EXPECT_NONE);
559 while (oper_prio (curlex, prio)) {
560 EXPR rhs;
561 NEW_RECORD (op);
562 memset (&rhs, 0, sizeof (EXPR));
563 RECCPY (op, curlex);
564 rc = scan (EXPECT_NONE);
565 if (prio == MAX_PRIO - 1) {
566 exprio (&rhs, prio, no_dim_var);
567 } else {
568 exprio (&rhs, prio + 1, no_dim_var);
569 }
570 oper (&lhs, &rhs, op);
571 if (lhs.variant == EXPR_CONST && rhs.variant == EXPR_CONST) {
572 ;
573 } else {
574 lhs.variant = EXPR_OTHER;
575 }
576 rc = scan (EXPECT_NONE);
577 }
578 memcpy (reg, &lhs, sizeof (EXPR));
579 UNSCAN;
580 (void) rc;
581 }
582 }
583
584 #undef OP_ERROR
585
586 logical_4 express (EXPR * reg, int_4 expect, int_4 len)
587 {
588 MODE expect_type = (MODE) {.type = expect, .len = len, .dim = 0 };
589 memset (reg, 0, sizeof (EXPR));
590 exprio (reg, 1, FALSE);
591 if (!valid_expr (reg)) {
592 return FALSE;
593 }
594 (void) fold_expr (reg, expect);
595 if (reg->variant == EXPR_CONST && reg->mode.type == INTEGER && expect == INTEGER) {
596 // INTEGER length denotations overlap.
597 factor_integer_number (reg, reg->str);
598 if (reg->mode.len <= len) {
599 reg->mode.len = len;
600 return TRUE;
601 } else {
602 MODE_ERROR (1413, qtype (&(reg->mode)), qtype (&expect_type));
603 return FALSE;
604 }
605 } else if (accept_mode (reg->mode.type, reg->mode.len, expect, len)) {
606 return TRUE;
607 } else {
608 MODE_ERROR (1414, qtype (&(reg->mode)), qtype (&expect_type));
609 return FALSE;
610 }
611 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
