OSDN Git Service

gcc/fortran:
[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_notification_std (GFC_STD_GNU) == ERROR)
349     {
350       gfc_error ("Extension: Unary operator following "
351                  "arithmetic operator (use parentheses) at %C");
352       return MATCH_ERROR;
353     }
354   else
355     gfc_warning ("Extension: Unary operator following "
356                  "arithmetic operator (use parentheses) at %C");
357
358   m = match_ext_mult_operand (&e);
359   if (m != MATCH_YES)
360     return m;
361
362   if (i == -1)
363     all = gfc_uminus (e);
364   else
365     all = gfc_uplus (e);
366
367   if (all == NULL)
368     {
369       gfc_free_expr (e);
370       return MATCH_ERROR;
371     }
372
373   all->where = where;
374   *result = all;
375   return MATCH_YES;
376 }
377
378
379 static match
380 match_add_operand (gfc_expr **result)
381 {
382   gfc_expr *all, *e, *total;
383   locus where, old_loc;
384   match m;
385   gfc_intrinsic_op i;
386
387   m = match_mult_operand (&all);
388   if (m != MATCH_YES)
389     return m;
390
391   for (;;)
392     {
393       /* Build up a string of products or quotients.  */
394
395       old_loc = gfc_current_locus;
396
397       if (next_operator (INTRINSIC_TIMES))
398         i = INTRINSIC_TIMES;
399       else
400         {
401           if (next_operator (INTRINSIC_DIVIDE))
402             i = INTRINSIC_DIVIDE;
403           else
404             break;
405         }
406
407       where = gfc_current_locus;
408
409       m = match_ext_mult_operand (&e);
410       if (m == MATCH_NO)
411         {
412           gfc_current_locus = old_loc;
413           break;
414         }
415
416       if (m == MATCH_ERROR)
417         {
418           gfc_free_expr (all);
419           return MATCH_ERROR;
420         }
421
422       if (i == INTRINSIC_TIMES)
423         total = gfc_multiply (all, e);
424       else
425         total = gfc_divide (all, e);
426
427       if (total == NULL)
428         {
429           gfc_free_expr (all);
430           gfc_free_expr (e);
431           return MATCH_ERROR;
432         }
433
434       all = total;
435       all->where = where;
436     }
437
438   *result = all;
439   return MATCH_YES;
440 }
441
442
443 static match
444 match_ext_add_operand (gfc_expr **result)
445 {
446   gfc_expr *all, *e;
447   locus where;
448   match m;
449   int i;
450
451   where = gfc_current_locus;
452   i = match_add_op ();
453
454   if (i == 0)
455     return match_add_operand (result);
456
457   if (gfc_notification_std (GFC_STD_GNU) == ERROR)
458     {
459       gfc_error ("Extension: Unary operator following "
460                  "arithmetic operator (use parentheses) at %C");
461       return MATCH_ERROR;
462     }
463   else
464     gfc_warning ("Extension: Unary operator following "
465                 "arithmetic operator (use parentheses) at %C");
466
467   m = match_ext_add_operand (&e);
468   if (m != MATCH_YES)
469     return m;
470
471   if (i == -1)
472     all = gfc_uminus (e);
473   else
474     all = gfc_uplus (e);
475
476   if (all == NULL)
477     {
478       gfc_free_expr (e);
479       return MATCH_ERROR;
480     }
481
482   all->where = where;
483   *result = all;
484   return MATCH_YES;
485 }
486
487
488 /* Match a level 2 expression.  */
489
490 static match
491 match_level_2 (gfc_expr **result)
492 {
493   gfc_expr *all, *e, *total;
494   locus where;
495   match m;
496   int i;
497
498   where = gfc_current_locus;
499   i = match_add_op ();
500
501   if (i != 0)
502     {
503       m = match_ext_add_operand (&e);
504       if (m == MATCH_NO)
505         {
506           gfc_error (expression_syntax);
507           m = MATCH_ERROR;
508         }
509     }
510   else
511     m = match_add_operand (&e);
512
513   if (m != MATCH_YES)
514     return m;
515
516   if (i == 0)
517     all = e;
518   else
519     {
520       if (i == -1)
521         all = gfc_uminus (e);
522       else
523         all = gfc_uplus (e);
524
525       if (all == NULL)
526         {
527           gfc_free_expr (e);
528           return MATCH_ERROR;
529         }
530     }
531
532   all->where = where;
533
534   /* Append add-operands to the sum.  */
535
536   for (;;)
537     {
538       where = gfc_current_locus;
539       i = match_add_op ();
540       if (i == 0)
541         break;
542
543       m = match_ext_add_operand (&e);
544       if (m == MATCH_NO)
545         gfc_error (expression_syntax);
546       if (m != MATCH_YES)
547         {
548           gfc_free_expr (all);
549           return MATCH_ERROR;
550         }
551
552       if (i == -1)
553         total = gfc_subtract (all, e);
554       else
555         total = gfc_add (all, e);
556
557       if (total == NULL)
558         {
559           gfc_free_expr (all);
560           gfc_free_expr (e);
561           return MATCH_ERROR;
562         }
563
564       all = total;
565       all->where = where;
566     }
567
568   *result = all;
569   return MATCH_YES;
570 }
571
572
573 /* Match a level three expression.  */
574
575 static match
576 match_level_3 (gfc_expr **result)
577 {
578   gfc_expr *all, *e, *total;
579   locus where;
580   match m;
581
582   m = match_level_2 (&all);
583   if (m != MATCH_YES)
584     return m;
585
586   for (;;)
587     {
588       if (!next_operator (INTRINSIC_CONCAT))
589         break;
590
591       where = gfc_current_locus;
592
593       m = match_level_2 (&e);
594       if (m == MATCH_NO)
595         {
596           gfc_error (expression_syntax);
597           gfc_free_expr (all);
598         }
599       if (m != MATCH_YES)
600         return MATCH_ERROR;
601
602       total = gfc_concat (all, e);
603       if (total == NULL)
604         {
605           gfc_free_expr (all);
606           gfc_free_expr (e);
607           return MATCH_ERROR;
608         }
609
610       all = total;
611       all->where = where;
612     }
613
614   *result = all;
615   return MATCH_YES;
616 }
617
618
619 /* Match a level 4 expression.  */
620
621 static match
622 match_level_4 (gfc_expr **result)
623 {
624   gfc_expr *left, *right, *r;
625   gfc_intrinsic_op i;
626   locus old_loc;
627   locus where;
628   match m;
629
630   m = match_level_3 (&left);
631   if (m != MATCH_YES)
632     return m;
633
634   old_loc = gfc_current_locus;
635
636   if (gfc_match_intrinsic_op (&i) != MATCH_YES)
637     {
638       *result = left;
639       return MATCH_YES;
640     }
641
642   if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
643       && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT
644       && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
645       && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
646     {
647       gfc_current_locus = old_loc;
648       *result = left;
649       return MATCH_YES;
650     }
651
652   where = gfc_current_locus;
653
654   m = match_level_3 (&right);
655   if (m == MATCH_NO)
656     gfc_error (expression_syntax);
657   if (m != MATCH_YES)
658     {
659       gfc_free_expr (left);
660       return MATCH_ERROR;
661     }
662
663   switch (i)
664     {
665     case INTRINSIC_EQ:
666     case INTRINSIC_EQ_OS:
667       r = gfc_eq (left, right, i);
668       break;
669
670     case INTRINSIC_NE:
671     case INTRINSIC_NE_OS:
672       r = gfc_ne (left, right, i);
673       break;
674
675     case INTRINSIC_LT:
676     case INTRINSIC_LT_OS:
677       r = gfc_lt (left, right, i);
678       break;
679
680     case INTRINSIC_LE:
681     case INTRINSIC_LE_OS:
682       r = gfc_le (left, right, i);
683       break;
684
685     case INTRINSIC_GT:
686     case INTRINSIC_GT_OS:
687       r = gfc_gt (left, right, i);
688       break;
689
690     case INTRINSIC_GE:
691     case INTRINSIC_GE_OS:
692       r = gfc_ge (left, right, i);
693       break;
694
695     default:
696       gfc_internal_error ("match_level_4(): Bad operator");
697     }
698
699   if (r == NULL)
700     {
701       gfc_free_expr (left);
702       gfc_free_expr (right);
703       return MATCH_ERROR;
704     }
705
706   r->where = where;
707   *result = r;
708
709   return MATCH_YES;
710 }
711
712
713 static match
714 match_and_operand (gfc_expr **result)
715 {
716   gfc_expr *e, *r;
717   locus where;
718   match m;
719   int i;
720
721   i = next_operator (INTRINSIC_NOT);
722   where = gfc_current_locus;
723
724   m = match_level_4 (&e);
725   if (m != MATCH_YES)
726     return m;
727
728   r = e;
729   if (i)
730     {
731       r = gfc_not (e);
732       if (r == NULL)
733         {
734           gfc_free_expr (e);
735           return MATCH_ERROR;
736         }
737     }
738
739   r->where = where;
740   *result = r;
741
742   return MATCH_YES;
743 }
744
745
746 static match
747 match_or_operand (gfc_expr **result)
748 {
749   gfc_expr *all, *e, *total;
750   locus where;
751   match m;
752
753   m = match_and_operand (&all);
754   if (m != MATCH_YES)
755     return m;
756
757   for (;;)
758     {
759       if (!next_operator (INTRINSIC_AND))
760         break;
761       where = gfc_current_locus;
762
763       m = match_and_operand (&e);
764       if (m == MATCH_NO)
765         gfc_error (expression_syntax);
766       if (m != MATCH_YES)
767         {
768           gfc_free_expr (all);
769           return MATCH_ERROR;
770         }
771
772       total = gfc_and (all, e);
773       if (total == NULL)
774         {
775           gfc_free_expr (all);
776           gfc_free_expr (e);
777           return MATCH_ERROR;
778         }
779
780       all = total;
781       all->where = where;
782     }
783
784   *result = all;
785   return MATCH_YES;
786 }
787
788
789 static match
790 match_equiv_operand (gfc_expr **result)
791 {
792   gfc_expr *all, *e, *total;
793   locus where;
794   match m;
795
796   m = match_or_operand (&all);
797   if (m != MATCH_YES)
798     return m;
799
800   for (;;)
801     {
802       if (!next_operator (INTRINSIC_OR))
803         break;
804       where = gfc_current_locus;
805
806       m = match_or_operand (&e);
807       if (m == MATCH_NO)
808         gfc_error (expression_syntax);
809       if (m != MATCH_YES)
810         {
811           gfc_free_expr (all);
812           return MATCH_ERROR;
813         }
814
815       total = gfc_or (all, e);
816       if (total == NULL)
817         {
818           gfc_free_expr (all);
819           gfc_free_expr (e);
820           return MATCH_ERROR;
821         }
822
823       all = total;
824       all->where = where;
825     }
826
827   *result = all;
828   return MATCH_YES;
829 }
830
831
832 /* Match a level 5 expression.  */
833
834 static match
835 match_level_5 (gfc_expr **result)
836 {
837   gfc_expr *all, *e, *total;
838   locus where;
839   match m;
840   gfc_intrinsic_op i;
841
842   m = match_equiv_operand (&all);
843   if (m != MATCH_YES)
844     return m;
845
846   for (;;)
847     {
848       if (next_operator (INTRINSIC_EQV))
849         i = INTRINSIC_EQV;
850       else
851         {
852           if (next_operator (INTRINSIC_NEQV))
853             i = INTRINSIC_NEQV;
854           else
855             break;
856         }
857
858       where = gfc_current_locus;
859
860       m = match_equiv_operand (&e);
861       if (m == MATCH_NO)
862         gfc_error (expression_syntax);
863       if (m != MATCH_YES)
864         {
865           gfc_free_expr (all);
866           return MATCH_ERROR;
867         }
868
869       if (i == INTRINSIC_EQV)
870         total = gfc_eqv (all, e);
871       else
872         total = gfc_neqv (all, e);
873
874       if (total == NULL)
875         {
876           gfc_free_expr (all);
877           gfc_free_expr (e);
878           return MATCH_ERROR;
879         }
880
881       all = total;
882       all->where = where;
883     }
884
885   *result = all;
886   return MATCH_YES;
887 }
888
889
890 /* Match an expression.  At this level, we are stringing together
891    level 5 expressions separated by binary operators.  */
892
893 match
894 gfc_match_expr (gfc_expr **result)
895 {
896   gfc_expr *all, *e;
897   gfc_user_op *uop;
898   locus where;
899   match m;
900
901   m = match_level_5 (&all);
902   if (m != MATCH_YES)
903     return m;
904
905   for (;;)
906     {
907       uop = NULL;
908       m = match_defined_operator (&uop);
909       if (m == MATCH_NO)
910         break;
911       if (m == MATCH_ERROR)
912         {
913           gfc_free_expr (all);
914           return MATCH_ERROR;
915         }
916
917       where = gfc_current_locus;
918
919       m = match_level_5 (&e);
920       if (m == MATCH_NO)
921         gfc_error (expression_syntax);
922       if (m != MATCH_YES)
923         {
924           gfc_free_expr (all);
925           return MATCH_ERROR;
926         }
927
928       all = build_node (INTRINSIC_USER, &where, all, e);
929       all->value.op.uop = uop;
930     }
931
932   *result = all;
933   return MATCH_YES;
934 }