decl.c

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

/* Declaration statement matcher
   Copyright (C) 2002, 2004, 2005 Free Software Foundation, Inc.
   Contributed by Andy Vaught

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.  */


#include "config.h"
#include "system.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"


/* This flag is set if an old-style length selector is matched
   during a type-declaration statement.  */

static int old_char_selector;

/* When variables acquire types and attributes from a declaration
   statement, they get them from the following static variables.  The
   first part of a declaration sets these variables and the second
   part copies these into symbol structures.  */

static gfc_typespec current_ts;

static symbol_attribute current_attr;
static gfc_array_spec *current_as;
static int colon_seen;

/* Initializer of the previous enumerator.  */

static gfc_expr *last_initializer;

/* History of all the enumerators is maintained, so that
   kind values of all the enumerators could be updated depending
   upon the maximum initialized value.  */

typedef struct enumerator_history
{
  gfc_symbol *sym;
  gfc_expr *initializer;
  struct enumerator_history *next;
}
enumerator_history;

/* Header of enum history chain.  */

static enumerator_history *enum_history = NULL;

/* Pointer of enum history node containing largest initializer.  */

static enumerator_history *max_enum = NULL;

/* gfc_new_block points to the symbol of a newly matched block.  */

gfc_symbol *gfc_new_block;


/********************* DATA statement subroutines *********************/

/* Free a gfc_data_variable structure and everything beneath it.  */

static void
free_variable (gfc_data_variable * p)
{
  gfc_data_variable *q;

  for (; p; p = q)
    {
      q = p->next;
      gfc_free_expr (p->expr);
      gfc_free_iterator (&p->iter, 0);
      free_variable (p->list);

      gfc_free (p);
    }
}


/* Free a gfc_data_value structure and everything beneath it.  */

static void
free_value (gfc_data_value * p)
{
  gfc_data_value *q;

  for (; p; p = q)
    {
      q = p->next;
      gfc_free_expr (p->expr);
      gfc_free (p);
    }
}


/* Free a list of gfc_data structures.  */

void
gfc_free_data (gfc_data * p)
{
  gfc_data *q;

  for (; p; p = q)
    {
      q = p->next;

      free_variable (p->var);
      free_value (p->value);

      gfc_free (p);
    }
}


static match var_element (gfc_data_variable *);

/* Match a list of variables terminated by an iterator and a right
   parenthesis.  */

static match
var_list (gfc_data_variable * parent)
{
  gfc_data_variable *tail, var;
  match m;

  m = var_element (&var);
  if (m == MATCH_ERROR)
    return MATCH_ERROR;
  if (m == MATCH_NO)
    goto syntax;

  tail = gfc_get_data_variable ();
  *tail = var;

  parent->list = tail;

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

      m = gfc_match_iterator (&parent->iter, 1);
      if (m == MATCH_YES)
	break;
      if (m == MATCH_ERROR)
	return MATCH_ERROR;

      m = var_element (&var);
      if (m == MATCH_ERROR)
	return MATCH_ERROR;
      if (m == MATCH_NO)
	goto syntax;

      tail->next = gfc_get_data_variable ();
      tail = tail->next;

      *tail = var;
    }

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

syntax:
  gfc_syntax_error (ST_DATA);
  return MATCH_ERROR;
}


/* Match a single element in a data variable list, which can be a
   variable-iterator list.  */

static match
var_element (gfc_data_variable * new)
{
  match m;
  gfc_symbol *sym;

  memset (new, 0, sizeof (gfc_data_variable));

  if (gfc_match_char ('(') == MATCH_YES)
    return var_list (new);

  m = gfc_match_variable (&new->expr, 0);
  if (m != MATCH_YES)
    return m;

  sym = new->expr->symtree->n.sym;

  if (!sym->attr.function && gfc_current_ns->parent && gfc_current_ns->parent == sym->ns)
    {
      gfc_error ("Host associated variable '%s' may not be in the DATA "
		 "statement at %C.", sym->name);
      return MATCH_ERROR;
    }

  if (gfc_current_state () != COMP_BLOCK_DATA
	&& sym->attr.in_common
	&& gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
			   "common block variable '%s' in DATA statement at %C",
			   sym->name) == FAILURE)
    return MATCH_ERROR;

  if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
    return MATCH_ERROR;

  return MATCH_YES;
}


/* Match the top-level list of data variables.  */

static match
top_var_list (gfc_data * d)
{
  gfc_data_variable var, *tail, *new;
  match m;

  tail = NULL;

  for (;;)
    {
      m = var_element (&var);
      if (m == MATCH_NO)
	goto syntax;
      if (m == MATCH_ERROR)
	return MATCH_ERROR;

      new = gfc_get_data_variable ();
      *new = var;

      if (tail == NULL)
	d->var = new;
      else
	tail->next = new;

      tail = new;

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

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_DATA);
  return MATCH_ERROR;
}


static match
match_data_constant (gfc_expr ** result)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *sym;
  gfc_expr *expr;
  match m;

  m = gfc_match_literal_constant (&expr, 1);
  if (m == MATCH_YES)
    {
      *result = expr;
      return MATCH_YES;
    }

  if (m == MATCH_ERROR)
    return MATCH_ERROR;

  m = gfc_match_null (result);
  if (m != MATCH_NO)
    return m;

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

  if (gfc_find_symbol (name, NULL, 1, &sym))
    return MATCH_ERROR;

  if (sym == NULL
      || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
    {
      gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
		 name);
      return MATCH_ERROR;
    }
  else if (sym->attr.flavor == FL_DERIVED)
    return gfc_match_structure_constructor (sym, result);

  *result = gfc_copy_expr (sym->value);
  return MATCH_YES;
}


