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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [fortran/] [matchexp.c] - Blame information for rev 744

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


/* Expression parser.
   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   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_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL);
  e2->ts = e->ts;
  e2->rank = e->rank;
 
  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;
}
 
 
/* 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;
 
  gfc_gobble_whitespace ();
  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 = gfc_get_operator_expr (&where, INTRINSIC_USER, 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 = gfc_get_operator_expr (&where, INTRINSIC_USER, all, e);
      all->value.op.uop = uop;
    }
 
  *result = all;
  return MATCH_YES;
}

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [fortran/] [matchexp.c] - Blame information for rev 744

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