1/* Expression parser.
2   Copyright (C) 2000-2020 Free Software Foundation, Inc.
3   Contributed by Andy Vaught
4
5This file is part of GCC.
6
7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 3, or (at your option) any later
10version.
11
12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15for more details.
16
17You should have received a copy of the GNU General Public License
18along 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
28static 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
35match
36gfc_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
79error:
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
91static match
92match_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
109static int
110next_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
128gfc_expr *
129gfc_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
143static match
144match_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
188syntax:
189  gfc_error (expression_syntax);
190  return MATCH_ERROR;
191}
192
193
194/* Match a level 1 expression.  */
195
196static match
197match_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
244static match match_ext_mult_operand (gfc_expr **result);
245static match match_ext_add_operand (gfc_expr **result);
246
247static int
248match_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
258static match
259match_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
303static match
304match_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
348static match
349match_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
412static match
413match_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
459static match
460match_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
544static match
545match_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
590static match
591match_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
682static match
683match_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
715static match
716match_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
758static match
759match_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
803static match
804match_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
862match
863gfc_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}
904