/* Match a list of values in a DATA statement.  The leading '/' has
   already been seen at this point.  */

static match
top_val_list (gfc_data * data)
{
  gfc_data_value *new, *tail;
  gfc_expr *expr;
  const char *msg;
  match m;

  tail = NULL;

  for (;;)
    {
      m = match_data_constant (&expr);
      if (m == MATCH_NO)
	goto syntax;
      if (m == MATCH_ERROR)
	return MATCH_ERROR;

      new = gfc_get_data_value ();

      if (tail == NULL)
	data->value = new;
      else
	tail->next = new;

      tail = new;

      if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
	{
	  tail->expr = expr;
	  tail->repeat = 1;
	}
      else
	{
	  signed int tmp;
	  msg = gfc_extract_int (expr, &tmp);
	  gfc_free_expr (expr);
	  if (msg != NULL)
	    {
	      gfc_error (msg);
	      return MATCH_ERROR;
	    }
	  tail->repeat = tmp;

	  m = match_data_constant (&tail->expr);
	  if (m == MATCH_NO)
	    goto syntax;
	  if (m == MATCH_ERROR)
	    return MATCH_ERROR;
	}

      if (gfc_match_char ('/') == MATCH_YES)
	break;
      if (gfc_match_char (',') == MATCH_NO)
	goto syntax;
    }

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_DATA);
  return MATCH_ERROR;
}


/* Matches an old style initialization.  */

static match
match_old_style_init (const char *name)
{
  match m;
  gfc_symtree *st;
  gfc_data *newdata;

  /* Set up data structure to hold initializers.  */
  gfc_find_sym_tree (name, NULL, 0, &st);
	  
  newdata = gfc_get_data ();
  newdata->var = gfc_get_data_variable ();
  newdata->var->expr = gfc_get_variable_expr (st);

  /* Match initial value list. This also eats the terminal
     '/'.  */
  m = top_val_list (newdata);
  if (m != MATCH_YES)
    {
      gfc_free (newdata);
      return m;
    }

  if (gfc_pure (NULL))
    {
      gfc_error ("Initialization at %C is not allowed in a PURE procedure");
      gfc_free (newdata);
      return MATCH_ERROR;
    }

  /* Chain in namespace list of DATA initializers.  */
  newdata->next = gfc_current_ns->data;
  gfc_current_ns->data = newdata;

  return m;
}

/* Match the stuff following a DATA statement. If ERROR_FLAG is set,
   we are matching a DATA statement and are therefore issuing an error
   if we encounter something unexpected, if not, we're trying to match 
   an old-style initialization expression of the form INTEGER I /2/.  */

match
gfc_match_data (void)
{
  gfc_data *new;
  match m;

  for (;;)
    {
      new = gfc_get_data ();
      new->where = gfc_current_locus;

      m = top_var_list (new);
      if (m != MATCH_YES)
	goto cleanup;

      m = top_val_list (new);
      if (m != MATCH_YES)
	goto cleanup;

      new->next = gfc_current_ns->data;
      gfc_current_ns->data = new;

      if (gfc_match_eos () == MATCH_YES)
	break;

      gfc_match_char (',');	/* Optional comma */
    }

  if (gfc_pure (NULL))
    {
      gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
      return MATCH_ERROR;
    }

  return MATCH_YES;

cleanup:
  gfc_free_data (new);
  return MATCH_ERROR;
}


/************************ Declaration statements *********************/

/* Match an intent specification.  Since this can only happen after an
   INTENT word, a legal intent-spec must follow.  */

static sym_intent
match_intent_spec (void)
{

  if (gfc_match (" ( in out )") == MATCH_YES)
    return INTENT_INOUT;
  if (gfc_match (" ( in )") == MATCH_YES)
    return INTENT_IN;
  if (gfc_match (" ( out )") == MATCH_YES)
    return INTENT_OUT;

  gfc_error ("Bad INTENT specification at %C");
  return INTENT_UNKNOWN;
}


/* Matches a character length specification, which is either a
   specification expression or a '*'.  */

static match
char_len_param_value (gfc_expr ** expr)
{

  if (gfc_match_char ('*') == MATCH_YES)
    {
      *expr = NULL;
      return MATCH_YES;
    }

  return gfc_match_expr (expr);
}


/* A character length is a '*' followed by a literal integer or a
   char_len_param_value in parenthesis.  */

static match
match_char_length (gfc_expr ** expr)
{
  int length, cnt;
  match m;

  m = gfc_match_char ('*');
  if (m != MATCH_YES)
    return m;

  /* cnt is unused, here.  */
  m = gfc_match_small_literal_int (&length, &cnt);
  if (m == MATCH_ERROR)
    return m;

  if (m == MATCH_YES)
    {
      *expr = gfc_int_expr (length);
      return m;
    }

  if (gfc_match_char ('(') == MATCH_NO)
    goto syntax;

  m = char_len_param_value (expr);
  if (m == MATCH_ERROR)
    return m;
  if (m == MATCH_NO)
    goto syntax;

  if (gfc_match_char (')') == MATCH_NO)
    {
      gfc_free_expr (*expr);
      *expr = NULL;
      goto syntax;
    }

  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in character length specification at %C");
  return MATCH_ERROR;
}


/* Special subroutine for finding a symbol.  Check if the name is found
   in the current name space.  If not, and we're compiling a function or
   subroutine and the parent compilation unit is an interface, then check
   to see if the name we've been given is the name of the interface
   (located in another namespace).  */

static int
find_special (const char *name, gfc_symbol ** result)
{
  gfc_state_data *s;
  int i;