match.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

/* Matching subroutines in all sizes, shapes and colors.
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
   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 "flags.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"

/* For matching and debugging purposes.  Order matters here!  The
   unary operators /must/ precede the binary plus and minus, or
   the expression parser breaks.  */

mstring intrinsic_operators[] = {
    minit ("+", INTRINSIC_UPLUS),
    minit ("-", INTRINSIC_UMINUS),
    minit ("+", INTRINSIC_PLUS),
    minit ("-", INTRINSIC_MINUS),
    minit ("**", INTRINSIC_POWER),
    minit ("//", INTRINSIC_CONCAT),
    minit ("*", INTRINSIC_TIMES),
    minit ("/", INTRINSIC_DIVIDE),
    minit (".and.", INTRINSIC_AND),
    minit (".or.", INTRINSIC_OR),
    minit (".eqv.", INTRINSIC_EQV),
    minit (".neqv.", INTRINSIC_NEQV),
    minit (".eq.", INTRINSIC_EQ),
    minit ("==", INTRINSIC_EQ),
    minit (".ne.", INTRINSIC_NE),
    minit ("/=", INTRINSIC_NE),
    minit (".ge.", INTRINSIC_GE),
    minit (">=", INTRINSIC_GE),
    minit (".le.", INTRINSIC_LE),
    minit ("<=", INTRINSIC_LE),
    minit (".lt.", INTRINSIC_LT),
    minit ("<", INTRINSIC_LT),
    minit (".gt.", INTRINSIC_GT),
    minit (">", INTRINSIC_GT),
    minit (".not.", INTRINSIC_NOT),
    minit ("parens", INTRINSIC_PARENTHESES),
    minit (NULL, INTRINSIC_NONE)
};


/******************** Generic matching subroutines ************************/

/* In free form, match at least one space.  Always matches in fixed
   form.  */

match
gfc_match_space (void)
{
  locus old_loc;
  int c;

  if (gfc_current_form == FORM_FIXED)
    return MATCH_YES;

  old_loc = gfc_current_locus;

  c = gfc_next_char ();
  if (!gfc_is_whitespace (c))
    {
      gfc_current_locus = old_loc;
      return MATCH_NO;
    }

  gfc_gobble_whitespace ();

  return MATCH_YES;
}


/* Match an end of statement.  End of statement is optional
   whitespace, followed by a ';' or '\n' or comment '!'.  If a
   semicolon is found, we continue to eat whitespace and semicolons.  */

match
gfc_match_eos (void)
{
  locus old_loc;
  int flag, c;

  flag = 0;

  for (;;)
    {
      old_loc = gfc_current_locus;
      gfc_gobble_whitespace ();

      c = gfc_next_char ();
      switch (c)
	{
	case '!':
	  do
	    {
	      c = gfc_next_char ();
	    }
	  while (c != '\n');

	  /* Fall through */

	case '\n':
	  return MATCH_YES;

	case ';':
	  flag = 1;
	  continue;
	}

      break;
    }

  gfc_current_locus = old_loc;
  return (flag) ? MATCH_YES : MATCH_NO;
}


/* Match a literal integer on the input, setting the value on
   MATCH_YES.  Literal ints occur in kind-parameters as well as
   old-style character length specifications.  */

match
gfc_match_small_literal_int (int *value, int *cnt)
{
  locus old_loc;
  char c;
  int i, j;

  old_loc = gfc_current_locus;

  gfc_gobble_whitespace ();
  c = gfc_next_char ();
  *cnt = 0;

  if (!ISDIGIT (c))
    {
      gfc_current_locus = old_loc;
      return MATCH_NO;
    }

  i = c - '0';
  j = 1;

  for (;;)
    {
      old_loc = gfc_current_locus;
      c = gfc_next_char ();

      if (!ISDIGIT (c))
	break;

      i = 10 * i + c - '0';
      j++;

      if (i > 99999999)
	{
	  gfc_error ("Integer too large at %C");
	  return MATCH_ERROR;
	}
    }

  gfc_current_locus = old_loc;

  *value = i;
  *cnt = j;
  return MATCH_YES;
}


/* Match a small, constant integer expression, like in a kind
   statement.  On MATCH_YES, 'value' is set.  */

match
gfc_match_small_int (int *value)
{
  gfc_expr *expr;
  const char *p;
  match m;
  int i;

  m = gfc_match_expr (&expr);
  if (m != MATCH_YES)
    return m;

  p = gfc_extract_int (expr, &i);
  gfc_free_expr (expr);

  if (p != NULL)
    {
      gfc_error (p);
      m = MATCH_ERROR;
    }

  *value = i;
  return m;
}


