URL https://opencores.org/ocsvn/scarts/scarts/trunk

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [fortran/] [matchexp.c] - Blame information for rev 20

Go to most recent revision | Details | Compare with Previous | View Log


/* Expression parser.
   Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc.
   Contributed by Andy Vaught
 
This file is part of GCC.
 
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.
 
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.
 
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.  */
 
 
#include "config.h"
#include "system.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
 
static char expression_syntax[] = N_("Syntax error in expression at %C");
 
 
/* Match a user-defined operator name.  This is a normal name with a
   few restrictions.  The error_flag controls whether an error is
   raised if 'true' or 'false' are used or not.  */
 
match
gfc_match_defined_op_name (char *result, int error_flag)
{
  static const char * const badops[] = {
    "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
      NULL
  };
 
  char name[GFC_MAX_SYMBOL_LEN + 1];
  locus old_loc;
  match m;
  int i;
 
  old_loc = gfc_current_locus;
 
  m = gfc_match (" . %n .", name);
  if (m != MATCH_YES)
    return m;
 
  /* .true. and .false. have interpretations as constants.  Trying to
     use these as operators will fail at a later time.  */
 
  if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0)
    {
      if (error_flag)
        goto error;
      gfc_current_locus = old_loc;
      return MATCH_NO;
    }
 
  for (i = 0; badops[i]; i++)
    if (strcmp (badops[i], name) == 0)
      goto error;
 
  for (i = 0; name[i]; i++)
    if (!ISALPHA (name[i]))
      {
        gfc_error ("Bad character '%c' in OPERATOR name at %C", name[i]);
        return MATCH_ERROR;
      }
 
  strcpy (result, name);
  return MATCH_YES;
 
error:
  gfc_error ("The name '%s' cannot be used as a defined operator at %C",
             name);
 
  gfc_current_locus = old_loc;
  return MATCH_ERROR;
}
 
 
/* Match a user defined operator.  The symbol found must be an
   operator already.  */
 
static match
match_defined_operator (gfc_user_op ** result)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  match m;
 
  m = gfc_match_defined_op_name (name, 0);
  if (m != MATCH_YES)
    return m;
 
  *result = gfc_get_uop (name);
  return MATCH_YES;
}
 
 
/* Check to see if the given operator is next on the input.  If this
   is not the case, the parse pointer remains where it was.  */
 
static int
next_operator (gfc_intrinsic_op t)
{
  gfc_intrinsic_op u;
  locus old_loc;
 
  old_loc = gfc_current_locus;
  if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u)
    return 1;
 
  gfc_current_locus = old_loc;
  return 0;
}
 
 
/* Match a primary expression.  */
 
static match
match_primary (gfc_expr ** result)
{
  match m;
  gfc_expr *e;
  locus where;
 
  m = gfc_match_literal_constant (result, 0);
  if (m != MATCH_NO)
    return m;
 
  m = gfc_match_array_constructor (result);
  if (m != MATCH_NO)
    return m;
 
  m = gfc_match_rvalue (result);
  if (m != MATCH_NO)
    return m;
 
  /* Match an expression in parentheses.  */
  where = gfc_current_locus;
 
  if (gfc_match_char ('(') != MATCH_YES)
    return MATCH_NO;
 
  m = gfc_match_expr (&e);
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    return m;
 
  m = gfc_match_char (')');
  if (m == MATCH_NO)
    gfc_error ("Expected a right parenthesis in expression at %C");
 
  /* Now we have the expression inside the parentheses, build the
     expression pointing to it. By 7.1.7.2 the integrity of
     parentheses is only conserved in numerical calculations, so we
     don't bother to keep the parentheses otherwise.  */
  if(!gfc_numeric_ts(&e->ts))
    *result = e;
  else
    {
      gfc_expr *e2 = gfc_get_expr();
 
      e2->expr_type = EXPR_OP;
      e2->ts = e->ts;
      e2->rank = e->rank;
      e2->where = where;
      e2->value.op.operator = INTRINSIC_PARENTHESES;
      e2->value.op.op1 = e;
      e2->value.op.op2 = NULL;
      *result = e2;
    }
 
  if (m != MATCH_YES)
    {
      gfc_free_expr (*result);
      return MATCH_ERROR;
    }
 
  return MATCH_YES;
 
syntax:
  gfc_error (expression_syntax);
  return MATCH_ERROR;
}
 
 
/* Build an operator expression node.  */
 
static gfc_expr *
build_node (gfc_intrinsic_op operator, locus * where,
            gfc_expr * op1, gfc_expr * op2)
{
  gfc_expr *new;
 
  new = gfc_get_expr ();
  new->expr_type = EXPR_OP;
  new->value.op.operator = operator;
  new->where = *where;
 
  new->value.op.op1 = op1;
  new->value.op.op2 = op2;
 
  return new;
}
 
 
/* Match a level 1 expression.  */
 
