|
111
|
1 /* Expression parser.
|
|
|
2 Copyright (C) 2000-2017 Free Software Foundation, Inc.
|
|
|
3 Contributed by Andy Vaught
|
|
|
4
|
|
|
5 This file is part of GCC.
|
|
|
6
|
|
|
7 GCC is free software; you can redistribute it and/or modify it under
|
|
|
8 the terms of the GNU General Public License as published by the Free
|
|
|
9 Software Foundation; either version 3, or (at your option) any later
|
|
|
10 version.
|
|
|
11
|
|
|
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
|
|
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
|
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
|
|
15 for more details.
|
|
|
16
|
|
|
17 You should have received a copy of the GNU General Public License
|
|
|
18 along with GCC; see the file COPYING3. If not see
|
|
|
19 <http://www.gnu.org/licenses/>. */
|
|
|
20
|
|
|
21 #include "config.h"
|
|
|
22 #include "system.h"
|
|
|
23 #include "coretypes.h"
|
|
|
24 #include "gfortran.h"
|
|
|
25 #include "arith.h"
|
|
|
26 #include "match.h"
|
|
|
27
|
|
|
28 static const char expression_syntax[] = N_("Syntax error in expression at %C");
|
|
|
29
|
|
|
30
|
|
|
31 /* Match a user-defined operator name. This is a normal name with a
|
|
|
32 few restrictions. The error_flag controls whether an error is
|
|
|
33 raised if 'true' or 'false' are used or not. */
|
|
|
34
|
|
|
35 match
|
|
|
36 gfc_match_defined_op_name (char *result, int error_flag)
|
|
|
37 {
|
|
|
38 static const char * const badops[] = {
|
|
|
39 "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
|
|
|
40 NULL
|
|
|
41 };
|
|
|
42
|
|
|
43 char name[GFC_MAX_SYMBOL_LEN + 1];
|
|
|
44 locus old_loc;
|
|
|
45 match m;
|
|
|
46 int i;
|
|
|
47
|
|
|
48 old_loc = gfc_current_locus;
|
|
|
49
|
|
|
50 m = gfc_match (" . %n .", name);
|
|
|
51 if (m != MATCH_YES)
|
|
|
52 return m;
|
|
|
53
|
|
|
54 /* .true. and .false. have interpretations as constants. Trying to
|
|
|
55 use these as operators will fail at a later time. */
|
|
|
56
|
|
|
57 if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0)
|
|
|
58 {
|
|
|
59 if (error_flag)
|
|
|
60 goto error;
|
|
|
61 gfc_current_locus = old_loc;
|
|
|
62 return MATCH_NO;
|
|
|
63 }
|
|
|
64
|
|
|
65 for (i = 0; badops[i]; i++)
|
|
|
66 if (strcmp (badops[i], name) == 0)
|
|
|
67 goto error;
|
|
|
68
|
|
|
69 for (i = 0; name[i]; i++)
|
|
|
70 if (!ISALPHA (name[i]))
|
|
|
71 {
|
|
|
72 gfc_error ("Bad character %qc in OPERATOR name at %C", name[i]);
|
|
|
73 return MATCH_ERROR;
|
|
|
74 }
|
|
|
75
|
|
|
76 strcpy (result, name);
|
|
|
77 return MATCH_YES;
|
|
|
78
|
|
|
79 error:
|
|
|
80 gfc_error ("The name %qs cannot be used as a defined operator at %C",
|
|
|
81 name);
|
|
|
82
|
|
|
83 gfc_current_locus = old_loc;
|
|
|
84 return MATCH_ERROR;
|
|
|
85 }
|
|
|
86
|
|
|
87
|
|
|
88 /* Match a user defined operator. The symbol found must be an
|
|
|
89 operator already. */
|
|
|
90
|
|
|
91 static match
|
|
|
92 match_defined_operator (gfc_user_op **result)
|
|
|
93 {
|
|
|
94 char name[GFC_MAX_SYMBOL_LEN + 1];
|
|
|
95 match m;
|
|
|
96
|
|
|
97 m = gfc_match_defined_op_name (name, 0);
|
|
|
98 if (m != MATCH_YES)
|
|
|
99 return m;
|
|
|
100
|
|
|
101 *result = gfc_get_uop (name);
|
|
|
102 return MATCH_YES;
|
|
|
103 }
|
|
|
104
|
|
|
105
|
|
|
106 /* Check to see if the given operator is next on the input. If this
|
|
|
107 is not the case, the parse pointer remains where it was. */
|
|
|
108
|
|
|
109 static int
|
|
|
110 next_operator (gfc_intrinsic_op t)
|
|
|
111 {
|
|
|
112 gfc_intrinsic_op u;
|
|
|
113 locus old_loc;
|
|
|
114
|
|
|
115 old_loc = gfc_current_locus;
|
|
|
116 if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u)
|
|
|
117 return 1;
|
|
|
118
|
|
|
119 gfc_current_locus = old_loc;
|
|
|
120 return 0;
|
|
|
121 }
|
|
|
122
|
|
|
123
|
|
|
124 /* Call the INTRINSIC_PARENTHESES function. This is both
|
|
|
125 used explicitly, as below, or by resolve.c to generate
|
|
|
126 temporaries. */
|
|
|
127
|
|
|
128 gfc_expr *
|
|
|
129 gfc_get_parentheses (gfc_expr *e)
|
|
|
130 {
|
|
|
131 gfc_expr *e2;
|
|
|
132
|
|
|
133 e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL);
|
|
|
134 e2->ts = e->ts;
|
|
|
135 e2->rank = e->rank;
|
|
|
136
|
|
|
137 return e2;
|
|
|
138 }
|
|
|
139
|
|
|
140
|
|
|
141 /* Match a primary expression. */
|
|
|
142
|
|
|
143 static match
|
|
|
144 match_primary (gfc_expr **result)
|
|
|
145 {
|
|
|
146 match m;
|
|
|
147 gfc_expr *e;
|
|
|
148
|
|
|
149 m = gfc_match_literal_constant (result, 0);
|
|
|
150 if (m != MATCH_NO)
|
|
|
151 return m;
|
|
|
152
|
|
|
153 m = gfc_match_array_constructor (result);
|
|
|
154 if (m != MATCH_NO)
|
|
|
155 return m;
|
|
|
156
|
|
|
157 m = gfc_match_rvalue (result);
|
|
|
158 if (m != MATCH_NO)
|
|
|
159 return m;
|
|
|
160
|
|
|
161 /* Match an expression in parentheses. */
|
|
|
162 if (gfc_match_char ('(') != MATCH_YES)
|
|
|
163 return MATCH_NO;
|
|
|
164
|
|
|
165 m = gfc_match_expr (&e);
|
|
|
166 if (m == MATCH_NO)
|
|
|
167 goto syntax;
|
|
|
168 if (m == MATCH_ERROR)
|
|
|
169 return m;
|
|
|
170
|
|
|
171 m = gfc_match_char (')');
|
|
|
172 if (m == MATCH_NO)
|
|
|
173 gfc_error ("Expected a right parenthesis in expression at %C");
|
|
|
174
|
|
|
175 /* Now we have the expression inside the parentheses, build the
|
|
|
176 expression pointing to it. By 7.1.7.2, any expression in
|
|
|
177 parentheses shall be treated as a data entity. */
|
|
|
178 *result = gfc_get_parentheses (e);
|
|
|
179
|
|
|
180 if (m != MATCH_YES)
|
|
|
181 {
|
|
|
182 gfc_free_expr (*result);
|
|
|
183 return MATCH_ERROR;
|
|
|
184 }
|
|
|
185
|
|
|
186 return MATCH_YES;
|
|
|
187
|
|
|
188 syntax:
|
|
|
189 gfc_error (expression_syntax);
|
|
|
190 return MATCH_ERROR;
|
|
|
191 }
|
|
|
192
|
|
|
193
|
|
|
194 /* Match a level 1 expression. */
|
|
|
195
|
|
|
196 static match
|
|
|
197 match_level_1 (gfc_expr **result)
|
|
|
198 {
|
|
|
199 gfc_user_op *uop;
|
|
|
200 gfc_expr *e, *f;
|
|
|
201 locus where;
|
|
|
202 match m;
|
|
|
203
|
|
|
204 gfc_gobble_whitespace ();
|
|
|
205 where = gfc_current_locus;
|
|
|
206 uop = NULL;
|
|
|
207 m = match_defined_operator (&uop);
|
|
|
208 if (m == MATCH_ERROR)
|
|
|
209 return m;
|
|
|
210
|
|
|
211 m = match_primary (&e);
|
|
|
212 if (m != MATCH_YES)
|
|
|
213 return m;
|
|
|
214
|
|
|
215 if (uop == NULL)
|
|
|
216 *result = e;
|
|
|
217 else
|
|
|
218 {
|
|
|
219 f = gfc_get_operator_expr (&where, INTRINSIC_USER, e, NULL);
|
|
|
220 f->value.op.uop = uop;
|
|
|
221 *result = f;
|
|
|
222 }
|
|
|
223
|
|
|
224 return MATCH_YES;
|
|
|
225 }
|
|
|
226
|
|
|
227
|
|
|
228 /* As a GNU extension we support an expanded level-2 expression syntax.
|
|
|
229 Via this extension we support (arbitrary) nesting of unary plus and
|
|
|
230 minus operations following unary and binary operators, such as **.
|
|
|
231 The grammar of section 7.1.1.3 is effectively rewritten as:
|
|
|
232
|
|
|
233 R704 mult-operand is level-1-expr [ power-op ext-mult-operand ]
|
|
|
234 R704' ext-mult-operand is add-op ext-mult-operand
|
|
|
235 or mult-operand
|
|
|
236 R705 add-operand is add-operand mult-op ext-mult-operand
|
|
|
237 or mult-operand
|
|
|
238 R705' ext-add-operand is add-op ext-add-operand
|
|
|
239 or add-operand
|
|
|
240 R706 level-2-expr is [ level-2-expr ] add-op ext-add-operand
|
|
|
241 or add-operand
|
|
|
242 */
|
|
|
243
|
|
|
244 static match match_ext_mult_operand (gfc_expr **result);
|
|
|
245 static match match_ext_add_operand (gfc_expr **result);
|
|
|
246
|
|
|
247 static int
|
|
|
248 match_add_op (void)
|
|
|
249 {
|
|
|
250 if (next_operator (INTRINSIC_MINUS))
|
|
|
251 return -1;
|
|
|
252 if (next_operator (INTRINSIC_PLUS))
|
|
|
253 return 1;
|
|
|
254 return 0;
|
|
|
255 }
|
|
|
256
|
|
|
257
|
|
|
258 static match
|
|
|
259 match_mult_operand (gfc_expr **result)
|
|
|
260 {
|
|
|
261 /* Workaround -Wmaybe-uninitialized false positive during
|
|
|
262 profiledbootstrap by initializing them. */
|
|
|
263 gfc_expr *e = NULL, *exp, *r;
|
|
|
264 locus where;
|
|
|
265 match m;
|
|
|
266
|
|
|
267 m = match_level_1 (&e);
|
|
|
268 if (m != MATCH_YES)
|
|
|
269 return m;
|
|
|
270
|
|
|
271 if (!next_operator (INTRINSIC_POWER))
|
|
|
272 {
|
|
|
273 *result = e;
|
|
|
274 return MATCH_YES;
|
|
|
275 }
|
|
|
276
|
|
|
277 where = gfc_current_locus;
|
|
|
278
|
|
|
279 m = match_ext_mult_operand (&exp);
|
|
|
280 if (m == MATCH_NO)
|
|
|
281 gfc_error ("Expected exponent in expression at %C");
|
|
|
282 if (m != MATCH_YES)
|
|
|
283 {
|
|
|
284 gfc_free_expr (e);
|
|
|
285 return MATCH_ERROR;
|
|
|
286 }
|
|
|
287
|
|
|
288 r = gfc_power (e, exp);
|
|
|
289 if (r == NULL)
|
|
|
290 {
|
|
|
291 gfc_free_expr (e);
|
|
|
292 gfc_free_expr (exp);
|
|
|
293 return MATCH_ERROR;
|
|
|
294 }
|
|
|
295
|
|
|
296 r->where = where;
|
|
|
297 *result = r;
|
|
|
298
|
|
|
299 return MATCH_YES;
|
|
|
300 }
|
|
|
301
|
|
|
302
|
|
|
303 static match
|
|
|
304 match_ext_mult_operand (gfc_expr **result)
|
|
|
305 {
|
|
|
306 gfc_expr *all, *e;
|
|
|
307 locus where;
|
|
|
308 match m;
|
|
|
309 int i;
|
|
|
310
|
|
|
311 where = gfc_current_locus;
|
|
|
312 i = match_add_op ();
|
|
|
313
|
|
|
314 if (i == 0)
|
|
|
315 return match_mult_operand (result);
|
|
|
316
|
|
|
317 if (gfc_notification_std (GFC_STD_GNU) == ERROR)
|
|
|
318 {
|
|
|
319 gfc_error ("Extension: Unary operator following "
|
|
|
320 "arithmetic operator (use parentheses) at %C");
|
|
|
321 return MATCH_ERROR;
|
|
|
322 }
|
|
|
323 else
|
|
|
324 gfc_warning (0, "Extension: Unary operator following "
|
|
|
325 "arithmetic operator (use parentheses) at %C");
|
|
|
326
|
|
|
327 m = match_ext_mult_operand (&e);
|
|
|
328 if (m != MATCH_YES)
|
|
|
329 return m;
|
|
|
330
|
|
|
331 if (i == -1)
|
|
|
332 all = gfc_uminus (e);
|
|
|
333 else
|
|
|
334 all = gfc_uplus (e);
|
|
|
335
|
|
|
336 if (all == NULL)
|
|
|
337 {
|
|
|
338 gfc_free_expr (e);
|
|
|
339 return MATCH_ERROR;
|
|
|
340 }
|
|
|
341
|
|
|
342 all->where = where;
|
|
|
343 *result = all;
|
|
|
344 return MATCH_YES;
|
|
|
345 }
|
|
|
346
|
|
|
347
|
|
|
348 static match
|
|
|
349 match_add_operand (gfc_expr **result)
|
|
|
350 {
|
|
|
351 gfc_expr *all, *e, *total;
|
|
|
352 locus where, old_loc;
|
|
|
353 match m;
|
|
|
354 gfc_intrinsic_op i;
|
|
|
355
|
|
|
356 m = match_mult_operand (&all);
|
|
|
357 if (m != MATCH_YES)
|
|
|
358 return m;
|
|
|
359
|
|
|
360 for (;;)
|
|
|
361 {
|
|
|
362 /* Build up a string of products or quotients. */
|
|
|
363
|
|
|
364 old_loc = gfc_current_locus;
|
|
|
365
|
|
|
366 if (next_operator (INTRINSIC_TIMES))
|
|
|
367 i = INTRINSIC_TIMES;
|
|
|
368 else
|
|
|
369 {
|
|
|
370 if (next_operator (INTRINSIC_DIVIDE))
|
|
|
371 i = INTRINSIC_DIVIDE;
|
|
|
372 else
|
|
|
373 break;
|
|
|
374 }
|
|
|
375
|
|
|
376 where = gfc_current_locus;
|
|
|
377
|
|
|
378 m = match_ext_mult_operand (&e);
|
|
|
379 if (m == MATCH_NO)
|
|
|
380 {
|
|
|
381 gfc_current_locus = old_loc;
|
|
|
382 break;
|
|
|
383 }
|
|
|
384
|
|
|
385 if (m == MATCH_ERROR)
|
|
|
386 {
|
|
|
387 gfc_free_expr (all);
|
|
|
388 return MATCH_ERROR;
|
|
|
389 }
|
|
|
390
|
|
|
391 if (i == INTRINSIC_TIMES)
|
|
|
392 total = gfc_multiply (all, e);
|
|
|
393 else
|
|
|
394 total = gfc_divide (all, e);
|
|
|
395
|
|
|
396 if (total == NULL)
|
|
|
397 {
|
|
|
398 gfc_free_expr (all);
|
|
|
399 gfc_free_expr (e);
|
|
|
400 return MATCH_ERROR;
|
|
|
401 }
|
|
|
402
|
|
|
403 all = total;
|
|
|
404 all->where = where;
|
|
|
405 }
|
|
|
406
|
|
|
407 *result = all;
|
|
|
408 return MATCH_YES;
|
|
|
409 }
|
|
|
410
|
|
|
411
|
|
|
412 static match
|
|
|
413 match_ext_add_operand (gfc_expr **result)
|
|
|
414 {
|
|
|
415 gfc_expr *all, *e;
|
|
|
416 locus where;
|
|
|
417 match m;
|
|
|
418 int i;
|
|
|
419
|
|
|
420 where = gfc_current_locus;
|
|
|
421 i = match_add_op ();
|
|
|
422
|
|
|
423 if (i == 0)
|
|
|
424 return match_add_operand (result);
|
|
|
425
|
|
|
426 if (gfc_notification_std (GFC_STD_GNU) == ERROR)
|
|
|
427 {
|
|
|
428 gfc_error ("Extension: Unary operator following "
|
|
|
429 "arithmetic operator (use parentheses) at %C");
|
|
|
430 return MATCH_ERROR;
|
|
|
431 }
|
|
|
432 else
|
|
|
433 gfc_warning (0, "Extension: Unary operator following "
|
|
|
434 "arithmetic operator (use parentheses) at %C");
|
|
|
435
|
|
|
436 m = match_ext_add_operand (&e);
|
|
|
437 if (m != MATCH_YES)
|
|
|
438 return m;
|
|
|
439
|
|
|
440 if (i == -1)
|
|
|
441 all = gfc_uminus (e);
|
|
|
442 else
|
|
|
443 all = gfc_uplus (e);
|
|
|
444
|
|
|
445 if (all == NULL)
|
|
|
446 {
|
|
|
447 gfc_free_expr (e);
|
|
|
448 return MATCH_ERROR;
|
|
|
449 }
|
|
|
450
|
|
|
451 all->where = where;
|
|
|
452 *result = all;
|
|
|
453 return MATCH_YES;
|
|
|
454 }
|
|
|
455
|
|
|
456
|
|
|
457 /* Match a level 2 expression. */
|
|
|
458
|
|
|
459 static match
|
|
|
460 match_level_2 (gfc_expr **result)
|
|
|
461 {
|
|
|
462 gfc_expr *all, *e, *total;
|
|
|
463 locus where;
|
|
|
464 match m;
|
|
|
465 int i;
|
|
|
466
|
|
|
467 where = gfc_current_locus;
|
|
|
468 i = match_add_op ();
|
|
|
469
|
|
|
470 if (i != 0)
|
|
|
471 {
|
|
|
472 m = match_ext_add_operand (&e);
|
|
|
473 if (m == MATCH_NO)
|
|
|
474 {
|
|
|
475 gfc_error (expression_syntax);
|
|
|
476 m = MATCH_ERROR;
|
|
|
477 }
|
|
|
478 }
|
|
|
479 else
|
|
|
480 m = match_add_operand (&e);
|
|
|
481
|
|
|
482 if (m != MATCH_YES)
|
|
|
483 return m;
|
|
|
484
|
|
|
485 if (i == 0)
|
|
|
486 all = e;
|
|
|
487 else
|
|
|
488 {
|
|
|
489 if (i == -1)
|
|
|
490 all = gfc_uminus (e);
|
|
|
491 else
|
|
|
492 all = gfc_uplus (e);
|
|
|
493
|
|
|
494 if (all == NULL)
|
|
|
495 {
|
|
|
496 gfc_free_expr (e);
|
|
|
497 return MATCH_ERROR;
|
|
|
498 }
|
|
|
499 }
|
|
|
500
|
|
|
501 all->where = where;
|
|
|
502
|
|
|
503 /* Append add-operands to the sum. */
|
|
|
504
|
|
|
505 for (;;)
|
|
|
506 {
|
|
|
507 where = gfc_current_locus;
|
|
|
508 i = match_add_op ();
|
|
|
509 if (i == 0)
|
|
|
510 break;
|
|
|
511
|
|
|
512 m = match_ext_add_operand (&e);
|
|
|
513 if (m == MATCH_NO)
|
|
|
514 gfc_error (expression_syntax);
|
|
|
515 if (m != MATCH_YES)
|
|
|
516 {
|
|
|
517 gfc_free_expr (all);
|
|
|
518 return MATCH_ERROR;
|
|
|
519 }
|
|
|
520
|
|
|
521 if (i == -1)
|
|
|
522 total = gfc_subtract (all, e);
|
|
|
523 else
|
|
|
524 total = gfc_add (all, e);
|
|
|
525
|
|
|
526 if (total == NULL)
|
|
|
527 {
|
|
|
528 gfc_free_expr (all);
|
|
|
529 gfc_free_expr (e);
|
|
|
530 return MATCH_ERROR;
|
|
|
531 }
|
|
|
532
|
|
|
533 all = total;
|
|
|
534 all->where = where;
|
|
|
535 }
|
|
|
536
|
|
|
537 *result = all;
|
|
|
538 return MATCH_YES;
|
|
|
539 }
|
|
|
540
|
|
|
541
|
|
|
542 /* Match a level three expression. */
|
|
|
543
|
|
|
544 static match
|
|
|
545 match_level_3 (gfc_expr **result)
|
|
|
546 {
|
|
|
547 gfc_expr *all, *e, *total = NULL;
|
|
|
548 locus where;
|
|
|
549 match m;
|
|
|
550
|
|
|
551 m = match_level_2 (&all);
|
|
|
552 if (m != MATCH_YES)
|
|
|
553 return m;
|
|
|
554
|
|
|
555 for (;;)
|
|
|
556 {
|
|
|
557 if (!next_operator (INTRINSIC_CONCAT))
|
|
|
558 break;
|
|
|
559
|
|
|
560 where = gfc_current_locus;
|
|
|
561
|
|
|
562 m = match_level_2 (&e);
|
|
|
563 if (m == MATCH_NO)
|
|
|
564 gfc_error (expression_syntax);
|
|
|
565 if (m != MATCH_YES)
|
|
|
566 {
|
|
|
567 gfc_free_expr (all);
|
|
|
568 return MATCH_ERROR;
|
|
|
569 }
|
|
|
570
|
|
|
571 total = gfc_concat (all, e);
|
|
|
572 if (total == NULL)
|
|
|
573 {
|
|
|
574 gfc_free_expr (all);
|
|
|
575 gfc_free_expr (e);
|
|
|
576 return MATCH_ERROR;
|
|
|
577 }
|
|
|
578
|
|
|
579 all = total;
|
|
|
580 all->where = where;
|
|
|
581 }
|
|
|
582
|
|
|
583 *result = all;
|
|
|
584 return MATCH_YES;
|
|
|
585 }
|
|
|
586
|
|
|
587
|
|
|
588 /* Match a level 4 expression. */
|
|
|
589
|
|
|
590 static match
|
|
|
591 match_level_4 (gfc_expr **result)
|
|
|
592 {
|
|
|
593 gfc_expr *left, *right, *r;
|
|
|
594 gfc_intrinsic_op i;
|
|
|
595 locus old_loc;
|
|
|
596 locus where;
|
|
|
597 match m;
|
|
|
598
|
|
|
599 m = match_level_3 (&left);
|
|
|
600 if (m != MATCH_YES)
|
|
|
601 return m;
|
|
|
602
|
|
|
603 old_loc = gfc_current_locus;
|
|
|
604
|
|
|
605 if (gfc_match_intrinsic_op (&i) != MATCH_YES)
|
|
|
606 {
|
|
|
607 *result = left;
|
|
|
608 return MATCH_YES;
|
|
|
609 }
|
|
|
610
|
|
|
611 if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
|
|
|
612 && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT
|
|
|
613 && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
|
|
|
614 && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
|
|
|
615 {
|
|
|
616 gfc_current_locus = old_loc;
|
|
|
617 *result = left;
|
|
|
618 return MATCH_YES;
|
|
|
619 }
|
|
|
620
|
|
|
621 where = gfc_current_locus;
|
|
|
622
|
|
|
623 m = match_level_3 (&right);
|
|
|
624 if (m == MATCH_NO)
|
|
|
625 gfc_error (expression_syntax);
|
|
|
626 if (m != MATCH_YES)
|
|
|
627 {
|
|
|
628 gfc_free_expr (left);
|
|
|
629 return MATCH_ERROR;
|
|
|
630 }
|
|
|
631
|
|
|
632 switch (i)
|
|
|
633 {
|
|
|
634 case INTRINSIC_EQ:
|
|
|
635 case INTRINSIC_EQ_OS:
|
|
|
636 r = gfc_eq (left, right, i);
|
|
|
637 break;
|
|
|
638
|
|
|
639 case INTRINSIC_NE:
|
|
|
640 case INTRINSIC_NE_OS:
|
|
|
641 r = gfc_ne (left, right, i);
|
|
|
642 break;
|
|
|
643
|
|
|
644 case INTRINSIC_LT:
|
|
|
645 case INTRINSIC_LT_OS:
|
|
|
646 r = gfc_lt (left, right, i);
|
|
|
647 break;
|
|
|
648
|
|
|
649 case INTRINSIC_LE:
|
|
|
650 case INTRINSIC_LE_OS:
|
|
|
651 r = gfc_le (left, right, i);
|
|
|
652 break;
|
|
|
653
|
|
|
654 case INTRINSIC_GT:
|
|
|
655 case INTRINSIC_GT_OS:
|
|
|
656 r = gfc_gt (left, right, i);
|
|
|
657 break;
|
|
|
658
|
|
|
659 case INTRINSIC_GE:
|
|
|
660 case INTRINSIC_GE_OS:
|
|
|
661 r = gfc_ge (left, right, i);
|
|
|
662 break;
|
|
|
663
|
|
|
664 default:
|
|
|
665 gfc_internal_error ("match_level_4(): Bad operator");
|
|
|
666 }
|
|
|
667
|
|
|
668 if (r == NULL)
|
|
|
669 {
|
|
|
670 gfc_free_expr (left);
|
|
|
671 gfc_free_expr (right);
|
|
|
672 return MATCH_ERROR;
|
|
|
673 }
|
|
|
674
|
|
|
675 r->where = where;
|
|
|
676 *result = r;
|
|
|
677
|
|
|
678 return MATCH_YES;
|
|
|
679 }
|
|
|
680
|
|
|
681
|
|
|
682 static match
|
|
|
683 match_and_operand (gfc_expr **result)
|
|
|
684 {
|
|
|
685 gfc_expr *e, *r;
|
|
|
686 locus where;
|
|
|
687 match m;
|
|
|
688 int i;
|
|
|
689
|
|
|
690 i = next_operator (INTRINSIC_NOT);
|
|
|
691 where = gfc_current_locus;
|
|
|
692
|
|
|
693 m = match_level_4 (&e);
|
|
|
694 if (m != MATCH_YES)
|
|
|
695 return m;
|
|
|
696
|
|
|
697 r = e;
|
|
|
698 if (i)
|
|
|
699 {
|
|
|
700 r = gfc_not (e);
|
|
|
701 if (r == NULL)
|
|
|
702 {
|
|
|
703 gfc_free_expr (e);
|
|
|
704 return MATCH_ERROR;
|
|
|
705 }
|
|
|
706 }
|
|
|
707
|
|
|
708 r->where = where;
|
|
|
709 *result = r;
|
|
|
710
|
|
|
711 return MATCH_YES;
|
|
|
712 }
|
|
|
713
|
|
|
714
|
|
|
715 static match
|
|
|
716 match_or_operand (gfc_expr **result)
|
|
|
717 {
|
|
|
718 gfc_expr *all, *e, *total;
|
|
|
719 locus where;
|
|
|
720 match m;
|
|
|
721
|
|
|
722 m = match_and_operand (&all);
|
|
|
723 if (m != MATCH_YES)
|
|
|
724 return m;
|
|
|
725
|
|
|
726 for (;;)
|
|
|
727 {
|
|
|
728 if (!next_operator (INTRINSIC_AND))
|
|
|
729 break;
|
|
|
730 where = gfc_current_locus;
|
|
|
731
|
|
|
732 m = match_and_operand (&e);
|
|
|
733 if (m == MATCH_NO)
|
|
|
734 gfc_error (expression_syntax);
|
|
|
735 if (m != MATCH_YES)
|
|
|
736 {
|
|
|
737 gfc_free_expr (all);
|
|
|
738 return MATCH_ERROR;
|
|
|
739 }
|
|
|
740
|
|
|
741 total = gfc_and (all, e);
|
|
|
742 if (total == NULL)
|
|
|
743 {
|
|
|
744 gfc_free_expr (all);
|
|
|
745 gfc_free_expr (e);
|
|
|
746 return MATCH_ERROR;
|
|
|
747 }
|
|
|
748
|
|
|
749 all = total;
|
|
|
750 all->where = where;
|
|
|
751 }
|
|
|
752
|
|
|
753 *result = all;
|
|
|
754 return MATCH_YES;
|
|
|
755 }
|
|
|
756
|
|
|
757
|
|
|
758 static match
|
|
|
759 match_equiv_operand (gfc_expr **result)
|
|
|
760 {
|
|
|
761 gfc_expr *all, *e, *total;
|
|
|
762 locus where;
|
|
|
763 match m;
|
|
|
764
|
|
|
765 m = match_or_operand (&all);
|
|
|
766 if (m != MATCH_YES)
|
|
|
767 return m;
|
|
|
768
|
|
|
769 for (;;)
|
|
|
770 {
|
|
|
771 if (!next_operator (INTRINSIC_OR))
|
|
|
772 break;
|
|
|
773 where = gfc_current_locus;
|
|
|
774
|
|
|
775 m = match_or_operand (&e);
|
|
|
776 if (m == MATCH_NO)
|
|
|
777 gfc_error (expression_syntax);
|
|
|
778 if (m != MATCH_YES)
|
|
|
779 {
|
|
|
780 gfc_free_expr (all);
|
|
|
781 return MATCH_ERROR;
|
|
|
782 }
|
|
|
783
|
|
|
784 total = gfc_or (all, e);
|
|
|
785 if (total == NULL)
|
|
|
786 {
|
|
|
787 gfc_free_expr (all);
|
|
|
788 gfc_free_expr (e);
|
|
|
789 return MATCH_ERROR;
|
|
|
790 }
|
|
|
791
|
|
|
792 all = total;
|
|
|
793 all->where = where;
|
|
|
794 }
|
|
|
795
|
|
|
796 *result = all;
|
|
|
797 return MATCH_YES;
|
|
|
798 }
|
|
|
799
|
|
|
800
|
|
|
801 /* Match a level 5 expression. */
|
|
|
802
|
|
|
803 static match
|
|
|
804 match_level_5 (gfc_expr **result)
|
|
|
805 {
|
|
|
806 gfc_expr *all, *e, *total;
|
|
|
807 locus where;
|
|
|
808 match m;
|
|
|
809 gfc_intrinsic_op i;
|
|
|
810
|
|
|
811 m = match_equiv_operand (&all);
|
|
|
812 if (m != MATCH_YES)
|
|
|
813 return m;
|
|
|
814
|
|
|
815 for (;;)
|
|
|
816 {
|
|
|
817 if (next_operator (INTRINSIC_EQV))
|
|
|
818 i = INTRINSIC_EQV;
|
|
|
819 else
|
|
|
820 {
|
|
|
821 if (next_operator (INTRINSIC_NEQV))
|
|
|
822 i = INTRINSIC_NEQV;
|
|
|
823 else
|
|
|
824 break;
|
|
|
825 }
|
|
|
826
|
|
|
827 where = gfc_current_locus;
|
|
|
828
|
|
|
829 m = match_equiv_operand (&e);
|
|
|
830 if (m == MATCH_NO)
|
|
|
831 gfc_error (expression_syntax);
|
|
|
832 if (m != MATCH_YES)
|
|
|
833 {
|
|
|
834 gfc_free_expr (all);
|
|
|
835 return MATCH_ERROR;
|
|
|
836 }
|
|
|
837
|
|
|
838 if (i == INTRINSIC_EQV)
|
|
|
839 total = gfc_eqv (all, e);
|
|
|
840 else
|
|
|
841 total = gfc_neqv (all, e);
|
|
|
842
|
|
|
843 if (total == NULL)
|
|
|
844 {
|
|
|
845 gfc_free_expr (all);
|
|
|
846 gfc_free_expr (e);
|
|
|
847 return MATCH_ERROR;
|
|
|
848 }
|
|
|
849
|
|
|
850 all = total;
|
|
|
851 all->where = where;
|
|
|
852 }
|
|
|
853
|
|
|
854 *result = all;
|
|
|
855 return MATCH_YES;
|
|
|
856 }
|
|
|
857
|
|
|
858
|
|
|
859 /* Match an expression. At this level, we are stringing together
|
|
|
860 level 5 expressions separated by binary operators. */
|
|
|
861
|
|
|
862 match
|
|
|
863 gfc_match_expr (gfc_expr **result)
|
|
|
864 {
|
|
|
865 gfc_expr *all, *e;
|
|
|
866 gfc_user_op *uop;
|
|
|
867 locus where;
|
|
|
868 match m;
|
|
|
869
|
|
|
870 m = match_level_5 (&all);
|
|
|
871 if (m != MATCH_YES)
|
|
|
872 return m;
|
|
|
873
|
|
|
874 for (;;)
|
|
|
875 {
|
|
|
876 uop = NULL;
|
|
|
877 m = match_defined_operator (&uop);
|
|
|
878 if (m == MATCH_NO)
|
|
|
879 break;
|
|
|
880 if (m == MATCH_ERROR)
|
|
|
881 {
|
|
|
882 gfc_free_expr (all);
|
|
|
883 return MATCH_ERROR;
|
|
|
884 }
|
|
|
885
|
|
|
886 where = gfc_current_locus;
|
|
|
887
|
|
|
888 m = match_level_5 (&e);
|
|
|
889 if (m == MATCH_NO)
|
|
|
890 gfc_error (expression_syntax);
|
|
|
891 if (m != MATCH_YES)
|
|
|
892 {
|
|
|
893 gfc_free_expr (all);
|
|
|
894 return MATCH_ERROR;
|
|
|
895 }
|
|
|
896
|
|
|
897 all = gfc_get_operator_expr (&where, INTRINSIC_USER, all, e);
|
|
|
898 all->value.op.uop = uop;
|
|
|
899 }
|
|
|
900
|
|
|
901 *result = all;
|
|
|
902 return MATCH_YES;
|
|
|
903 }
|