/* Matches a statement label.  Uses gfc_match_small_literal_int() to
   do most of the work.  */

match
gfc_match_st_label (gfc_st_label ** label)
{
  locus old_loc;
  match m;
  int i, cnt;

  old_loc = gfc_current_locus;

  m = gfc_match_small_literal_int (&i, &cnt);
  if (m != MATCH_YES)
    return m;

  if (cnt > 5)
    {
      gfc_error ("Too many digits in statement label at %C");
      goto cleanup;
    }

  if (i == 0)
    {
      gfc_error ("Statement label at %C is zero");
      goto cleanup;
    }

  *label = gfc_get_st_label (i);
  return MATCH_YES;

cleanup:

  gfc_current_locus = old_loc;
  return MATCH_ERROR;
}


/* Match and validate a label associated with a named IF, DO or SELECT
   statement.  If the symbol does not have the label attribute, we add
   it.  We also make sure the symbol does not refer to another
   (active) block.  A matched label is pointed to by gfc_new_block.  */

match
gfc_match_label (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  match m;

  gfc_new_block = NULL;

  m = gfc_match (" %n :", name);
  if (m != MATCH_YES)
    return m;

  if (gfc_get_symbol (name, NULL, &gfc_new_block))
    {
      gfc_error ("Label name '%s' at %C is ambiguous", name);
      return MATCH_ERROR;
    }

  if (gfc_new_block->attr.flavor == FL_LABEL)
    {
      gfc_error ("Duplicate construct label '%s' at %C", name);
      return MATCH_ERROR;
    }

  if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
		      gfc_new_block->name, NULL) == FAILURE)
    return MATCH_ERROR;

  return MATCH_YES;
}


/* Try and match the input against an array of possibilities.  If one
   potential matching string is a substring of another, the longest
   match takes precedence.  Spaces in the target strings are optional
   spaces that do not necessarily have to be found in the input
   stream.  In fixed mode, spaces never appear.  If whitespace is
   matched, it matches unlimited whitespace in the input.  For this
   reason, the 'mp' member of the mstring structure is used to track
   the progress of each potential match.

   If there is no match we return the tag associated with the
   terminating NULL mstring structure and leave the locus pointer
   where it started.  If there is a match we return the tag member of
   the matched mstring and leave the locus pointer after the matched
   character.

   A '%' character is a mandatory space.  */

int
gfc_match_strings (mstring * a)
{
  mstring *p, *best_match;
  int no_match, c, possibles;
  locus match_loc;

  possibles = 0;

  for (p = a; p->string != NULL; p++)
    {
      p->mp = p->string;
      possibles++;
    }

  no_match = p->tag;

  best_match = NULL;
  match_loc = gfc_current_locus;

  gfc_gobble_whitespace ();

  while (possibles > 0)
    {
      c = gfc_next_char ();

      /* Apply the next character to the current possibilities.  */
      for (p = a; p->string != NULL; p++)
	{
	  if (p->mp == NULL)
	    continue;

	  if (*p->mp == ' ')
	    {
	      /* Space matches 1+ whitespace(s).  */
	      if ((gfc_current_form == FORM_FREE)
		  && gfc_is_whitespace (c))
		continue;

	      p->mp++;
	    }

	  if (*p->mp != c)
	    {
	      /* Match failed.  */
	      p->mp = NULL;
	      possibles--;
	      continue;
	    }

	  p->mp++;
	  if (*p->mp == '\0')
	    {
	      /* Found a match.  */
	      match_loc = gfc_current_locus;
	      best_match = p;
	      possibles--;
	      p->mp = NULL;
	    }
	}
    }

  gfc_current_locus = match_loc;

  return (best_match == NULL) ? no_match : best_match->tag;
}


/* See if the current input looks like a name of some sort.  Modifies
   the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.  */

match
gfc_match_name (char *buffer)
{
  locus old_loc;
  int i, c;

  old_loc = gfc_current_locus;
  gfc_gobble_whitespace ();

  c = gfc_next_char ();
  if (!ISALPHA (c))
    {
      gfc_current_locus = old_loc;
      return MATCH_NO;
    }

  i = 0;

  do
    {
      buffer[i++] = c;

      if (i > gfc_option.max_identifier_length)
	{
	  gfc_error ("Name at %C is too long");
	  return MATCH_ERROR;
	}

      old_loc = gfc_current_locus;
      c = gfc_next_char ();
    }
  while (ISALNUM (c)
	 || c == '_'
	 || (gfc_option.flag_dollar_ok && c == '$'));

  buffer[i] = '\0';
  gfc_current_locus = old_loc;

  return MATCH_YES;
}


