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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [fortran/] [matchexp.c] - Blame information for rev 826

Details | Compare with Previous | View Log


/* Expression parser.
   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009
   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 3, 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 COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */
 
#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;
}
 
 
/* Call the INTRINSIC_PARENTHESES function.  This is both
   used explicitly, as below, or by resolve.c to generate
   temporaries.  */
 
gfc_expr *
gfc_get_parentheses (gfc_expr *e)
{
  gfc_expr *e2;
 
  e2 = gfc_get_expr();
  e2->expr_type = EXPR_OP;
  e2->ts = e->ts;
  e2->rank = e->rank;
  e2->where = e->where;
  e2->value.op.op = INTRINSIC_PARENTHESES;
  e2->value.op.op1 = e;
  e2->value.op.op2 = NULL;
  return e2;
}
 
 
/* Match a primary expression.  */
 
static match
match_primary (gfc_expr **result)
{
  match m;
  gfc_expr *e;
 
  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.  */
  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, any expression in
     parentheses shall be treated as a data entity.  */
  *result = gfc_get_parentheses (e);
 
  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 op, locus *where,
            gfc_expr *op1, gfc_expr *op2)
{
  gfc_expr *new_expr;
 
  new_expr = gfc_get_expr ();
  new_expr->expr_type = EXPR_OP;
  new_expr->value.op.op = op;
  new_expr->where = *where;
 
  new_expr->value.op.op1 = op1;
  new_expr->value.op.op2 = op2;
 
  return new_expr;
}
 
 
/* 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 rewritten 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_notification_std (GFC_STD_GNU) == ERROR)
    {
      gfc_error ("Extension: Unary operator following "
                 "arithmetic operator (use parentheses) at %C");
      return MATCH_ERROR;
    }
  else
    gfc_warning ("Extension: Unary operator following "
                 "arithmetic operator (use parentheses) at %C");
 
  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_notification_std (GFC_STD_GNU) == ERROR)
    {
      gfc_error ("Extension: Unary operator following "
                 "arithmetic operator (use parentheses) at %C");
      return MATCH_ERROR;
    }
  else
    gfc_warning ("Extension: Unary operator following "
                "arithmetic operator (use parentheses) at %C");
 
  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
      && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
      && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
    {
      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:
    case INTRINSIC_EQ_OS:
      r = gfc_eq (left, right, i);
      break;
 
    case INTRINSIC_NE:
    case INTRINSIC_NE_OS:
      r = gfc_ne (left, right, i);
      break;
 
    case INTRINSIC_LT:
    case INTRINSIC_LT_OS:
      r = gfc_lt (left, right, i);
      break;
 
    case INTRINSIC_LE:
    case INTRINSIC_LE_OS:
      r = gfc_le (left, right, i);
      break;
 
    case INTRINSIC_GT:
    case INTRINSIC_GT_OS:
      r = gfc_gt (left, right, i);
      break;
 
    case INTRINSIC_GE:
    case INTRINSIC_GE_OS:
      r = gfc_ge (left, right, i);
      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 openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [fortran/] [matchexp.c] - Blame information for rev 826

Line No.	Rev	Author	Line
1	285	jeremybenn	`/* 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			`}`