symbol.c

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

/* Maintain binary trees of symbols.
   Copyright (C) 2000, 2001, 2002, 2003, 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 "parse.h"

/* Strings for all symbol attributes.  We use these for dumping the
   parse tree, in error messages, and also when reading and writing
   modules.  */

const mstring flavors[] =
{
  minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
  minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
  minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
  minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
  minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
  minit (NULL, -1)
};

const mstring procedures[] =
{
    minit ("UNKNOWN-PROC", PROC_UNKNOWN),
    minit ("MODULE-PROC", PROC_MODULE),
    minit ("INTERNAL-PROC", PROC_INTERNAL),
    minit ("DUMMY-PROC", PROC_DUMMY),
    minit ("INTRINSIC-PROC", PROC_INTRINSIC),
    minit ("EXTERNAL-PROC", PROC_EXTERNAL),
    minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
    minit (NULL, -1)
};

const mstring intents[] =
{
    minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
    minit ("IN", INTENT_IN),
    minit ("OUT", INTENT_OUT),
    minit ("INOUT", INTENT_INOUT),
    minit (NULL, -1)
};

const mstring access_types[] =
{
    minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
    minit ("PUBLIC", ACCESS_PUBLIC),
    minit ("PRIVATE", ACCESS_PRIVATE),
    minit (NULL, -1)
};

const mstring ifsrc_types[] =
{
    minit ("UNKNOWN", IFSRC_UNKNOWN),
    minit ("DECL", IFSRC_DECL),
    minit ("BODY", IFSRC_IFBODY),
    minit ("USAGE", IFSRC_USAGE)
};


/* This is to make sure the backend generates setup code in the correct
   order.  */

static int next_dummy_order = 1;


gfc_namespace *gfc_current_ns;

gfc_gsymbol *gfc_gsym_root = NULL;

static gfc_symbol *changed_syms = NULL;


/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/

/* The following static variable indicates whether a particular element has
   been explicitly set or not.  */

static int new_flag[GFC_LETTERS];


/* Handle a correctly parsed IMPLICIT NONE.  */

void
gfc_set_implicit_none (void)
{
  int i;

  if (gfc_current_ns->seen_implicit_none)
    {
      gfc_error ("Duplicate IMPLICIT NONE statement at %C");
      return;
    }

  gfc_current_ns->seen_implicit_none = 1;

  for (i = 0; i < GFC_LETTERS; i++)
    {
      gfc_clear_ts (&gfc_current_ns->default_type[i]);
      gfc_current_ns->set_flag[i] = 1;
    }
}


/* Reset the implicit range flags.  */

void
gfc_clear_new_implicit (void)
{
  int i;

  for (i = 0; i < GFC_LETTERS; i++)
    new_flag[i] = 0;
}


/* Prepare for a new implicit range.  Sets flags in new_flag[].  */

try
gfc_add_new_implicit_range (int c1, int c2)
{
  int i;

  c1 -= 'a';
  c2 -= 'a';

  for (i = c1; i <= c2; i++)
    {
      if (new_flag[i])
	{
	  gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
		     i + 'A');
	  return FAILURE;
	}

      new_flag[i] = 1;
    }

  return SUCCESS;
}


/* Add a matched implicit range for gfc_set_implicit().  Check if merging
   the new implicit types back into the existing types will work.  */

try
gfc_merge_new_implicit (gfc_typespec * ts)
{
  int i;

  if (gfc_current_ns->seen_implicit_none)
    {
      gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
      return FAILURE;
    }

  for (i = 0; i < GFC_LETTERS; i++)
    {
      if (new_flag[i])
	{

	  if (gfc_current_ns->set_flag[i])
	    {
	      gfc_error ("Letter %c already has an IMPLICIT type at %C",
			 i + 'A');
	      return FAILURE;
	    }
	  gfc_current_ns->default_type[i] = *ts;
	  gfc_current_ns->set_flag[i] = 1;
	}
    }
  return SUCCESS;
}


/* Given a symbol, return a pointer to the typespec for its default type.  */

gfc_typespec *
gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns)
{
  char letter;

  letter = sym->name[0];
  if (letter < 'a' || letter > 'z')
    gfc_internal_error ("gfc_get_default_type(): Bad symbol");

  if (ns == NULL)
    ns = gfc_current_ns;

  return &ns->default_type[letter - 'a'];
}


/* Given a pointer to a symbol, set its type according to the first
   letter of its name.  Fails if the letter in question has no default
   type.  */

try
gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
{
  gfc_typespec *ts;

  if (sym->ts.type != BT_UNKNOWN)
    gfc_internal_error ("gfc_set_default_type(): symbol already has a type");

  ts = gfc_get_default_type (sym, ns);

  if (ts->type == BT_UNKNOWN)
    {
      if (error_flag && !sym->attr.untyped)
	{
	  gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
		     sym->name, &sym->declared_at);
	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
	}

      return FAILURE;
    }

  sym->ts = *ts;
  sym->attr.implicit_type = 1;

  return SUCCESS;
}


