symbol.c

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

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

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

  if (attr->intrinsic)
    {
      duplicate_attr ("INTRINSIC", where);
      return FAILURE;
    }

  attr->intrinsic = 1;

  return check_conflict (attr, NULL, where);
}


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

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

  if (attr->optional)
    {
      duplicate_attr ("OPTIONAL", where);
      return FAILURE;
    }

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


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

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

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


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

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

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


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

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

  if (attr->cray_pointee)
    {
      gfc_error ("Cray Pointee at %L appears in multiple pointer()"
		 " statements.", where);
      return FAILURE;
    }

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


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

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

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


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

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

  if (gfc_pure (NULL))
    {
      gfc_error
	("SAVE attribute at %L cannot be specified in a PURE procedure",
	 where);
      return FAILURE;
    }

  if (attr->save)
    {
	if (gfc_notify_std (GFC_STD_LEGACY, 
			    "Duplicate SAVE attribute specified at %L",
			    where) 
	    == FAILURE)
	  return FAILURE;
    }

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


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

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

  if (attr->target)
    {
      duplicate_attr ("TARGET", where);
      return FAILURE;
    }

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


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

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

  /* Duplicate dummy arguments are allowed due to ENTRY statements.  */
  attr->dummy = 1;
  return check_conflict (attr, name, where);
}


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

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

  /* Duplicate attribute already checked for.  */
  attr->in_common = 1;
  if (check_conflict (attr, name, where) == FAILURE)
    return FAILURE;

  if (attr->flavor == FL_VARIABLE)
    return SUCCESS;

  return gfc_add_flavor (attr, FL_VARIABLE, name, where);
}

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

  /* Duplicate attribute already checked for.  */
  attr->in_equivalence = 1;
  if (check_conflict (attr, name, where) == FAILURE)
    return FAILURE;

  if (attr->flavor == FL_VARIABLE)
    return SUCCESS;

  return gfc_add_flavor (attr, FL_VARIABLE, name, where);
}


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

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

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


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

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


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

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

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


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

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

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


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

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

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


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

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

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


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

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

  if (attr->entry)
    {
      duplicate_attr ("ENTRY", where);
      return FAILURE;
    }

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


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

  if (attr->flavor != FL_PROCEDURE
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
    return FAILURE;

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


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

  if (attr->flavor != FL_PROCEDURE
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
    return FAILURE;

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


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

  if (attr->flavor != FL_PROCEDURE
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
    return FAILURE;

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


/* Flavors are special because some flavors are not what Fortran
   considers attributes and can be reaffirmed multiple times.  */

try
gfc_add_flavor (symbol_attribute * attr, sym_flavor f, const char *name,
		locus * where)
{

  if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
       || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
       || f == FL_NAMELIST) && check_used (attr, name, where))
    return FAILURE;

  if (attr->flavor == f && f == FL_VARIABLE)
    return SUCCESS;

  if (attr->flavor != FL_UNKNOWN)
    {
      if (where == NULL)
	where = &gfc_current_locus;

      gfc_error ("%s attribute conflicts with %s attribute at %L",
		 gfc_code2string (flavors, attr->flavor),
		 gfc_code2string (flavors, f), where);

      return FAILURE;
    }

  attr->flavor = f;

  return check_conflict (attr, name, where);
}


try
gfc_add_procedure (symbol_attribute * attr, procedure_type t,
		   const char *name, locus * where)
{

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

  if (attr->flavor != FL_PROCEDURE
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
    return FAILURE;

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

  if (attr->proc != PROC_UNKNOWN)
    {
      gfc_error ("%s procedure at %L is already declared as %s procedure",
		 gfc_code2string (procedures, t), where,
		 gfc_code2string (procedures, attr->proc));

      return FAILURE;
    }

  attr->proc = t;

  /* Statement functions are always scalar and functions.  */
  if (t == PROC_ST_FUNCTION
      && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
	  || attr->dimension))
    return FAILURE;

  return check_conflict (attr, name, where);
}


try
gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where)
{

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

  if (attr->intent == INTENT_UNKNOWN)
    {
      attr->intent = intent;
      return check_conflict (attr, NULL, where);
    }

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

  gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
	     gfc_intent_string (attr->intent),
	     gfc_intent_string (intent), where);

  return FAILURE;
}


/* No checks for use-association in public and private statements.  */