static match
match_level_1 (gfc_expr ** result)
{
  gfc_user_op *uop;
  gfc_expr *e, *f;
  locus where;
  match m;
 
  where = gfc_current_locus;
  uop = NULL;
  m = match_defined_operator (&uop);
  if (m == MATCH_ERROR)
    return m;
 
  m = match_primary (&e);
  if (m != MATCH_YES)
    return m;
 
  if (uop == NULL)
    *result = e;
  else
    {
      f = build_node (INTRINSIC_USER, &where, e, NULL);
      f->value.op.uop = uop;
      *result = f;
    }
 
  return MATCH_YES;
}
 
 
/* As a GNU extension we support an expanded level-2 expression syntax.
   Via this extension we support (arbitrary) nesting of unary plus and
   minus operations following unary and binary operators, such as **.
   The grammar of section 7.1.1.3 is effectively rewitten as:
 
        R704  mult-operand     is level-1-expr [ power-op ext-mult-operand ]
        R704' ext-mult-operand is add-op ext-mult-operand
                               or mult-operand
        R705  add-operand      is add-operand mult-op ext-mult-operand
                               or mult-operand
        R705' ext-add-operand  is add-op ext-add-operand
                               or add-operand
        R706  level-2-expr     is [ level-2-expr ] add-op ext-add-operand
                               or add-operand
 */
 
static match match_ext_mult_operand (gfc_expr ** result);
static match match_ext_add_operand (gfc_expr ** result);
 
 
static int
match_add_op (void)
{
 
  if (next_operator (INTRINSIC_MINUS))
    return -1;
  if (next_operator (INTRINSIC_PLUS))
    return 1;
  return 0;
}
 
 
static match
match_mult_operand (gfc_expr ** result)
{
  gfc_expr *e, *exp, *r;
  locus where;
  match m;
 
  m = match_level_1 (&e);
  if (m != MATCH_YES)
    return m;
 
  if (!next_operator (INTRINSIC_POWER))
    {
      *result = e;
      return MATCH_YES;
    }
 
  where = gfc_current_locus;
 
  m = match_ext_mult_operand (&exp);
  if (m == MATCH_NO)
    gfc_error ("Expected exponent in expression at %C");
  if (m != MATCH_YES)
    {
      gfc_free_expr (e);
      return MATCH_ERROR;
    }
 
  r = gfc_power (e, exp);
  if (r == NULL)
    {
      gfc_free_expr (e);
      gfc_free_expr (exp);
      return MATCH_ERROR;
    }
 
  r->where = where;
  *result = r;
 
  return MATCH_YES;
}
 
 
static match
match_ext_mult_operand (gfc_expr ** result)
{
  gfc_expr *all, *e;
  locus where;
  match m;
  int i;
 
  where = gfc_current_locus;
  i = match_add_op ();
 
  if (i == 0)
    return match_mult_operand (result);
 
  if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following"
                      " arithmetic operator (use parentheses) at %C")
      == FAILURE)
    return MATCH_ERROR;
 
  m = match_ext_mult_operand (&e);
  if (m != MATCH_YES)
    return m;
 
  if (i == -1)
    all = gfc_uminus (e);
  else
    all = gfc_uplus (e);
 
  if (all == NULL)
    {
      gfc_free_expr (e);
      return MATCH_ERROR;
    }
 
  all->where = where;
  *result = all;
  return MATCH_YES;
}
 
 
static match
match_add_operand (gfc_expr ** result)
{
  gfc_expr *all, *e, *total;
  locus where, old_loc;
  match m;
  gfc_intrinsic_op i;
 
  m = match_mult_operand (&all);
  if (m != MATCH_YES)
    return m;
 
  for (;;)
    {
      /* Build up a string of products or quotients.  */
 
      old_loc = gfc_current_locus;
 
      if (next_operator (INTRINSIC_TIMES))
        i = INTRINSIC_TIMES;
      else
        {
          if (next_operator (INTRINSIC_DIVIDE))
            i = INTRINSIC_DIVIDE;
          else
            break;
        }
 
      where = gfc_current_locus;
 
      m = match_ext_mult_operand (&e);
      if (m == MATCH_NO)
        {
          gfc_current_locus = old_loc;
          break;
        }
 
      if (m == MATCH_ERROR)
        {
          gfc_free_expr (all);
          return MATCH_ERROR;
        }
 
      if (i == INTRINSIC_TIMES)
        total = gfc_multiply (all, e);
      else
        total = gfc_divide (all, e);
 
      if (total == NULL)
        {
          gfc_free_expr (all);
          gfc_free_expr (e);
          return MATCH_ERROR;
        }
 
      all = total;
      all->where = where;
    }
 
  *result = all;
  return MATCH_YES;
}
 
 
static match
match_ext_add_operand (gfc_expr ** result)
{
  gfc_expr *all, *e;
  locus where;
  match m;
  int i;
 
  where = gfc_current_locus;
  i = match_add_op ();
 
  if (i == 0)
    return match_add_operand (result);
 
  if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following"
                      " arithmetic operator (use parentheses) at %C")
      == FAILURE)
    return MATCH_ERROR;
 
  m = match_ext_add_operand (&e);
  if (m != MATCH_YES)
    return m;
 
  if (i == -1)
    all = gfc_uminus (e);
  else
    all = gfc_uplus (e);
 
  if (all == NULL)
    {
      gfc_free_expr (e);
      return MATCH_ERROR;
    }
 
  all->where = where;
  *result = all;
  return MATCH_YES;
}
 
 
/* Match a level 2 expression.  */
 