/* Match a symbol on the input.  Modifies the pointer to the symbol
   pointer if successful.  */

match
gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc)
{
  char buffer[GFC_MAX_SYMBOL_LEN + 1];
  match m;

  m = gfc_match_name (buffer);
  if (m != MATCH_YES)
    return m;

  if (host_assoc)
    return (gfc_get_ha_sym_tree (buffer, matched_symbol))
      ? MATCH_ERROR : MATCH_YES;

  if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
    return MATCH_ERROR;

  return MATCH_YES;
}


match
gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc)
{
  gfc_symtree *st;
  match m;

  m = gfc_match_sym_tree (&st, host_assoc);

  if (m == MATCH_YES)
    {
      if (st)
        *matched_symbol = st->n.sym;
      else
        *matched_symbol = NULL;
    }
  else
    *matched_symbol = NULL;
  return m;
}

/* Match an intrinsic operator.  Returns an INTRINSIC enum. While matching, 
   we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this 
   in matchexp.c.  */

match
gfc_match_intrinsic_op (gfc_intrinsic_op * result)
{
  gfc_intrinsic_op op;

  op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators);

  if (op == INTRINSIC_NONE)
    return MATCH_NO;

  *result = op;
  return MATCH_YES;
}


/* Match a loop control phrase:

    <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]

   If the final integer expression is not present, a constant unity
   expression is returned.  We don't return MATCH_ERROR until after
   the equals sign is seen.  */

match
gfc_match_iterator (gfc_iterator * iter, int init_flag)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_expr *var, *e1, *e2, *e3;
  locus start;
  match m;

  /* Match the start of an iterator without affecting the symbol
     table.  */

  start = gfc_current_locus;
  m = gfc_match (" %n =", name);
  gfc_current_locus = start;

  if (m != MATCH_YES)
    return MATCH_NO;

  m = gfc_match_variable (&var, 0);
  if (m != MATCH_YES)
    return MATCH_NO;

  gfc_match_char ('=');

  e1 = e2 = e3 = NULL;

  if (var->ref != NULL)
    {
      gfc_error ("Loop variable at %C cannot be a sub-component");
      goto cleanup;
    }

  if (var->symtree->n.sym->attr.intent == INTENT_IN)
    {
      gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
		 var->symtree->n.sym->name);
      goto cleanup;
    }

  if (var->symtree->n.sym->attr.pointer)
    {
      gfc_error ("Loop variable at %C cannot have the POINTER attribute");
      goto cleanup;
    }

  m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  if (gfc_match_char (',') != MATCH_YES)
    goto syntax;

  m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  if (gfc_match_char (',') != MATCH_YES)
    {
      e3 = gfc_int_expr (1);
      goto done;
    }

  m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
  if (m == MATCH_ERROR)
    goto cleanup;
  if (m == MATCH_NO)
    {
      gfc_error ("Expected a step value in iterator at %C");
      goto cleanup;
    }

done:
  iter->var = var;
  iter->start = e1;
  iter->end = e2;
  iter->step = e3;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in iterator at %C");

cleanup:
  gfc_free_expr (e1);
  gfc_free_expr (e2);
  gfc_free_expr (e3);

  return MATCH_ERROR;
}


/* Tries to match the next non-whitespace character on the input.
   This subroutine does not return MATCH_ERROR.  */

match
gfc_match_char (char c)
{
  locus where;

  where = gfc_current_locus;
  gfc_gobble_whitespace ();

  if (gfc_next_char () == c)
    return MATCH_YES;

  gfc_current_locus = where;
  return MATCH_NO;
}


/* General purpose matching subroutine.  The target string is a
   scanf-like format string in which spaces correspond to arbitrary
   whitespace (including no whitespace), characters correspond to
   themselves.  The %-codes are:

   %%  Literal percent sign
   %e  Expression, pointer to a pointer is set
   %s  Symbol, pointer to the symbol is set
   %n  Name, character buffer is set to name
   %t  Matches end of statement.
   %o  Matches an intrinsic operator, returned as an INTRINSIC enum.
   %l  Matches a statement label
   %v  Matches a variable expression (an lvalue)
   %   Matches a required space (in free form) and optional spaces.  */

match
gfc_match (const char *target, ...)
{
  gfc_st_label **label;
  int matches, *ip;
  locus old_loc;
  va_list argp;
  char c, *np;
  match m, n;
  void **vp;
  const char *p;

  old_loc = gfc_current_locus;
  va_start (argp, target);
  m = MATCH_NO;
  matches = 0;
  p = target;