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-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 //! 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 if (lhs->mode.type == INTEGER) {
324 if (lhs->mode.len == 4) {
325 strcpy (proc, "_up_int_4");
326 } else if (lhs->mode.len == 8) {
327 strcpy (proc, "_up_int_8");
328 }
329 } else if (lhs->mode.type == REAL) {
330 if (lhs->mode.len == 4) {
331 strcpy (proc, "_up_real_4");
332 } else if (lhs->mode.len == 8) {
333 strcpy (proc, "_up_real_8");
334 } else if (lhs->mode.len == 16) {
335 strcpy (proc, "_up_real_16");
336 }
337 } else if (lhs->mode.type == COMPLEX) {
338 if (lhs->mode.len == 8) {
339 strcpy (proc, "_up_complex_8");
340 } else if (lhs->mode.len == 16) {
341 strcpy (proc, "_up_complex");
342 } else if (lhs->mode.len == 32) {
343 strcpy (proc, "_up_complex_32");
344 }
345 } else {
346 OP_ERROR (1310, "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 (1311, "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, NULL);
547 if (idf != NULL && idf->mode.dim != 0) {
548 ERROR (1312, "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 (NULL);
559 while (oper_prio (curlex, prio)) {
560 RECORD op;
561 EXPR rhs;
562 RECCLR (op);
563 memset (&rhs, 0, sizeof (EXPR));
564 strcpy (op, curlex);
565 rc = scan (NULL);
566 if (prio == MAX_PRIO - 1) {
567 exprio (&rhs, prio, no_dim_var);
568 } else {
569 exprio (&rhs, prio + 1, no_dim_var);
570 }
571 oper (&lhs, &rhs, op);
572 if (lhs.variant == EXPR_CONST && rhs.variant == EXPR_CONST) {
573 ;
574 } else {
575 lhs.variant = EXPR_OTHER;
576 }
577 rc = scan (NULL);
578 }
579 memcpy (reg, &lhs, sizeof (EXPR));
580 UNSCAN;
581 (void) rc;
582 }
583 }
584
585 #undef OP_ERROR
586
587 int_4 express (EXPR * reg, int_4 expect, int_4 len)
588 {
589 MODE mode = (MODE) {.type = expect,.len = len,.dim = 0 };
590 memset (reg, 0, sizeof (EXPR));
591 exprio (reg, 1, FALSE);
592 if (!valid_expr (reg)) {
593 return FALSE;
594 }
595 (void) fold_expr (reg, expect);
596 if (accept_mode (reg->mode.type, reg->mode.len, expect, len)) {
597 return TRUE;
598 } else {
599 MODE_ERROR (1313, qtype (&(reg->mode)), qtype (&mode));
600 return FALSE;
601 }
602 }
603
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