static match
match_level_2 (gfc_expr ** result)
{
  gfc_expr *all, *e, *total;
  locus where;
  match m;
  int i;
 
  where = gfc_current_locus;
  i = match_add_op ();
 
  if (i != 0)
    {
      m = match_ext_add_operand (&e);
      if (m == MATCH_NO)
        {
          gfc_error (expression_syntax);
          m = MATCH_ERROR;
        }
    }
  else
    m = match_add_operand (&e);
 
  if (m != MATCH_YES)
    return m;
 
  if (i == 0)
    all = e;
  else
    {
      if (i == -1)
        all = gfc_uminus (e);
      else
        all = gfc_uplus (e);
 
      if (all == NULL)
        {
          gfc_free_expr (e);
          return MATCH_ERROR;
        }
    }
 
  all->where = where;
 
/* Append add-operands to the sum */
 
  for (;;)
    {
      where = gfc_current_locus;
      i = match_add_op ();
      if (i == 0)
        break;
 
      m = match_ext_add_operand (&e);
      if (m == MATCH_NO)
        gfc_error (expression_syntax);
      if (m != MATCH_YES)
        {
          gfc_free_expr (all);
          return MATCH_ERROR;
        }
 
      if (i == -1)
        total = gfc_subtract (all, e);
      else
        total = gfc_add (all, e);
 
      if (total == NULL)
        {
          gfc_free_expr (all);
          gfc_free_expr (e);
          return MATCH_ERROR;
        }
 
      all = total;
      all->where = where;
    }
 
  *result = all;
  return MATCH_YES;
}
 
 
/* Match a level three expression.  */
 
static match
match_level_3 (gfc_expr ** result)
{
  gfc_expr *all, *e, *total;
  locus where;
  match m;
 
  m = match_level_2 (&all);
  if (m != MATCH_YES)
    return m;
 
  for (;;)
    {
      if (!next_operator (INTRINSIC_CONCAT))
        break;
 
      where = gfc_current_locus;
 
      m = match_level_2 (&e);
      if (m == MATCH_NO)
        {
          gfc_error (expression_syntax);
          gfc_free_expr (all);
        }
      if (m != MATCH_YES)
        return MATCH_ERROR;
 
      total = gfc_concat (all, e);
      if (total == NULL)
        {
          gfc_free_expr (all);
          gfc_free_expr (e);
          return MATCH_ERROR;
        }
 
      all = total;
      all->where = where;
    }
 
  *result = all;
  return MATCH_YES;
}
 
 
/* Match a level 4 expression.  */
 
static match
match_level_4 (gfc_expr ** result)
{
  gfc_expr *left, *right, *r;
  gfc_intrinsic_op i;
  locus old_loc;
  locus where;
  match m;
 
  m = match_level_3 (&left);
  if (m != MATCH_YES)
    return m;
 
  old_loc = gfc_current_locus;
 
  if (gfc_match_intrinsic_op (&i) != MATCH_YES)
    {
      *result = left;
      return MATCH_YES;
    }
 
  if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
      && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT)
    {
      gfc_current_locus = old_loc;
      *result = left;
      return MATCH_YES;
    }
 
  where = gfc_current_locus;
 
  m = match_level_3 (&right);
  if (m == MATCH_NO)
    gfc_error (expression_syntax);
  if (m != MATCH_YES)
    {
      gfc_free_expr (left);
      return MATCH_ERROR;
    }
 
  switch (i)
    {
    case INTRINSIC_EQ:
      r = gfc_eq (left, right);
      break;
 
    case INTRINSIC_NE:
      r = gfc_ne (left, right);
      break;
 
    case INTRINSIC_LT:
      r = gfc_lt (left, right);
      break;
 
    case INTRINSIC_LE:
      r = gfc_le (left, right);
      break;
 
    case INTRINSIC_GT:
      r = gfc_gt (left, right);
      break;
 
    case INTRINSIC_GE:
      r = gfc_ge (left, right);
      break;
 
    default:
      gfc_internal_error ("match_level_4(): Bad operator");
    }
 
  if (r == NULL)
    {
      gfc_free_expr (left);
      gfc_free_expr (right);
      return MATCH_ERROR;
    }
 
  r->where = where;
  *result = r;
 
  return MATCH_YES;
}
 
 
static match
match_and_operand (gfc_expr ** result)
{
  gfc_expr *e, *r;
  locus where;
  match m;
  int i;
 
  i = next_operator (INTRINSIC_NOT);
  where = gfc_current_locus;
 
  m = match_level_4 (&e);
  if (m != MATCH_YES)
    return m;
 
  r = e;
  if (i)
    {
      r = gfc_not (e);
      if (r == NULL)
        {
          gfc_free_expr (e);
          return MATCH_ERROR;
        }
    }
 
  r->where = where;
  *result = r;
 
  return MATCH_YES;
}
 
 
static match
match_or_operand (gfc_expr ** result)
{
  gfc_expr *all, *e, *total;
  locus where;
  match m;
 
  m = match_and_operand (&all);
  if (m != MATCH_YES)
    return m;
 
  for (;;)
    {
      if (!next_operator (INTRINSIC_AND))
        break;
      where = gfc_current_locus;
 
      m = match_and_operand (&e);
      if (m == MATCH_NO)
        gfc_error (expression_syntax);
      if (m != MATCH_YES)
        {
          gfc_free_expr (all);
          return MATCH_ERROR;
        }
 
      total = gfc_and (all, e);
      if (total == NULL)
        {
          gfc_free_expr (all);
          gfc_free_expr (e);
          return MATCH_ERROR;
        }
 
      all = total;
      all->where = where;
    }
 
  *result = all;
  return MATCH_YES;
}
 
 
static match
match_equiv_operand (gfc_expr ** result)
{
  gfc_expr *all, *e, *total;
  locus where;
  match m;
 
  m = match_or_operand (&all);
  if (m != MATCH_YES)
    return m;
 
  for (;;)
    {
      if (!next_operator (INTRINSIC_OR))
        break;
      where = gfc_current_locus;
 
      m = match_or_operand (&e);
      if (m == MATCH_NO)
        gfc_error (expression_syntax);
      if (m != MATCH_YES)
        {
          gfc_free_expr (all);
          return MATCH_ERROR;
        }
 
      total = gfc_or (all, e);
      if (total == NULL)
        {
          gfc_free_expr (all);
          gfc_free_expr (e);
          return MATCH_ERROR;
        }
 
      all = total;
      all->where = where;
    }
 
  *result = all;
  return MATCH_YES;
}
 
 
/* Match a level 5 expression.  */
 
