resolve.c

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

/* Perform type resolution on the various stuctures.
   Copyright (C) 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 "gfortran.h"
#include "arith.h"  /* For gfc_compare_expr().  */

/* Types used in equivalence statements.  */

typedef enum seq_type
{
  SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
}
seq_type;

/* Stack to push the current if we descend into a block during
   resolution.  See resolve_branch() and resolve_code().  */

typedef struct code_stack
{
  struct gfc_code *head, *current;
  struct code_stack *prev;
}
code_stack;

static code_stack *cs_base = NULL;


/* Nonzero if we're inside a FORALL block */

static int forall_flag;

/* Nonzero if we are processing a formal arglist. The corresponding function
   resets the flag each time that it is read.  */
static int formal_arg_flag = 0;

int
gfc_is_formal_arg (void)
{
  return formal_arg_flag;
}

/* Resolve types of formal argument lists.  These have to be done early so that
   the formal argument lists of module procedures can be copied to the
   containing module before the individual procedures are resolved
   individually.  We also resolve argument lists of procedures in interface
   blocks because they are self-contained scoping units.

   Since a dummy argument cannot be a non-dummy procedure, the only
   resort left for untyped names are the IMPLICIT types.  */

static void
resolve_formal_arglist (gfc_symbol * proc)
{
  gfc_formal_arglist *f;
  gfc_symbol *sym;
  int i;

  /* TODO: Procedures whose return character length parameter is not constant
     or assumed must also have explicit interfaces.  */
  if (proc->result != NULL)
    sym = proc->result;
  else
    sym = proc;

  if (gfc_elemental (proc)
      || sym->attr.pointer || sym->attr.allocatable
      || (sym->as && sym->as->rank > 0))
    proc->attr.always_explicit = 1;

  formal_arg_flag = 1;

  for (f = proc->formal; f; f = f->next)
    {
      sym = f->sym;

      if (sym == NULL)
	{
          /* Alternate return placeholder.  */
	  if (gfc_elemental (proc))
	    gfc_error ("Alternate return specifier in elemental subroutine "
		       "'%s' at %L is not allowed", proc->name,
		       &proc->declared_at);
          if (proc->attr.function)
            gfc_error ("Alternate return specifier in function "
                       "'%s' at %L is not allowed", proc->name,
                       &proc->declared_at);
	  continue;
	}

      if (sym->attr.if_source != IFSRC_UNKNOWN)
	resolve_formal_arglist (sym);

      if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
	{
	  if (gfc_pure (proc) && !gfc_pure (sym))
	    {
	      gfc_error
		("Dummy procedure '%s' of PURE procedure at %L must also "
		 "be PURE", sym->name, &sym->declared_at);
	      continue;
	    }

	  if (gfc_elemental (proc))
	    {
	      gfc_error
		("Dummy procedure at %L not allowed in ELEMENTAL procedure",
		 &sym->declared_at);
	      continue;
	    }

	  continue;
	}

      if (sym->ts.type == BT_UNKNOWN)
	{
	  if (!sym->attr.function || sym->result == sym)
	    gfc_set_default_type (sym, 1, sym->ns);
	}

      gfc_resolve_array_spec (sym->as, 0);

      /* We can't tell if an array with dimension (:) is assumed or deferred
         shape until we know if it has the pointer or allocatable attributes.
      */
      if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
          && !(sym->attr.pointer || sym->attr.allocatable))
        {
          sym->as->type = AS_ASSUMED_SHAPE;
          for (i = 0; i < sym->as->rank; i++)
            sym->as->lower[i] = gfc_int_expr (1);
        }

      if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
          || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
          || sym->attr.optional)
        proc->attr.always_explicit = 1;

      /* If the flavor is unknown at this point, it has to be a variable.
         A procedure specification would have already set the type.  */

      if (sym->attr.flavor == FL_UNKNOWN)
	gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);

      if (gfc_pure (proc))
	{
	  if (proc->attr.function && !sym->attr.pointer
              && sym->attr.flavor != FL_PROCEDURE
	      && sym->attr.intent != INTENT_IN)

	    gfc_error ("Argument '%s' of pure function '%s' at %L must be "
		       "INTENT(IN)", sym->name, proc->name,
		       &sym->declared_at);

	  if (proc->attr.subroutine && !sym->attr.pointer
	      && sym->attr.intent == INTENT_UNKNOWN)

	    gfc_error
	      ("Argument '%s' of pure subroutine '%s' at %L must have "
	       "its INTENT specified", sym->name, proc->name,
	       &sym->declared_at);
	}


      if (gfc_elemental (proc))
	{
	  if (sym->as != NULL)
	    {
	      gfc_error
		("Argument '%s' of elemental procedure at %L must be scalar",
		 sym->name, &sym->declared_at);
	      continue;
	    }

	  if (sym->attr.pointer)
	    {
	      gfc_error
		("Argument '%s' of elemental procedure at %L cannot have "
		 "the POINTER attribute", sym->name, &sym->declared_at);
	      continue;
	    }
	}

      /* Each dummy shall be specified to be scalar.  */
      if (proc->attr.proc == PROC_ST_FUNCTION)
        {
          if (sym->as != NULL)
            {
              gfc_error
                ("Argument '%s' of statement function at %L must be scalar",
                 sym->name, &sym->declared_at);
              continue;
            }

          if (sym->ts.type == BT_CHARACTER)
            {
              gfc_charlen *cl = sym->ts.cl;
              if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
                {
                  gfc_error
                    ("Character-valued argument '%s' of statement function at "
                     "%L must has constant length",
                     sym->name, &sym->declared_at);
                  continue;
                }
            }
        }
    }
  formal_arg_flag = 0;
}