/******************** Symbol attribute stuff *********************/

/* This is a generic conflict-checker.  We do this to avoid having a
   single conflict in two places.  */

#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
#define conf2(a) if (attr->a) { a2 = a; goto conflict; }

static try
check_conflict (symbol_attribute * attr, const char * name, locus * where)
{
  static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
    *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
    *intrinsic = "INTRINSIC", *allocatable = "ALLOCATABLE",
    *elemental = "ELEMENTAL", *private = "PRIVATE", *recursive = "RECURSIVE",
    *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
    *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
    *function = "FUNCTION", *subroutine = "SUBROUTINE",
    *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
    *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
    *cray_pointee = "CRAY POINTEE", *data = "DATA";

  const char *a1, *a2;

  if (where == NULL)
    where = &gfc_current_locus;

  if (attr->pointer && attr->intent != INTENT_UNKNOWN)
    {
      a1 = pointer;
      a2 = intent;
      goto conflict;
    }

  /* Check for attributes not allowed in a BLOCK DATA.  */
  if (gfc_current_state () == COMP_BLOCK_DATA)
    {
      a1 = NULL;

      if (attr->in_namelist)
	a1 = in_namelist;
      if (attr->allocatable)
	a1 = allocatable;
      if (attr->external)
	a1 = external;
      if (attr->optional)
	a1 = optional;
      if (attr->access == ACCESS_PRIVATE)
	a1 = private;
      if (attr->access == ACCESS_PUBLIC)
	a1 = public;
      if (attr->intent != INTENT_UNKNOWN)
	a1 = intent;

      if (a1 != NULL)
	{
	  gfc_error
	    ("%s attribute not allowed in BLOCK DATA program unit at %L", a1,
	     where);
	  return FAILURE;
	}
    }

  conf (dummy, save);
  conf (pointer, target);
  conf (pointer, external);
  conf (pointer, intrinsic);
  conf (pointer, elemental);

  conf (target, external);
  conf (target, intrinsic);
  conf (external, dimension);   /* See Fortran 95's R504.  */

  conf (external, intrinsic);
    
  if (attr->if_source || attr->contained)
    {
      conf (external, subroutine);
      conf (external, function);
    }

  conf (allocatable, pointer);
  conf (allocatable, dummy);	/* TODO: Allowed in Fortran 200x.  */
  conf (allocatable, function);	/* TODO: Allowed in Fortran 200x.  */
  conf (allocatable, result);	/* TODO: Allowed in Fortran 200x.  */
  conf (elemental, recursive);

  conf (in_common, dummy);
  conf (in_common, allocatable);
  conf (in_common, result);
  conf (in_common, save);
  conf (result, save);

  conf (dummy, result);

  conf (in_equivalence, use_assoc);
  conf (in_equivalence, dummy);
  conf (in_equivalence, target);
  conf (in_equivalence, pointer);
  conf (in_equivalence, function);
  conf (in_equivalence, result);
  conf (in_equivalence, entry);
  conf (in_equivalence, allocatable);

  conf (in_namelist, pointer);
  conf (in_namelist, allocatable);

  conf (entry, result);

  conf (function, subroutine);

  /* Cray pointer/pointee conflicts.  */
  conf (cray_pointer, cray_pointee);
  conf (cray_pointer, dimension);
  conf (cray_pointer, pointer);
  conf (cray_pointer, target);
  conf (cray_pointer, allocatable);
  conf (cray_pointer, external);
  conf (cray_pointer, intrinsic);
  conf (cray_pointer, in_namelist);
  conf (cray_pointer, function);
  conf (cray_pointer, subroutine);
  conf (cray_pointer, entry);

  conf (cray_pointee, allocatable);
  conf (cray_pointee, intent);
  conf (cray_pointee, optional);
  conf (cray_pointee, dummy);
  conf (cray_pointee, target);
  conf (cray_pointee, external);
  conf (cray_pointee, intrinsic);
  conf (cray_pointee, pointer);
  conf (cray_pointee, function);
  conf (cray_pointee, subroutine);
  conf (cray_pointee, entry);
  conf (cray_pointee, in_common);
  conf (cray_pointee, in_equivalence);

  conf (data, dummy);
  conf (data, function);
  conf (data, result);
  conf (data, allocatable);
  conf (data, use_assoc);

  a1 = gfc_code2string (flavors, attr->flavor);

  if (attr->in_namelist
      && attr->flavor != FL_VARIABLE
      && attr->flavor != FL_UNKNOWN)
    {

      a2 = in_namelist;
      goto conflict;
    }

  switch (attr->flavor)
    {
    case FL_PROGRAM:
    case FL_BLOCK_DATA:
    case FL_MODULE:
    case FL_LABEL:
      conf2 (dummy);
      conf2 (save);
      conf2 (pointer);
      conf2 (target);
      conf2 (external);
      conf2 (intrinsic);
      conf2 (allocatable);
      conf2 (result);
      conf2 (in_namelist);
      conf2 (optional);
      conf2 (function);
      conf2 (subroutine);
      break;

    case FL_VARIABLE:
    case FL_NAMELIST:
      break;

    case FL_PROCEDURE:
      conf2 (intent);

      if (attr->subroutine)
	{
	  conf2(save);
	  conf2(pointer);
	  conf2(target);
	  conf2(allocatable);
	  conf2(result);
	  conf2(in_namelist);
	  conf2(function);
	}

      switch (attr->proc)
	{
	case PROC_ST_FUNCTION:
	  conf2 (in_common);
	  conf2 (dummy);
	  break;

	case PROC_MODULE:
	  conf2 (dummy);
	  break;

	case PROC_DUMMY:
	  conf2 (result);
	  conf2 (in_common);
	  conf2 (save);
	  break;

	default:
	  break;
	}

      break;

    case FL_DERIVED:
      conf2 (dummy);
      conf2 (save);
      conf2 (pointer);
      conf2 (target);
      conf2 (external);
      conf2 (intrinsic);
      conf2 (allocatable);
      conf2 (optional);
      conf2 (entry);
      conf2 (function);
      conf2 (subroutine);

      if (attr->intent != INTENT_UNKNOWN)
	{
	  a2 = intent;
	  goto conflict;
	}
      break;

    case FL_PARAMETER:
      conf2 (external);
      conf2 (intrinsic);
      conf2 (optional);
      conf2 (allocatable);
      conf2 (function);
      conf2 (subroutine);
      conf2 (entry);
      conf2 (pointer);
      conf2 (target);
      conf2 (dummy);
      conf2 (in_common);
      conf2 (save);
      break;

    default:
      break;
    }

  return SUCCESS;

conflict:
  if (name == NULL)
    gfc_error ("%s attribute conflicts with %s attribute at %L",
	       a1, a2, where);
  else
    gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
	       a1, a2, name, where);

  return FAILURE;
}