static match
match_level_5 (gfc_expr ** result)
{
  gfc_expr *all, *e, *total;
  locus where;
  match m;
  gfc_intrinsic_op i;
 
  m = match_equiv_operand (&all);
  if (m != MATCH_YES)
    return m;
 
  for (;;)
    {
      if (next_operator (INTRINSIC_EQV))
        i = INTRINSIC_EQV;
      else
        {
          if (next_operator (INTRINSIC_NEQV))
            i = INTRINSIC_NEQV;
          else
            break;
        }
 
      where = gfc_current_locus;
 
      m = match_equiv_operand (&e);
      if (m == MATCH_NO)
        gfc_error (expression_syntax);
      if (m != MATCH_YES)
        {
          gfc_free_expr (all);
          return MATCH_ERROR;
        }
 
      if (i == INTRINSIC_EQV)
        total = gfc_eqv (all, e);
      else
        total = gfc_neqv (all, e);
 
      if (total == NULL)
        {
          gfc_free_expr (all);
          gfc_free_expr (e);
          return MATCH_ERROR;
        }
 
      all = total;
      all->where = where;
    }
 
  *result = all;
  return MATCH_YES;
}
 
 
/* Match an expression.  At this level, we are stringing together
   level 5 expressions separated by binary operators.  */
 
match
gfc_match_expr (gfc_expr ** result)
{
  gfc_expr *all, *e;
  gfc_user_op *uop;
  locus where;
  match m;
 
  m = match_level_5 (&all);
  if (m != MATCH_YES)
    return m;
 
  for (;;)
    {
      uop = NULL;
      m = match_defined_operator (&uop);
      if (m == MATCH_NO)
        break;
      if (m == MATCH_ERROR)
        {
          gfc_free_expr (all);
          return MATCH_ERROR;
        }
 
      where = gfc_current_locus;
 
      m = match_level_5 (&e);
      if (m == MATCH_NO)
        gfc_error (expression_syntax);
      if (m != MATCH_YES)
        {
          gfc_free_expr (all);
          return MATCH_ERROR;
        }
 
      all = build_node (INTRINSIC_USER, &where, all, e);
      all->value.op.uop = uop;
    }
 
  *result = all;
  return MATCH_YES;
}

Browse

Tools

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [fortran/] [matchexp.c] - Blame information for rev 20

