expr.c
1 //! @file expr.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 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 int_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 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 (1301, "mixed mode expression");
137 } else {
138 if (EQUAL (op, "+") || EQUAL (op, "//")) {
139 int len;
140 if (lhs->mode.len == 0 || rhs->mode.len == 0) {
141 len = MAX_STRLEN;
142 } else {
143 len = lhs->mode.len + rhs->mode.len;
144 }
145 MODE m = {.type = CHARACTER, .len = (len > MAX_STRLEN ? MAX_STRLEN : len)};
146 norm_mode (&m);
147 RECORD tmp;
148 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
149 add_local (tmp, CHARACTER, m.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
150 _srecordf (lhs->str, "concat (%s, %s, %s)", tmp, lhs->str, rhs->str);
151 lhs->mode = (MODE) {.type = CHARACTER, .len = m.len, .dim = 0};
152 } else if (EQUAL (op, ".eq.") || EQUAL (op, "==")) {
153 _srecordf (lhs->str, "(strcmp (%s, %s) == 0)", lhs->str, rhs->str);
154 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
155 } else if (EQUAL (op, ".ne.") || EQUAL (op, "!=")) {
156 _srecordf (lhs->str, "(strcmp (%s, %s) != 0)", lhs->str, rhs->str);
157 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
158 } else if (EQUAL (op, ".le.") || EQUAL (op, ".lle.") || EQUAL (op, "<=")) {
159 _srecordf (lhs->str, "(strcmp (%s, %s) <= 0)", lhs->str, rhs->str);
160 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
161 } else if (EQUAL (op, ".ge.") || EQUAL (op, ".lge.") || EQUAL (op, ">=")) {
162 _srecordf (lhs->str, "(strcmp (%s, %s) >= 0)", lhs->str, rhs->str);
163 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
164 } else if (EQUAL (op, ".lt.") || EQUAL (op, ".llt.") || EQUAL (op, "<")) {
165 _srecordf (lhs->str, "(strcmp (%s, %s) < 0)", lhs->str, rhs->str);
166 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
167 } else if (EQUAL (op, ".gt.") || EQUAL (op, ".lgt.") || EQUAL (op, ">")) {
168 _srecordf (lhs->str, "(strcmp (%s, %s) > 0)", lhs->str, rhs->str);
169 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};
170 } else {
171 OP_ERROR (1302, "undefined operator");
172 }
173 }
174 }
175
176 static void oper_real_32 (EXPR * lhs, EXPR * rhs, char *op)
177 {
178 if (TYPE (lhs, REAL, 32)) {
179 if (TYPE (rhs, REAL, 32)) {
180 /* Ok */;
181 } else if (rhs->mode.type == REAL || rhs->mode.type == INTEGER) {
182 RECORD tmp;
183 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
184 add_local (tmp, REAL, 32, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
185 _srecordf (rhs->str, "_quadtop (&%s, %s)", tmp, rhs->str);
186 rhs->mode = (MODE) {.type = REAL, .len = 32, .dim = 0};
187 }
188 } else if (TYPE (rhs, REAL, 32)) {
189 if (TYPE (lhs, REAL, 32)) {
190 /* Ok */;
191 } else if (lhs->mode.type == REAL || lhs->mode.type == INTEGER) {
192 RECORD tmp;
193 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
194 add_local (tmp, REAL, 32, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
195 _srecordf (lhs->str, "_quadtop (&%s, %s)", tmp, lhs->str);
196 lhs->mode = (MODE) {.type = REAL, .len = 32, .dim = 0};
197 }
198 }
199 if (lhs->mode.type != rhs->mode.type) {
200 OP_ERROR (1303, "undefined operator");
201 } else if (lhs->mode.len != rhs->mode.len) {
202 OP_ERROR (1304, "undefined operator");
203 } else if (EQUAL (op, "+")) {
204 _srecordf (lhs->str, "xsum (%s, %s)", lhs->str, rhs->str);
205 } else if (EQUAL (op, "-")) {
206 _srecordf (lhs->str, "xsub (%s, %s)", lhs->str, rhs->str);
207 } else if (EQUAL (op, "*")) {
208 _srecordf (lhs->str, "xmul (%s, %s)", lhs->str, rhs->str);
209 } else if (EQUAL (op, "/")) {
210 _srecordf (lhs->str, "xdiv (%s, %s)", lhs->str, rhs->str);
211 } else if (EQUAL (op, ".eq.") || EQUAL (op, "==")) {
212 _srecordf (lhs->str, "xeq (%s, %s)", lhs->str, rhs->str);
213 lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
214 } else if (EQUAL (op, ".ne.") || EQUAL (op, "!=")) {
215 _srecordf (lhs->str, "xneq (%s, %s)", lhs->str, rhs->str);
216 lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
217 } else if (EQUAL (op, ".le.") || EQUAL (op, "<=")) {
218 _srecordf (lhs->str, "xle (%s, %s)", lhs->str, rhs->str);
219 lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
220 } else if (EQUAL (op, ".lt.") || EQUAL (op, "<")) {
221 _srecordf (lhs->str, "xlt (%s, %s)", lhs->str, rhs->str);
222 lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
223 } else if (EQUAL (op, ".ge.") || EQUAL (op, ">=")) {
224 _srecordf (lhs->str, "xge (%s, %s)", lhs->str, rhs->str);
225 lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
226 } else if (EQUAL (op, ".gt.") || EQUAL (op, ">")) {
227 _srecordf (lhs->str, "xgt (%s, %s)", lhs->str, rhs->str);
228 lhs->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
229 } else {
230 OP_ERROR (1305, "undefined operator");
231 }
232 }
233
234 static void oper_complex_64 (EXPR * lhs, EXPR * rhs, char *op)
235 {
236 if (TYPE (lhs, COMPLEX, 64)) {
237 if (TYPE (rhs, COMPLEX, 64)) {
238 /* Ok */;
239 } else if (TYPE (rhs, REAL, 32)) {
240 RECORD tmp;
241 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
242 add_local (tmp, COMPLEX, 64, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
243 _srecordf (rhs->str, "_coctotop (&%s, %s)", tmp, rhs->str);
244 rhs->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
245 } else if (rhs->mode.type == INTEGER || rhs->mode.type == REAL) {
246 RECORD tmp;
247 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
248 add_local (tmp, COMPLEX, 64, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
249 _srecordf (rhs->str, "_cquadtop (&%s, %s)", tmp, rhs->str);
250 rhs->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
251 }
252 } else if (TYPE (rhs, COMPLEX, 64)) {
253 if (TYPE (lhs, REAL, 32)) {
254 RECORD tmp;
255 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
256 add_local (tmp, COMPLEX, 64, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
257 _srecordf (lhs->str, "_coctotop (&%s, %s)", tmp, lhs->str);
258 lhs->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
259 } else if (lhs->mode.type == INTEGER || lhs->mode.type == REAL) {
260 RECORD tmp;
261 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
262 add_local (tmp, COMPLEX, 64, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
263 _srecordf (lhs->str, "_cquadtop (&%s, %s)", tmp, lhs->str);
264 lhs->mode = (MODE) {.type = COMPLEX, .len = 64, .dim = 0};
265 }
266 }
267 if (lhs->mode.type != rhs->mode.type) {
268 OP_ERROR (1306, "undefined operator");
269 } else if (lhs->mode.len != rhs->mode.len) {
270 OP_ERROR (1307, "undefined operator");
271 } else if (EQUAL (op, "+")) {
272 _srecordf (lhs->str, "cxsum (%s, %s)", lhs->str, rhs->str);
273 } else if (EQUAL (op, "-")) {
274 _srecordf (lhs->str, "cxsub (%s, %s)", lhs->str, rhs->str);
275 } else if (EQUAL (op, "*")) {
276 _srecordf (lhs->str, "cxmul (%s, %s)", lhs->str, rhs->str);
277 } else if (EQUAL (op, "/")) {
278 _srecordf (lhs->str, "cxdiv (%s, %s)", lhs->str, rhs->str);
279 } else if (EQUAL (op, ".eq.")) {
280 _srecordf (lhs->str, "cxeq (%s, %s)", lhs->str, rhs->str);
281 } else if (EQUAL (op, ".ne.")) {
282 _srecordf (lhs->str, "cxneq (%s, %s)", lhs->str, rhs->str);
283 } else {
284 OP_ERROR (1308, "undefined operator");
285 }
286 }
287
288 int_4 mix_len (EXPR * lhs, EXPR * rhs)
289 {
290 return _max (lhs->mode.len, rhs->mode.len);
291 }
292
293 void power (EXPR * lhs, EXPR * rhs, char *op)
294 {
295 RECORD str;
296 RECCLR (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 (1309, "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 strcpy (lhs->str, str);
320 return;
321 } else {
322 RECORD proc;
323 RECCLR (proc);
324 if (lhs->mode.type == INTEGER) {
325 if (lhs->mode.len == 4) {
326 strcpy (proc, "_up_int_4");
327 } else if (lhs->mode.len == 8) {
328 strcpy (proc, "_up_int_8");
329 }
330 } else if (lhs->mode.type == REAL) {
331 if (lhs->mode.len == 4) {
332 strcpy (proc, "_up_real_4");
333 } else if (lhs->mode.len == 8) {
334 strcpy (proc, "_up_real_8");
335 } else if (lhs->mode.len == 16) {
336 strcpy (proc, "_up_real_16");
337 }
338 } else if (lhs->mode.type == COMPLEX) {
339 if (lhs->mode.len == 8) {
340 strcpy (proc, "_up_complex_8");
341 } else if (lhs->mode.len == 16) {
342 strcpy (proc, "_up_complex");
343 } else if (lhs->mode.len == 32) {
344 strcpy (proc, "_up_complex_32");
345 }
346 } else {
347 OP_ERROR (1310, "not an arithmetic operand");
348 }
349 _srecordf (lhs->str, "%s (%s, %s)", proc, lhs->str, rhs->str);
350 return;
351 }
352 }
353 }
354
355 void oper (EXPR * lhs, EXPR * rhs, char *op)
356 {
357 //
358 if (lhs->mode.type == ETYPE || rhs->mode.type == ETYPE) {
359 lhs->mode.type = ETYPE;
360 return;
361 }
362 //
363 if (EQUAL (op, ".not.") || EQUAL (op, "!")) {
364 _srecordf (lhs->str, "! (%s)", rhs->str);\
365 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};\
366 return;
367 }
368 //
369 #define MIXED(p, f_op, q, r, c_op) {\
370 if ((lhs->mode.type == (p) && rhs->mode.type == (q)) ||\
371 (lhs->mode.type == (q) && rhs->mode.type == (p))) {\
372 if (EQUAL (op, f_op)) {\
373 _srecordf (lhs->str, "%s %s %s", lhs->str, c_op, rhs->str);\
374 lhs->mode = (MODE) {.type = r, .len = mix_len (lhs, rhs), .dim = 0};\
375 return;\
376 }\
377 }}
378 //
379 #define LOGIC(p, f_op, q, c_op) {\
380 if ((lhs->mode.type == (p) && rhs->mode.type == (q)) ||\
381 (lhs->mode.type == (q) && rhs->mode.type == (p))) {\
382 if (EQUAL (op, f_op)) {\
383 _srecordf (lhs->str, "%s %s %s", lhs->str, c_op, rhs->str);\
384 lhs->mode = (MODE) {.type = LOGICAL, .len = 4, .dim = 0};\
385 return;\
386 }\
387 }}
388 //
389 if (lhs->mode.type == CHARACTER) {
390 oper_char (lhs, rhs, op);
391 } else if ((TYPE (lhs, COMPLEX, 64)) || (TYPE (rhs, COMPLEX, 64))) {
392 oper_complex_64 (lhs, rhs, op);
393 } else if ((TYPE (lhs, REAL, 32)) || (TYPE (rhs, REAL, 32))) {
394 oper_real_32 (lhs, rhs, op);
395 } else if (EQUAL (op, "**")) {
396 power (lhs, rhs, op);
397 } else {
398 MIXED (INTEGER, "+", INTEGER, INTEGER, "+");
399 MIXED (INTEGER, "+", REAL, REAL, "+");
400 MIXED (INTEGER, "+", COMPLEX, COMPLEX, "+");
401 MIXED (INTEGER, "-", INTEGER, INTEGER, "-");
402 MIXED (INTEGER, "-", REAL, REAL, "-");
403 MIXED (INTEGER, "-", COMPLEX, COMPLEX, "-");
404 MIXED (INTEGER, "*", INTEGER, INTEGER, "*");
405 MIXED (INTEGER, "*", REAL, REAL, "*");
406 MIXED (INTEGER, "*", COMPLEX, COMPLEX, "*");
407 MIXED (INTEGER, "/", INTEGER, INTEGER, "/");
408 MIXED (INTEGER, ".mod.", INTEGER, INTEGER, "%");
409 MIXED (INTEGER, "*%", INTEGER, INTEGER, "%");
410 MIXED (INTEGER, "/", REAL, REAL, "/");
411 MIXED (INTEGER, "/", COMPLEX, COMPLEX, "/");
412 MIXED (INTEGER, ".eq.", INTEGER, LOGICAL, "==");
413 MIXED (INTEGER, ".eq.", REAL, LOGICAL, "==");
414 MIXED (INTEGER, ".eq.", COMPLEX, LOGICAL, "==");
415 MIXED (INTEGER, ".ne.", INTEGER, LOGICAL, "!=");
416 MIXED (INTEGER, ".ne.", REAL, LOGICAL, "!=");
417 MIXED (INTEGER, ".ne.", COMPLEX, LOGICAL, "!=");
418 MIXED (INTEGER, ".le.", INTEGER, LOGICAL, "<=");
419 MIXED (INTEGER, ".le.", REAL, LOGICAL, "<=");
420 MIXED (INTEGER, ".ge.", INTEGER, LOGICAL, ">=");
421 MIXED (INTEGER, ".ge.", REAL, LOGICAL, ">=");
422 MIXED (INTEGER, ".lt.", INTEGER, LOGICAL, "<");
423 MIXED (INTEGER, ".lt.", REAL, LOGICAL, "<");
424 MIXED (INTEGER, ".gt.", INTEGER, LOGICAL, ">");
425 MIXED (INTEGER, ".gt.", REAL, LOGICAL, ">");
426 MIXED (INTEGER, "==", INTEGER, LOGICAL, "==");
427 MIXED (INTEGER, "==", REAL, LOGICAL, "==");
428 MIXED (INTEGER, "==", COMPLEX, LOGICAL, "==");
429 MIXED (INTEGER, "!=", INTEGER, LOGICAL, "!=");
430 MIXED (INTEGER, "!=", REAL, LOGICAL, "!=");
431 MIXED (INTEGER, "!=", COMPLEX, LOGICAL, "!=");
432 MIXED (INTEGER, "<=", INTEGER, LOGICAL, "<=");
433 MIXED (INTEGER, "<=", REAL, LOGICAL, "<=");
434 MIXED (INTEGER, ">=", INTEGER, LOGICAL, ">=");
435 MIXED (INTEGER, ">=", REAL, LOGICAL, ">=");
436 MIXED (INTEGER, "<", INTEGER, LOGICAL, "<");
437 MIXED (INTEGER, "<", REAL, LOGICAL, "<");
438 MIXED (INTEGER, ">", INTEGER, LOGICAL, ">");
439 MIXED (INTEGER, ">", REAL, LOGICAL, ">");
440 //
441 MIXED (REAL, "+", REAL, REAL, "+");
442 MIXED (REAL, "+", COMPLEX, COMPLEX, "+");
443 MIXED (REAL, "-", REAL, REAL, "-");
444 MIXED (REAL, "-", COMPLEX, COMPLEX, "-");
445 MIXED (REAL, "*", REAL, REAL, "*");
446 MIXED (REAL, "*", COMPLEX, COMPLEX, "*");
447 MIXED (REAL, "/", REAL, REAL, "/");
448 MIXED (REAL, "/", COMPLEX, COMPLEX, "/");
449 MIXED (REAL, ".eq.", REAL, LOGICAL, "==");
450 MIXED (REAL, ".eq.", COMPLEX, LOGICAL, "==");
451 MIXED (REAL, ".ne.", REAL, LOGICAL, "!=");
452 MIXED (REAL, ".ne.", COMPLEX, LOGICAL, "!=");
453 MIXED (REAL, ".le.", REAL, LOGICAL, "<=");
454 MIXED (REAL, ".ge.", REAL, LOGICAL, ">=");
455 MIXED (REAL, ".lt.", REAL, LOGICAL, "<");
456 MIXED (REAL, ".gt.", REAL, LOGICAL, ">");
457 MIXED (REAL, "==", REAL, LOGICAL, "==");
458 MIXED (REAL, "==", COMPLEX, LOGICAL, "==");
459 MIXED (REAL, "!=", REAL, LOGICAL, "!=");
460 MIXED (REAL, "!=", COMPLEX, LOGICAL, "!=");
461 MIXED (REAL, "<=", REAL, LOGICAL, "<=");
462 MIXED (REAL, ">=", REAL, LOGICAL, ">=");
463 MIXED (REAL, "<", REAL, LOGICAL, "<");
464 MIXED (REAL, ">", REAL, LOGICAL, ">");
465 //
466 MIXED (COMPLEX, "+", COMPLEX, COMPLEX, "+");
467 MIXED (COMPLEX, "-", COMPLEX, COMPLEX, "-");
468 MIXED (COMPLEX, "*", COMPLEX, COMPLEX, "*");
469 MIXED (COMPLEX, "/", COMPLEX, COMPLEX, "/");
470 MIXED (COMPLEX, ".eq.", COMPLEX, LOGICAL, "==");
471 MIXED (COMPLEX, ".ne.", COMPLEX, LOGICAL, "!=");
472 MIXED (COMPLEX, "==", COMPLEX, LOGICAL, "==");
473 MIXED (COMPLEX, "!=", COMPLEX, LOGICAL, "!=");
474 //
475 LOGIC (LOGICAL, "==", LOGICAL, "==");
476 LOGIC (LOGICAL, "!=", LOGICAL, "!=");
477 LOGIC (LOGICAL, ".eq.", LOGICAL, "==");
478 LOGIC (LOGICAL, ".neq.", LOGICAL, "!=");
479 LOGIC (LOGICAL, ".and.", LOGICAL, "&&");
480 LOGIC (LOGICAL, "&", LOGICAL, "&&");
481 LOGIC (LOGICAL, ".or.", LOGICAL, "||");
482 LOGIC (LOGICAL, "|", LOGICAL, "||");
483 LOGIC (LOGICAL, ".xor.", LOGICAL, "^");
484 LOGIC (LOGICAL, "^", LOGICAL, "^");
485 LOGIC (LOGICAL, ".eqv.", LOGICAL, "==");
486 LOGIC (LOGICAL, ".neqv.", LOGICAL, "^");
487 //
488 OP_ERROR (1311, "undefined operator");
489 }
490 #undef MIXED
491 #undef LOGIC
492 }
493
494 int_4 oper_prio (char *op, int_4 prio)
495 {
496 if (TOKEN (")")) {
497 return FALSE;
498 } else if (TOKEN ("=")) {
499 return FALSE;
500 }
501 // According VAX FORTRAN.
502 switch (prio) {
503 case 1: {
504 return TOKEN (".eqv.") || TOKEN (".neqv.") || TOKEN (".xor.") || TOKEN ("^");
505 }
506 case 2: {
507 return TOKEN (".or.") || TOKEN ("|");
508 }
509 case 3: {
510 return TOKEN (".and.") || TOKEN ("&");
511 }
512 case 4: {
513 return TOKEN (".not.") || TOKEN ("!");
514 }
515 case 5: {
516 return TOKEN (".eq.") || TOKEN (".ne.") ||
517 TOKEN (".lt.") || TOKEN (".le.") ||
518 TOKEN (".gt.") || TOKEN (".ge.") ||
519 TOKEN ("==") || TOKEN ("!=") ||
520 TOKEN ("<") || TOKEN ("<=") ||
521 TOKEN (">") || TOKEN (">=");
522 }
523 case 6: {
524 return TOKEN ("+") || TOKEN ("-") || TOKEN ("//");
525 }
526 case 7: {
527 return TOKEN ("*") || TOKEN ("/") || TOKEN (".mod.") || TOKEN ("*%");
528 }
529 case 8: {
530 return TOKEN ("**");
531 }
532 }
533 return FALSE;
534 }
535
536 void exprio (EXPR * reg, int_4 prio, logical_4 no_dim_var)
537 {
538 if (prio == MAX_PRIO) {
539 if (TOKEN (".not.") || TOKEN ("!")) {
540 _srecordf (reg->str, "TRUE");
541 reg->mode = (MODE) {.type = LOGICAL,.len = 4,.dim = 0};
542 reg->variant = EXPR_CONST;
543 UNSCAN;
544 } else {
545 factor (reg);
546 if (no_dim_var && reg->variant == EXPR_VAR) {
547 IDENT *idf = impl_decl (reg->str, NO_MODE);
548 if (idf != NO_IDENT && IS_ROW (idf->mode)) {
549 ERROR (1312, "dimensioned variable cannot be an operand", curlex);
550 }
551 }
552 }
553 } else {
554 int_4 rc;
555 EXPR lhs;
556 memset (&lhs, 0, sizeof (EXPR));
557 //
558 exprio (&lhs, prio + 1, no_dim_var);
559 rc = scan (EXPECT_NONE);
560 while (oper_prio (curlex, prio)) {
561 RECORD op;
562 EXPR rhs;
563 RECCLR (op);
564 memset (&rhs, 0, sizeof (EXPR));
565 strcpy (op, curlex);
566 rc = scan (EXPECT_NONE);
567 if (prio == MAX_PRIO - 1) {
568 exprio (&rhs, prio, no_dim_var);
569 } else {
570 exprio (&rhs, prio + 1, no_dim_var);
571 }
572 oper (&lhs, &rhs, op);
573 if (lhs.variant == EXPR_CONST && rhs.variant == EXPR_CONST) {
574 ;
575 } else {
576 lhs.variant = EXPR_OTHER;
577 }
578 rc = scan (EXPECT_NONE);
579 }
580 memcpy (reg, &lhs, sizeof (EXPR));
581 UNSCAN;
582 (void) rc;
583 }
584 }
585
586 #undef OP_ERROR
587
588 int_4 express (EXPR * reg, int_4 expect, int_4 len)
589 {
590 MODE expect_type = (MODE) {.type = expect, .len = len, .dim = 0 };
591 memset (reg, 0, sizeof (EXPR));
592 exprio (reg, 1, FALSE);
593 if (!valid_expr (reg)) {
594 return FALSE;
595 }
596 (void) fold_expr (reg, expect);
597 if (reg->variant == EXPR_CONST && reg->mode.type == INTEGER && expect == INTEGER) {
598 // INTEGER length denotations overlap.
599 factor_integer_number (reg, reg->str);
600 if (reg->mode.len <= len) {
601 reg->mode.len = len;
602 return TRUE;
603 } else {
604 MODE_ERROR (1313, qtype (&(reg->mode)), qtype (&expect_type));
605 return FALSE;
606 }
607 } else if (accept_mode (reg->mode.type, reg->mode.len, expect, len)) {
608 return TRUE;
609 } else {
610 MODE_ERROR (1314, qtype (&(reg->mode)), qtype (&expect_type));
611 return FALSE;
612 }
613 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