/* Work function called when searching for symbols that have argument lists
   associated with them.  */

static void
find_arglists (gfc_symbol * sym)
{

  if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
    return;

  resolve_formal_arglist (sym);
}


/* Given a namespace, resolve all formal argument lists within the namespace.
 */

static void
resolve_formal_arglists (gfc_namespace * ns)
{

  if (ns == NULL)
    return;

  gfc_traverse_ns (ns, find_arglists);
}


static void
resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
{
  try t;
  
  /* If this namespace is not a function, ignore it.  */
  if (! sym
      || !(sym->attr.function
	   || sym->attr.flavor == FL_VARIABLE))
    return;

  /* Try to find out of what the return type is.  */
  if (sym->result != NULL)
    sym = sym->result;

  if (sym->ts.type == BT_UNKNOWN)
    {
      t = gfc_set_default_type (sym, 0, ns);

      if (t == FAILURE && !sym->attr.untyped)
	{
	  gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
		     sym->name, &sym->declared_at); /* FIXME */
	  sym->attr.untyped = 1;
	}
    }

  if (sym->ts.type == BT_CHARACTER)
    {
      gfc_charlen *cl = sym->ts.cl;
      if (!cl || !cl->length)
	gfc_error ("Character-valued internal function '%s' at %L must "
		   "not be assumed length", sym->name, &sym->declared_at);
    }
}


/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
   introduce duplicates.  */

static void
merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
{
  gfc_formal_arglist *f, *new_arglist;
  gfc_symbol *new_sym;

  for (; new_args != NULL; new_args = new_args->next)
    {
      new_sym = new_args->sym;
      /* See if ths arg is already in the formal argument list.  */
      for (f = proc->formal; f; f = f->next)
	{
	  if (new_sym == f->sym)
	    break;
	}

      if (f)
	continue;

      /* Add a new argument.  Argument order is not important.  */
      new_arglist = gfc_get_formal_arglist ();
      new_arglist->sym = new_sym;
      new_arglist->next = proc->formal;
      proc->formal  = new_arglist;
    }
}


/* Resolve alternate entry points.  If a symbol has multiple entry points we
   create a new master symbol for the main routine, and turn the existing
   symbol into an entry point.  */