Line No.	Rev	Author	Line
1	12	jlechner	`/* Expression parser.`
2			`Copyright (C) 2000, 2001, 2002, 2004, 2005 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 2, 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 COPYING. If not, write to the Free`
19			`Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA`
20			`02110-1301, USA. */`
21
22
23			`#include "config.h"`
24			`#include "system.h"`
25			`#include "gfortran.h"`
26			`#include "arith.h"`
27			`#include "match.h"`
28
29			`static char expression_syntax[] = N_("Syntax error in expression at %C");`
30
31
32			`/* Match a user-defined operator name. This is a normal name with a`
33			`few restrictions. The error_flag controls whether an error is`
34			`raised if 'true' or 'false' are used or not. */`
35
36			`match`
37			`gfc_match_defined_op_name (char *result, int error_flag)`
38			`{`
39			`static const char * const badops[] = {`
40			`"and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",`
41			`NULL`
42			`};`
43
44			`char name[GFC_MAX_SYMBOL_LEN + 1];`
45			`locus old_loc;`
46			`match m;`
47			`int i;`
48
49			`old_loc = gfc_current_locus;`
50
51			`m = gfc_match (" . %n .", name);`
52			`if (m != MATCH_YES)`
53			`return m;`
54
55			`/* .true. and .false. have interpretations as constants. Trying to`
56			`use these as operators will fail at a later time. */`
57
58			`if (strcmp (name, "true") == 0 \|\| strcmp (name, "false") == 0)`
59			`{`
60			`if (error_flag)`
61			`goto error;`
62			`gfc_current_locus = old_loc;`
63			`return MATCH_NO;`
64			`}`
65
66			`for (i = 0; badops[i]; i++)`
67			`if (strcmp (badops[i], name) == 0)`
68			`goto error;`
69
70			`for (i = 0; name[i]; i++)`
71			`if (!ISALPHA (name[i]))`
72			`{`
73			`gfc_error ("Bad character '%c' in OPERATOR name at %C", name[i]);`
74			`return MATCH_ERROR;`
75			`}`
76
77			`strcpy (result, name);`
78			`return MATCH_YES;`
79
80			`error:`
81			`gfc_error ("The name '%s' cannot be used as a defined operator at %C",`
82			`name);`
83
84			`gfc_current_locus = old_loc;`
85			`return MATCH_ERROR;`
86			`}`
87
88
89			`/* Match a user defined operator. The symbol found must be an`
90			`operator already. */`
91
92			`static match`
93			`match_defined_operator (gfc_user_op ** result)`
94			`{`
95			`char name[GFC_MAX_SYMBOL_LEN + 1];`
96			`match m;`
97
98			`m = gfc_match_defined_op_name (name, 0);`
99			`if (m != MATCH_YES)`
100			`return m;`
101
102			`*result = gfc_get_uop (name);`
103			`return MATCH_YES;`
104			`}`
105
106
107			`/* Check to see if the given operator is next on the input. If this`
108			`is not the case, the parse pointer remains where it was. */`
109
110			`static int`
111			`next_operator (gfc_intrinsic_op t)`
112			`{`
113			`gfc_intrinsic_op u;`
114			`locus old_loc;`
115
116			`old_loc = gfc_current_locus;`
117			`if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u)`
118			`return 1;`
119
120			`gfc_current_locus = old_loc;`
121			`return 0;`
122			`}`
123
124
125			`/* Match a primary expression. */`
126
127			`static match`
128			`match_primary (gfc_expr ** result)`
129			`{`
130			`match m;`
131			`gfc_expr *e;`
132			`locus where;`
133
134			`m = gfc_match_literal_constant (result, 0);`
135			`if (m != MATCH_NO)`
136			`return m;`
137
138			`m = gfc_match_array_constructor (result);`
139			`if (m != MATCH_NO)`
140			`return m;`
141
142			`m = gfc_match_rvalue (result);`
143			`if (m != MATCH_NO)`
144			`return m;`
145
146			`/* Match an expression in parentheses. */`
147			`where = gfc_current_locus;`
148
149			`if (gfc_match_char ('(') != MATCH_YES)`
150			`return MATCH_NO;`
151
152			`m = gfc_match_expr (&e);`
153			`if (m == MATCH_NO)`
154			`goto syntax;`
155			`if (m == MATCH_ERROR)`
156			`return m;`
157
158			`m = gfc_match_char (')');`
159			`if (m == MATCH_NO)`
160			`gfc_error ("Expected a right parenthesis in expression at %C");`
161
162			`/* Now we have the expression inside the parentheses, build the`
163			`expression pointing to it. By 7.1.7.2 the integrity of`
164			`parentheses is only conserved in numerical calculations, so we`
165			`don't bother to keep the parentheses otherwise. */`
166			`if(!gfc_numeric_ts(&e->ts))`
167			`*result = e;`
168			`else`
169			`{`
170			`gfc_expr *e2 = gfc_get_expr();`
171
172			`e2->expr_type = EXPR_OP;`
173			`e2->ts = e->ts;`
174			`e2->rank = e->rank;`
175			`e2->where = where;`
176			`e2->value.op.operator = INTRINSIC_PARENTHESES;`
177			`e2->value.op.op1 = e;`
178			`e2->value.op.op2 = NULL;`
179			`*result = e2;`
180			`}`
181
182			`if (m != MATCH_YES)`
183			`{`
184			`gfc_free_expr (*result);`
185			`return MATCH_ERROR;`
186			`}`
187
188			`return MATCH_YES;`
189
190			`syntax:`
191			`gfc_error (expression_syntax);`
192			`return MATCH_ERROR;`
193			`}`
194
195
196			`/* Build an operator expression node. */`
197
198			`static gfc_expr *`
199			`build_node (gfc_intrinsic_op operator, locus * where,`
200			`gfc_expr * op1, gfc_expr * op2)`
201			`{`
202			`gfc_expr *new;`
203
204			`new = gfc_get_expr ();`
205			`new->expr_type = EXPR_OP;`
206			`new->value.op.operator = operator;`
207			`new->where = *where;`
208
209			`new->value.op.op1 = op1;`
210			`new->value.op.op2 = op2;`
211
212			`return new;`
213			`}`
214
215
216			`/* Match a level 1 expression. */`
217
218			`static match`
219			`match_level_1 (gfc_expr ** result)`
220			`{`
221			`gfc_user_op *uop;`
222			`gfc_expr e, f;`
223			`locus where;`
224			`match m;`
225
226			`where = gfc_current_locus;`
227			`uop = NULL;`
228			`m = match_defined_operator (&uop);`
229			`if (m == MATCH_ERROR)`
230			`return m;`
231
232			`m = match_primary (&e);`
233			`if (m != MATCH_YES)`
234			`return m;`
235
236			`if (uop == NULL)`
237			`*result = e;`
238			`else`
239			`{`
240			`f = build_node (INTRINSIC_USER, &where, e, NULL);`
241			`f->value.op.uop = uop;`
242			`*result = f;`
243			`}`
244
245			`return MATCH_YES;`
246			`}`
247
248
249			`/* As a GNU extension we support an expanded level-2 expression syntax.`
250			`Via this extension we support (arbitrary) nesting of unary plus and`
251			`minus operations following unary and binary operators, such as **.`
252			`The grammar of section 7.1.1.3 is effectively rewitten as:`
253
254			`R704 mult-operand is level-1-expr [ power-op ext-mult-operand ]`
255			`R704' ext-mult-operand is add-op ext-mult-operand`
256			`or mult-operand`
257			`R705 add-operand is add-operand mult-op ext-mult-operand`
258			`or mult-operand`
259			`R705' ext-add-operand is add-op ext-add-operand`
260			`or add-operand`
261			`R706 level-2-expr is [ level-2-expr ] add-op ext-add-operand`
262			`or add-operand`
263			`*/`
264
265			`static match match_ext_mult_operand (gfc_expr ** result);`
266			`static match match_ext_add_operand (gfc_expr ** result);`
267
268
269			`static int`
270			`match_add_op (void)`
271			`{`
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_notify_std (GFC_STD_GNU, "Extension: Unary operator following"`
339			`" arithmetic operator (use parentheses) at %C")`
340			`== FAILURE)`
341			`return MATCH_ERROR;`
342
343			`m = match_ext_mult_operand (&e);`
344			`if (m != MATCH_YES)`
345			`return m;`
346
347			`if (i == -1)`
348			`all = gfc_uminus (e);`
349			`else`
350			`all = gfc_uplus (e);`
351
352			`if (all == NULL)`
353			`{`
354			`gfc_free_expr (e);`
355			`return MATCH_ERROR;`
356			`}`
357
358			`all->where = where;`
359			`*result = all;`
360			`return MATCH_YES;`
361			`}`
362
363
364			`static match`
365			`match_add_operand (gfc_expr ** result)`
366			`{`
367			`gfc_expr all, e, *total;`
368			`locus where, old_loc;`
369			`match m;`
370			`gfc_intrinsic_op i;`
371
372			`m = match_mult_operand (&all);`
373			`if (m != MATCH_YES)`
374			`return m;`
375
376			`for (;;)`
377			`{`
378			`/* Build up a string of products or quotients. */`
379
380			`old_loc = gfc_current_locus;`
381
382			`if (next_operator (INTRINSIC_TIMES))`
383			`i = INTRINSIC_TIMES;`
384			`else`
385			`{`
386			`if (next_operator (INTRINSIC_DIVIDE))`
387			`i = INTRINSIC_DIVIDE;`
388			`else`
389			`break;`
390			`}`
391
392			`where = gfc_current_locus;`
393
394			`m = match_ext_mult_operand (&e);`
395			`if (m == MATCH_NO)`
396			`{`
397			`gfc_current_locus = old_loc;`
398			`break;`
399			`}`
400
401			`if (m == MATCH_ERROR)`
402			`{`
403			`gfc_free_expr (all);`
404			`return MATCH_ERROR;`
405			`}`
406
407			`if (i == INTRINSIC_TIMES)`
408			`total = gfc_multiply (all, e);`
409			`else`
410			`total = gfc_divide (all, e);`
411
412			`if (total == NULL)`
413			`{`
414			`gfc_free_expr (all);`
415			`gfc_free_expr (e);`
416			`return MATCH_ERROR;`
417			`}`
418
419			`all = total;`
420			`all->where = where;`
421			`}`
422
423			`*result = all;`
424			`return MATCH_YES;`
425			`}`
426
427
428			`static match`
429			`match_ext_add_operand (gfc_expr ** result)`
430			`{`
431			`gfc_expr all, e;`
432			`locus where;`
433			`match m;`
434			`int i;`
435
436			`where = gfc_current_locus;`
437			`i = match_add_op ();`
438
439			`if (i == 0)`
440			`return match_add_operand (result);`
441
442			`if (gfc_notify_std (GFC_STD_GNU, "Extension: Unary operator following"`
443			`" arithmetic operator (use parentheses) at %C")`
444			`== FAILURE)`
445			`return MATCH_ERROR;`
446
447			`m = match_ext_add_operand (&e);`
448			`if (m != MATCH_YES)`
449			`return m;`
450
451			`if (i == -1)`
452			`all = gfc_uminus (e);`
453			`else`
454			`all = gfc_uplus (e);`
455
456			`if (all == NULL)`
457			`{`
458			`gfc_free_expr (e);`
459			`return MATCH_ERROR;`
460			`}`
461
462			`all->where = where;`
463			`*result = all;`
464			`return MATCH_YES;`
465			`}`
466
467
468			`/* Match a level 2 expression. */`
469
470			`static match`
471			`match_level_2 (gfc_expr ** result)`
472			`{`
473			`gfc_expr all, e, *total;`
474			`locus where;`
475			`match m;`
476			`int i;`
477
478			`where = gfc_current_locus;`
479			`i = match_add_op ();`
480
481			`if (i != 0)`
482			`{`
483			`m = match_ext_add_operand (&e);`
484			`if (m == MATCH_NO)`
485			`{`
486			`gfc_error (expression_syntax);`
487			`m = MATCH_ERROR;`
488			`}`
489			`}`
490			`else`
491			`m = match_add_operand (&e);`
492
493			`if (m != MATCH_YES)`
494			`return m;`
495
496			`if (i == 0)`
497			`all = e;`
498			`else`
499			`{`
500			`if (i == -1)`
501			`all = gfc_uminus (e);`
502			`else`
503			`all = gfc_uplus (e);`
504
505			`if (all == NULL)`
506			`{`
507			`gfc_free_expr (e);`
508			`return MATCH_ERROR;`
509			`}`
510			`}`
511
512			`all->where = where;`
513
514			`/* Append add-operands to the sum */`
515
516			`for (;;)`
517			`{`
518			`where = gfc_current_locus;`
519			`i = match_add_op ();`
520			`if (i == 0)`
521			`break;`
522
523			`m = match_ext_add_operand (&e);`
524			`if (m == MATCH_NO)`
525			`gfc_error (expression_syntax);`
526			`if (m != MATCH_YES)`
527			`{`
528			`gfc_free_expr (all);`
529			`return MATCH_ERROR;`
530			`}`
531
532			`if (i == -1)`
533			`total = gfc_subtract (all, e);`
534			`else`
535			`total = gfc_add (all, e);`
536
537			`if (total == NULL)`
538			`{`
539			`gfc_free_expr (all);`
540			`gfc_free_expr (e);`
541			`return MATCH_ERROR;`
542			`}`
543
544			`all = total;`
545			`all->where = where;`
546			`}`
547
548			`*result = all;`
549			`return MATCH_YES;`
550			`}`
551
552
553			`/* Match a level three expression. */`
554
555			`static match`
556			`match_level_3 (gfc_expr ** result)`
557			`{`
558			`gfc_expr all, e, *total;`
559			`locus where;`
560			`match m;`
561
562			`m = match_level_2 (&all);`
563			`if (m != MATCH_YES)`
564			`return m;`
565
566			`for (;;)`
567			`{`
568			`if (!next_operator (INTRINSIC_CONCAT))`
569			`break;`
570
571			`where = gfc_current_locus;`
572
573			`m = match_level_2 (&e);`
574			`if (m == MATCH_NO)`
575			`{`
576			`gfc_error (expression_syntax);`
577			`gfc_free_expr (all);`
578			`}`
579			`if (m != MATCH_YES)`
580			`return MATCH_ERROR;`
581
582			`total = gfc_concat (all, e);`
583			`if (total == NULL)`
584			`{`
585			`gfc_free_expr (all);`
586			`gfc_free_expr (e);`
587			`return MATCH_ERROR;`
588			`}`
589
590			`all = total;`
591			`all->where = where;`
592			`}`
593
594			`*result = all;`
595			`return MATCH_YES;`
596			`}`
597
598
599			`/* Match a level 4 expression. */`
600
601			`static match`
602			`match_level_4 (gfc_expr ** result)`
603			`{`
604			`gfc_expr left, right, *r;`
605			`gfc_intrinsic_op i;`
606			`locus old_loc;`
607			`locus where;`
608			`match m;`
609
610			`m = match_level_3 (&left);`
611			`if (m != MATCH_YES)`
612			`return m;`
613
614			`old_loc = gfc_current_locus;`
615
616			`if (gfc_match_intrinsic_op (&i) != MATCH_YES)`
617			`{`
618			`*result = left;`
619			`return MATCH_YES;`
620			`}`
621
622			`if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE`
623			`&& i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT)`
624			`{`
625			`gfc_current_locus = old_loc;`
626			`*result = left;`
627			`return MATCH_YES;`
628			`}`
629
630			`where = gfc_current_locus;`
631
632			`m = match_level_3 (&right);`
633			`if (m == MATCH_NO)`
634			`gfc_error (expression_syntax);`
635			`if (m != MATCH_YES)`
636			`{`
637			`gfc_free_expr (left);`
638			`return MATCH_ERROR;`
639			`}`
640
641			`switch (i)`
642			`{`
643			`case INTRINSIC_EQ:`
644			`r = gfc_eq (left, right);`
645			`break;`
646
647			`case INTRINSIC_NE:`
648			`r = gfc_ne (left, right);`
649			`break;`
650
651			`case INTRINSIC_LT:`
652			`r = gfc_lt (left, right);`
653			`break;`
654
655			`case INTRINSIC_LE:`
656			`r = gfc_le (left, right);`
657			`break;`
658
659			`case INTRINSIC_GT:`
660			`r = gfc_gt (left, right);`
661			`break;`
662
663			`case INTRINSIC_GE:`
664			`r = gfc_ge (left, right);`
665			`break;`
666
667			`default:`
668			`gfc_internal_error ("match_level_4(): Bad operator");`
669			`}`
670
671			`if (r == NULL)`
672			`{`
673			`gfc_free_expr (left);`
674			`gfc_free_expr (right);`
675			`return MATCH_ERROR;`
676			`}`
677
678			`r->where = where;`
679			`*result = r;`
680
681			`return MATCH_YES;`
682			`}`
683
684
685			`static match`
686			`match_and_operand (gfc_expr ** result)`
687			`{`
688			`gfc_expr e, r;`
689			`locus where;`
690			`match m;`
691			`int i;`
692
693			`i = next_operator (INTRINSIC_NOT);`
694			`where = gfc_current_locus;`
695
696			`m = match_level_4 (&e);`
697			`if (m != MATCH_YES)`
698			`return m;`
699
700			`r = e;`
701			`if (i)`
702			`{`
703			`r = gfc_not (e);`
704			`if (r == NULL)`
705			`{`
706			`gfc_free_expr (e);`
707			`return MATCH_ERROR;`
708			`}`
709			`}`
710
711			`r->where = where;`
712			`*result = r;`
713
714			`return MATCH_YES;`
715			`}`
716
717
718			`static match`
719			`match_or_operand (gfc_expr ** result)`
720			`{`
721			`gfc_expr all, e, *total;`
722			`locus where;`
723			`match m;`
724
725			`m = match_and_operand (&all);`
726			`if (m != MATCH_YES)`
727			`return m;`
728
729			`for (;;)`
730			`{`
731			`if (!next_operator (INTRINSIC_AND))`
732			`break;`
733			`where = gfc_current_locus;`
734
735			`m = match_and_operand (&e);`
736			`if (m == MATCH_NO)`
737			`gfc_error (expression_syntax);`
738			`if (m != MATCH_YES)`
739			`{`
740			`gfc_free_expr (all);`
741			`return MATCH_ERROR;`
742			`}`
743
744			`total = gfc_and (all, e);`
745			`if (total == NULL)`
746			`{`
747			`gfc_free_expr (all);`
748			`gfc_free_expr (e);`
749			`return MATCH_ERROR;`
750			`}`
751
752			`all = total;`
753			`all->where = where;`
754			`}`
755
756			`*result = all;`
757			`return MATCH_YES;`
758			`}`
759
760
761			`static match`
762			`match_equiv_operand (gfc_expr ** result)`
763			`{`
764			`gfc_expr all, e, *total;`
765			`locus where;`
766			`match m;`
767
768			`m = match_or_operand (&all);`
769			`if (m != MATCH_YES)`
770			`return m;`
771
772			`for (;;)`
773			`{`
774			`if (!next_operator (INTRINSIC_OR))`
775			`break;`
776			`where = gfc_current_locus;`
777
778			`m = match_or_operand (&e);`
779			`if (m == MATCH_NO)`
780			`gfc_error (expression_syntax);`
781			`if (m != MATCH_YES)`
782			`{`
783			`gfc_free_expr (all);`
784			`return MATCH_ERROR;`
785			`}`
786
787			`total = gfc_or (all, e);`
788			`if (total == NULL)`
789			`{`
790			`gfc_free_expr (all);`
791			`gfc_free_expr (e);`
792			`return MATCH_ERROR;`
793			`}`
794
795			`all = total;`
796			`all->where = where;`
797			`}`
798
799			`*result = all;`
800			`return MATCH_YES;`
801			`}`
802
803
804			`/* Match a level 5 expression. */`
805
806			`static match`
807			`match_level_5 (gfc_expr ** result)`
808			`{`
809			`gfc_expr all, e, *total;`
810			`locus where;`
811			`match m;`
812			`gfc_intrinsic_op i;`
813
814			`m = match_equiv_operand (&all);`
815			`if (m != MATCH_YES)`
816			`return m;`
817
818			`for (;;)`
819			`{`
820			`if (next_operator (INTRINSIC_EQV))`
821			`i = INTRINSIC_EQV;`
822			`else`
823			`{`
824			`if (next_operator (INTRINSIC_NEQV))`
825			`i = INTRINSIC_NEQV;`
826			`else`
827			`break;`
828			`}`
829
830			`where = gfc_current_locus;`
831
832			`m = match_equiv_operand (&e);`
833			`if (m == MATCH_NO)`
834			`gfc_error (expression_syntax);`
835			`if (m != MATCH_YES)`
836			`{`
837			`gfc_free_expr (all);`
838			`return MATCH_ERROR;`
839			`}`
840
841			`if (i == INTRINSIC_EQV)`
842			`total = gfc_eqv (all, e);`
843			`else`
844			`total = gfc_neqv (all, e);`
845
846			`if (total == NULL)`
847			`{`
848			`gfc_free_expr (all);`
849			`gfc_free_expr (e);`
850			`return MATCH_ERROR;`
851			`}`
852
853			`all = total;`
854			`all->where = where;`
855			`}`
856
857			`*result = all;`
858			`return MATCH_YES;`
859			`}`
860
861
862			`/* Match an expression. At this level, we are stringing together`
863			`level 5 expressions separated by binary operators. */`
864
865			`match`
866			`gfc_match_expr (gfc_expr ** result)`
867			`{`
868			`gfc_expr all, e;`
869			`gfc_user_op *uop;`
870			`locus where;`
871			`match m;`
872
873			`m = match_level_5 (&all);`
874			`if (m != MATCH_YES)`
875			`return m;`
876
877			`for (;;)`
878			`{`
879			`uop = NULL;`
880			`m = match_defined_operator (&uop);`
881			`if (m == MATCH_NO)`
882			`break;`
883			`if (m == MATCH_ERROR)`
884			`{`
885			`gfc_free_expr (all);`
886			`return MATCH_ERROR;`
887			`}`
888
889			`where = gfc_current_locus;`
890
891			`m = match_level_5 (&e);`
892			`if (m == MATCH_NO)`
893			`gfc_error (expression_syntax);`
894			`if (m != MATCH_YES)`
895			`{`
896			`gfc_free_expr (all);`
897			`return MATCH_ERROR;`
898			`}`
899
900			`all = build_node (INTRINSIC_USER, &where, all, e);`
901			`all->value.op.uop = uop;`
902			`}`
903
904			`*result = all;`
905			`return MATCH_YES;`
906			`}`