#undef conf
#undef conf2


/* Mark a symbol as referenced.  */

void
gfc_set_sym_referenced (gfc_symbol * sym)
{
  if (sym->attr.referenced)
    return;

  sym->attr.referenced = 1;

  /* Remember which order dummy variables are accessed in.  */
  if (sym->attr.dummy)
    sym->dummy_order = next_dummy_order++;
}


/* Common subroutine called by attribute changing subroutines in order
   to prevent them from changing a symbol that has been
   use-associated.  Returns zero if it is OK to change the symbol,
   nonzero if not.  */

static int
check_used (symbol_attribute * attr, const char * name, locus * where)
{

  if (attr->use_assoc == 0)
    return 0;

  if (where == NULL)
    where = &gfc_current_locus;

  if (name == NULL)
    gfc_error ("Cannot change attributes of USE-associated symbol at %L",
	       where);
  else
    gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
	       name, where);

  return 1;
}


/* Used to prevent changing the attributes of a symbol after it has been
   used.  This check is only done for dummy variables as only these can be
   used in specification expressions.  Applying this to all symbols causes
   an error when we reach the body of a contained function.  */

static int
check_done (symbol_attribute * attr, locus * where)
{

  if (!(attr->dummy && attr->referenced))
    return 0;

  if (where == NULL)
    where = &gfc_current_locus;

  gfc_error ("Cannot change attributes of symbol at %L"
             " after it has been used", where);

  return 1;
}


/* Generate an error because of a duplicate attribute.  */

static void
duplicate_attr (const char *attr, locus * where)
{

  if (where == NULL)
    where = &gfc_current_locus;

  gfc_error ("Duplicate %s attribute specified at %L", attr, where);
}

/* Called from decl.c (attr_decl1) to check attributes, when declared separately.  */

try
gfc_add_attribute (symbol_attribute * attr, locus * where, uint attr_intent)
{

  if (check_used (attr, NULL, where)
	|| (attr_intent == 0 && check_done (attr, where)))
    return FAILURE;

  return check_conflict (attr, NULL, where);
}

try
gfc_add_allocatable (symbol_attribute * attr, locus * where)
{

  if (check_used (attr, NULL, where) || check_done (attr, where))
    return FAILURE;

  if (attr->allocatable)
    {
      duplicate_attr ("ALLOCATABLE", where);
      return FAILURE;
    }

  attr->allocatable = 1;
  return check_conflict (attr, NULL, where);
}


try
gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where)
{

  if (check_used (attr, name, where) || check_done (attr, where))
    return FAILURE;

  if (attr->dimension)
    {
      duplicate_attr ("DIMENSION", where);
      return FAILURE;
    }

  attr->dimension = 1;
  return check_conflict (attr, name, where);
}


try
gfc_add_external (symbol_attribute * attr, locus * where)
{

  if (check_used (attr, NULL, where) || check_done (attr, where))
    return FAILURE;

  if (attr->external)
    {
      duplicate_attr ("EXTERNAL", where);
      return FAILURE;
    }

  attr->external = 1;

  return check_conflict (attr, NULL, where);
}