Mercurial > hg > CbC > CbC_gcc
comparison gcc/fortran/matchexp.c @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
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 } |