OSDN Git Service

* trans-common.c (create_common): Remove unused offset variable.
[pf3gnuchains/gcc-fork.git] / gcc / fortran / matchexp.c
1 /* Expression parser.
2    Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009
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   e2 = gfc_get_expr();
134   e2->expr_type = EXPR_OP;
135   e2->ts = e->ts;
136   e2->rank = e->rank;
137   e2->where = e->where;
138   e2->value.op.op = INTRINSIC_PARENTHESES;
139   e2->value.op.op1 = e;
140   e2->value.op.op2 = NULL;
141   return e2;
142 }
143
144
145 /* Match a primary expression.  */
146
147 static match
148 match_primary (gfc_expr **result)
149 {
150   match m;
151   gfc_expr *e;
152
153   m = gfc_match_literal_constant (result, 0);
154   if (m != MATCH_NO)
155     return m;
156
157   m = gfc_match_array_constructor (result);
158   if (m != MATCH_NO)
159     return m;
160
161   m = gfc_match_rvalue (result);
162   if (m != MATCH_NO)
163     return m;
164
165   /* Match an expression in parentheses.  */
166   if (gfc_match_char ('(') != MATCH_YES)
167     return MATCH_NO;
168
169   m = gfc_match_expr (&e);
170   if (m == MATCH_NO)
171     goto syntax;
172   if (m == MATCH_ERROR)
173     return m;
174
175   m = gfc_match_char (')');
176   if (m == MATCH_NO)
177     gfc_error ("Expected a right parenthesis in expression at %C");
178
179   /* Now we have the expression inside the parentheses, build the
180      expression pointing to it. By 7.1.7.2, any expression in
181      parentheses shall be treated as a data entity.  */
182   *result = gfc_get_parentheses (e);
183
184   if (m != MATCH_YES)
185     {
186       gfc_free_expr (*result);
187       return MATCH_ERROR;
188     }
189
190   return MATCH_YES;
191
192 syntax:
193   gfc_error (expression_syntax);
194   return MATCH_ERROR;
195 }
196
197
198 /* Build an operator expression node.  */
199
200 static gfc_expr *
201 build_node (gfc_intrinsic_op op, locus *where,
202             gfc_expr *op1, gfc_expr *op2)
203 {
204   gfc_expr *new_expr;
205
206   new_expr = gfc_get_expr ();
207   new_expr->expr_type = EXPR_OP;
208   new_expr->value.op.op = op;
209   new_expr->where = *where;
210
211   new_expr->value.op.op1 = op1;
212   new_expr->value.op.op2 = op2;
213
214   return new_expr;
215 }
216
217
218 /* Match a level 1 expression.  */
219
220 static match
221 match_level_1 (gfc_expr **result)
222 {
223   gfc_user_op *uop;
224   gfc_expr *e, *f;
225   locus where;
226   match m;
227
228   where = gfc_current_locus;
229   uop = NULL;
230   m = match_defined_operator (&uop);
231   if (m == MATCH_ERROR)
232     return m;
233
234   m = match_primary (&e);
235   if (m != MATCH_YES)
236     return m;
237
238   if (uop == NULL)
239     *result = e;
240   else
241     {
242       f = build_node (INTRINSIC_USER, &where, e, NULL);
243       f->value.op.uop = uop;
244       *result = f;
245     }
246
247   return MATCH_YES;
248 }
249
250
251 /* As a GNU extension we support an expanded level-2 expression syntax.
252    Via this extension we support (arbitrary) nesting of unary plus and
253    minus operations following unary and binary operators, such as **.
254    The grammar of section 7.1.1.3 is effectively rewritten as:
255
256         R704  mult-operand     is level-1-expr [ power-op ext-mult-operand ]
257         R704' ext-mult-operand is add-op ext-mult-operand
258                                or mult-operand
259         R705  add-operand      is add-operand mult-op ext-mult-operand
260                                or mult-operand
261         R705' ext-add-operand  is add-op ext-add-operand
262                                or add-operand
263         R706  level-2-expr     is [ level-2-expr ] add-op ext-add-operand
264                                or add-operand
265  */
266
267 static match match_ext_mult_operand (gfc_expr **result);
268 static match match_ext_add_operand (gfc_expr **result);
269
270 static int
271 match_add_op (void)
272 {
273   if (next_operator (INTRINSIC_MINUS))
274     return -1;
275   if (next_operator (INTRINSIC_PLUS))
276     return 1;
277   return 0;
278 }
279
280
281 static match
282 match_mult_operand (gfc_expr **result)
283 {
284   gfc_expr *e, *exp, *r;
285   locus where;
286   match m;
287
288   m = match_level_1 (&e);
289   if (m != MATCH_YES)
290     return m;
291
292   if (!next_operator (INTRINSIC_POWER))
293     {
294       *result = e;
295       return MATCH_YES;
296     }
297
298   where = gfc_current_locus;
299
300   m = match_ext_mult_operand (&exp);
301   if (m == MATCH_NO)
302     gfc_error ("Expected exponent in expression at %C");
303   if (m != MATCH_YES)
304     {
305       gfc_free_expr (e);
306       return MATCH_ERROR;
307     }
308
309   r = gfc_power (e, exp);
310   if (r == NULL)
311     {
312       gfc_free_expr (e);
313       gfc_free_expr (exp);
314       return MATCH_ERROR;
315     }
316
317   r->where = where;
318   *result = r;
319
320   return MATCH_YES;
321 }
322
323
324 static match
325 match_ext_mult_operand (gfc_expr **result)
326 {
327   gfc_expr *all, *e;
328   locus where;
329   match m;
330   int i;
331
332   where = gfc_current_locus;
333   i = match_add_op ();
334
335   if (i == 0)
336     return match_mult_operand (result);
337
338   if (gfc_notification_std (GFC_STD_GNU) == ERROR)
339     {
340       gfc_error ("Extension: Unary operator following "
341                  "arithmetic operator (use parentheses) at %C");
342       return MATCH_ERROR;
343     }
344   else
345     gfc_warning ("Extension: Unary operator following "
346                  "arithmetic operator (use parentheses) at %C");
347
348   m = match_ext_mult_operand (&e);
349   if (m != MATCH_YES)
350     return m;
351
352   if (i == -1)
353     all = gfc_uminus (e);
354   else
355     all = gfc_uplus (e);
356
357   if (all == NULL)
358     {
359       gfc_free_expr (e);
360       return MATCH_ERROR;
361     }
362
363   all->where = where;
364   *result = all;
365   return MATCH_YES;
366 }
367
368
369 static match
370 match_add_operand (gfc_expr **result)
371 {
372   gfc_expr *all, *e, *total;
373   locus where, old_loc;
374   match m;
375   gfc_intrinsic_op i;
376
377   m = match_mult_operand (&all);
378   if (m != MATCH_YES)
379     return m;
380
381   for (;;)
382     {
383       /* Build up a string of products or quotients.  */
384
385       old_loc = gfc_current_locus;
386
387       if (next_operator (INTRINSIC_TIMES))
388         i = INTRINSIC_TIMES;
389       else
390         {
391           if (next_operator (INTRINSIC_DIVIDE))
392             i = INTRINSIC_DIVIDE;
393           else
394             break;
395         }
396
397       where = gfc_current_locus;
398
399       m = match_ext_mult_operand (&e);
400       if (m == MATCH_NO)
401         {
402           gfc_current_locus = old_loc;
403           break;
404         }
405
406       if (m == MATCH_ERROR)
407         {
408           gfc_free_expr (all);
409           return MATCH_ERROR;
410         }
411
412       if (i == INTRINSIC_TIMES)
413         total = gfc_multiply (all, e);
414       else
415         total = gfc_divide (all, e);
416
417       if (total == NULL)
418         {
419           gfc_free_expr (all);
420           gfc_free_expr (e);
421           return MATCH_ERROR;
422         }
423
424       all = total;
425       all->where = where;
426     }
427
428   *result = all;
429   return MATCH_YES;
430 }
431
432
433 static match
434 match_ext_add_operand (gfc_expr **result)
435 {
436   gfc_expr *all, *e;
437   locus where;
438   match m;
439   int i;
440
441   where = gfc_current_locus;
442   i = match_add_op ();
443
444   if (i == 0)
445     return match_add_operand (result);
446
447   if (gfc_notification_std (GFC_STD_GNU) == ERROR)
448     {
449       gfc_error ("Extension: Unary operator following "
450                  "arithmetic operator (use parentheses) at %C");
451       return MATCH_ERROR;
452     }
453   else
454     gfc_warning ("Extension: Unary operator following "
455                 "arithmetic operator (use parentheses) at %C");
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 }