OSDN Git Service

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