static void
resolve_entries (gfc_namespace * ns)
{
  gfc_namespace *old_ns;
  gfc_code *c;
  gfc_symbol *proc;
  gfc_entry_list *el;
  char name[GFC_MAX_SYMBOL_LEN + 1];
  static int master_count = 0;

  if (ns->proc_name == NULL)
    return;

  /* No need to do anything if this procedure doesn't have alternate entry
     points.  */
  if (!ns->entries)
    return;

  /* We may already have resolved alternate entry points.  */
  if (ns->proc_name->attr.entry_master)
    return;

  /* If this isn't a procedure something has gone horribly wrong.  */
  gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
  
  /* Remember the current namespace.  */
  old_ns = gfc_current_ns;

  gfc_current_ns = ns;

  /* Add the main entry point to the list of entry points.  */
  el = gfc_get_entry_list ();
  el->sym = ns->proc_name;
  el->id = 0;
  el->next = ns->entries;
  ns->entries = el;
  ns->proc_name->attr.entry = 1;

  /* Add an entry statement for it.  */
  c = gfc_get_code ();
  c->op = EXEC_ENTRY;
  c->ext.entry = el;
  c->next = ns->code;
  ns->code = c;

  /* Create a new symbol for the master function.  */
  /* Give the internal function a unique name (within this file).
     Also include the function name so the user has some hope of figuring
     out what is going on.  */
  snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
	    master_count++, ns->proc_name->name);
  gfc_get_ha_symbol (name, &proc);
  gcc_assert (proc != NULL);

  gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
  if (ns->proc_name->attr.subroutine)
    gfc_add_subroutine (&proc->attr, proc->name, NULL);
  else
    {
      gfc_symbol *sym;
      gfc_typespec *ts, *fts;

      gfc_add_function (&proc->attr, proc->name, NULL);
      proc->result = proc;
      fts = &ns->entries->sym->result->ts;
      if (fts->type == BT_UNKNOWN)
	fts = gfc_get_default_type (ns->entries->sym->result, NULL);
      for (el = ns->entries->next; el; el = el->next)
	{
	  ts = &el->sym->result->ts;
	  if (ts->type == BT_UNKNOWN)
	    ts = gfc_get_default_type (el->sym->result, NULL);
	  if (! gfc_compare_types (ts, fts)
	      || (el->sym->result->attr.dimension
		  != ns->entries->sym->result->attr.dimension)
	      || (el->sym->result->attr.pointer
		  != ns->entries->sym->result->attr.pointer))
	    break;
	}

      if (el == NULL)
	{
	  sym = ns->entries->sym->result;
	  /* All result types the same.  */
	  proc->ts = *fts;
	  if (sym->attr.dimension)
	    gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
	  if (sym->attr.pointer)
	    gfc_add_pointer (&proc->attr, NULL);
	}
      else
	{
	  /* Otherwise the result will be passed through a union by
	     reference.  */
	  proc->attr.mixed_entry_master = 1;
	  for (el = ns->entries; el; el = el->next)
	    {
	      sym = el->sym->result;
	      if (sym->attr.dimension)
	      {
		if (el == ns->entries)
		  gfc_error
		  ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
		   sym->name, ns->entries->sym->name, &sym->declared_at);
	        else
		  gfc_error
		    ("ENTRY result %s can't be an array in FUNCTION %s at %L",
		     sym->name, ns->entries->sym->name, &sym->declared_at);
	      }
	      else if (sym->attr.pointer)
	      {
		if (el == ns->entries)
		  gfc_error
		  ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
		   sym->name, ns->entries->sym->name, &sym->declared_at);
	        else
		  gfc_error
		    ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
		     sym->name, ns->entries->sym->name, &sym->declared_at);
	      }
	      else
		{
		  ts = &sym->ts;
		  if (ts->type == BT_UNKNOWN)
		    ts = gfc_get_default_type (sym, NULL);
		  switch (ts->type)
		    {
		    case BT_INTEGER:
		      if (ts->kind == gfc_default_integer_kind)
			sym = NULL;
		      break;
		    case BT_REAL:
		      if (ts->kind == gfc_default_real_kind
			  || ts->kind == gfc_default_double_kind)
			sym = NULL;
		      break;
		    case BT_COMPLEX:
		      if (ts->kind == gfc_default_complex_kind)
			sym = NULL;
		      break;
		    case BT_LOGICAL:
		      if (ts->kind == gfc_default_logical_kind)
			sym = NULL;
		      break;
		    case BT_UNKNOWN:
		      /* We will issue error elsewhere.  */
		      sym = NULL;
		      break;
		    default:
		      break;
		    }
		  if (sym)
		  {
		    if (el == ns->entries)
		      gfc_error
			("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
			 sym->name, gfc_typename (ts), ns->entries->sym->name,
			 &sym->declared_at);
		    else
		      gfc_error
			("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
			 sym->name, gfc_typename (ts), ns->entries->sym->name,
			 &sym->declared_at);
		  }
		}
	    }
	}
    }
  proc->attr.access = ACCESS_PRIVATE;
  proc->attr.entry_master = 1;

  /* Merge all the entry point arguments.  */
  for (el = ns->entries; el; el = el->next)
    merge_argument_lists (proc, el->sym->formal);

  /* Use the master function for the function body.  */
  ns->proc_name = proc;

  /* Finalize the new symbols.  */
  gfc_commit_symbols ();

  /* Restore the original namespace.  */
  gfc_current_ns = old_ns;
}


/* Resolve contained function types.  Because contained functions can call one
   another, they have to be worked out before any of the contained procedures
   can be resolved.

   The good news is that if a function doesn't already have a type, the only
   way it can get one is through an IMPLICIT type or a RESULT variable, because
   by definition contained functions are contained namespace they're contained
   in, not in a sibling or parent namespace.  */

static void
resolve_contained_functions (gfc_namespace * ns)
{
  gfc_namespace *child;
  gfc_entry_list *el;

  resolve_formal_arglists (ns);

  for (child = ns->contained; child; child = child->sibling)
    {
      /* Resolve alternate entry points first.  */
      resolve_entries (child); 

      /* Then check function return types.  */
      resolve_contained_fntype (child->proc_name, child);
      for (el = child->entries; el; el = el->next)
	resolve_contained_fntype (el->sym, child);
    }
}


/* Resolve all of the elements of a structure constructor and make sure that
   the types are correct.  */