try
gfc_add_access (symbol_attribute * attr, gfc_access access,
		const char *name, locus * where)
{

  if (attr->access == ACCESS_UNKNOWN)
    {
      attr->access = access;
      return check_conflict (attr, name, where);
    }

  if (where == NULL)
    where = &gfc_current_locus;
  gfc_error ("ACCESS specification at %L was already specified", where);

  return FAILURE;
}


try
gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source,
			    gfc_formal_arglist * formal, locus * where)
{

  if (check_used (&sym->attr, sym->name, where))
    return FAILURE;

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

  if (sym->attr.if_source != IFSRC_UNKNOWN
      && sym->attr.if_source != IFSRC_DECL)
    {
      gfc_error ("Symbol '%s' at %L already has an explicit interface",
		 sym->name, where);
      return FAILURE;
    }

  sym->formal = formal;
  sym->attr.if_source = source;

  return SUCCESS;
}


/* Add a type to a symbol.  */

try
gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where)
{
  sym_flavor flavor;

/* TODO: This is legal if it is reaffirming an implicit type.
  if (check_done (&sym->attr, where))
    return FAILURE;*/

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

  if (sym->ts.type != BT_UNKNOWN)
    {
      gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
		 where, gfc_basic_typename (sym->ts.type));
      return FAILURE;
    }

  flavor = sym->attr.flavor;

  if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
      || flavor == FL_LABEL || (flavor == FL_PROCEDURE
				&& sym->attr.subroutine)
      || flavor == FL_DERIVED || flavor == FL_NAMELIST)
    {
      gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
      return FAILURE;
    }

  sym->ts = *ts;
  return SUCCESS;
}


/* Clears all attributes.  */

void
gfc_clear_attr (symbol_attribute * attr)
{
  memset (attr, 0, sizeof(symbol_attribute));
}


/* Check for missing attributes in the new symbol.  Currently does
   nothing, but it's not clear that it is unnecessary yet.  */

try
gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED,
		  locus * where ATTRIBUTE_UNUSED)
{

  return SUCCESS;
}


/* Copy an attribute to a symbol attribute, bit by bit.  Some
   attributes have a lot of side-effects but cannot be present given
   where we are called from, so we ignore some bits.  */

try
gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
{

  if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
    goto fail;

  if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->optional && gfc_add_optional (dest, where) == FAILURE)
    goto fail;
  if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
    goto fail;
  if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->target && gfc_add_target (dest, where) == FAILURE)
    goto fail;
  if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->entry)
    dest->entry = 1;

  if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
    goto fail;

  if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
    goto fail;

  if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
    goto fail;

  if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
    goto fail;
  if (src->pure && gfc_add_pure (dest, where) == FAILURE)
    goto fail;
  if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
    goto fail;

  if (src->flavor != FL_UNKNOWN
      && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
    goto fail;

  if (src->intent != INTENT_UNKNOWN
      && gfc_add_intent (dest, src->intent, where) == FAILURE)
    goto fail;

  if (src->access != ACCESS_UNKNOWN
      && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
    goto fail;

  if (gfc_missing_attr (dest, where) == FAILURE)
    goto fail;

  if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
    goto fail;
  if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
    goto fail;    
  
  /* The subroutines that set these bits also cause flavors to be set,
     and that has already happened in the original, so don't let it
     happen again.  */
  if (src->external)
    dest->external = 1;
  if (src->intrinsic)
    dest->intrinsic = 1;

  return SUCCESS;

fail:
  return FAILURE;
}


/************** Component name management ************/

/* Component names of a derived type form their own little namespaces
   that are separate from all other spaces.  The space is composed of
   a singly linked list of gfc_component structures whose head is
   located in the parent symbol.  */


/* Add a component name to a symbol.  The call fails if the name is
   already present.  On success, the component pointer is modified to
   point to the additional component structure.  */

try
gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** component)
{
  gfc_component *p, *tail;

  tail = NULL;

  for (p = sym->components; p; p = p->next)
    {
      if (strcmp (p->name, name) == 0)
	{
	  gfc_error ("Component '%s' at %C already declared at %L",
		     name, &p->loc);
	  return FAILURE;
	}

      tail = p;
    }

  /* Allocate a new component.  */
  p = gfc_get_component ();

  if (tail == NULL)
    sym->components = p;
  else
    tail->next = p;

  p->name = gfc_get_string (name);
  p->loc = gfc_current_locus;

  *component = p;
  return SUCCESS;
}


/* Recursive function to switch derived types of all symbol in a
   namespace.  */

static void
switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to)
{
  gfc_symbol *sym;

  if (st == NULL)
    return;

  sym = st->n.sym;
  if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
    sym->ts.derived = to;