interface.c

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

/* Deal with interfaces.
   Copyright (C) 2000, 2001, 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.  */


/* Deal with interfaces.  An explicit interface is represented as a
   singly linked list of formal argument structures attached to the
   relevant symbols.  For an implicit interface, the arguments don't
   point to symbols.  Explicit interfaces point to namespaces that
   contain the symbols within that interface.

   Implicit interfaces are linked together in a singly linked list
   along the next_if member of symbol nodes.  Since a particular
   symbol can only have a single explicit interface, the symbol cannot
   be part of multiple lists and a single next-member suffices.

   This is not the case for general classes, though.  An operator
   definition is independent of just about all other uses and has it's
   own head pointer.

   Nameless interfaces:
     Nameless interfaces create symbols with explicit interfaces within
     the current namespace.  They are otherwise unlinked.

   Generic interfaces:
     The generic name points to a linked list of symbols.  Each symbol
     has an explicit interface.  Each explicit interface has its own
     namespace containing the arguments.  Module procedures are symbols in
     which the interface is added later when the module procedure is parsed.

   User operators:
     User-defined operators are stored in a their own set of symtrees
     separate from regular symbols.  The symtrees point to gfc_user_op
     structures which in turn head up a list of relevant interfaces.

   Extended intrinsics and assignment:
     The head of these interface lists are stored in the containing namespace.

   Implicit interfaces:
     An implicit interface is represented as a singly linked list of
     formal argument list structures that don't point to any symbol
     nodes -- they just contain types.


   When a subprogram is defined, the program unit's name points to an
   interface as usual, but the link to the namespace is NULL and the
   formal argument list points to symbols within the same namespace as
   the program unit name.  */

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


/* The current_interface structure holds information about the
   interface currently being parsed.  This structure is saved and
   restored during recursive interfaces.  */

gfc_interface_info current_interface;


/* Free a singly linked list of gfc_interface structures.  */

void
gfc_free_interface (gfc_interface * intr)
{
  gfc_interface *next;

  for (; intr; intr = next)
    {
      next = intr->next;
      gfc_free (intr);
    }
}


/* Change the operators unary plus and minus into binary plus and
   minus respectively, leaving the rest unchanged.  */

static gfc_intrinsic_op
fold_unary (gfc_intrinsic_op operator)
{

  switch (operator)
    {
    case INTRINSIC_UPLUS:
      operator = INTRINSIC_PLUS;
      break;
    case INTRINSIC_UMINUS:
      operator = INTRINSIC_MINUS;
      break;
    default:
      break;
    }

  return operator;
}


/* Match a generic specification.  Depending on which type of
   interface is found, the 'name' or 'operator' pointers may be set.
   This subroutine doesn't return MATCH_NO.  */

match
gfc_match_generic_spec (interface_type * type,
			char *name,
			gfc_intrinsic_op *operator)
{
  char buffer[GFC_MAX_SYMBOL_LEN + 1];
  match m;
  gfc_intrinsic_op i;

  if (gfc_match (" assignment ( = )") == MATCH_YES)
    {
      *type = INTERFACE_INTRINSIC_OP;
      *operator = INTRINSIC_ASSIGN;
      return MATCH_YES;
    }

  if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
    {				/* Operator i/f */
      *type = INTERFACE_INTRINSIC_OP;
      *operator = fold_unary (i);
      return MATCH_YES;
    }

  if (gfc_match (" operator ( ") == MATCH_YES)
    {
      m = gfc_match_defined_op_name (buffer, 1);
      if (m == MATCH_NO)
	goto syntax;
      if (m != MATCH_YES)
	return MATCH_ERROR;

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

      strcpy (name, buffer);
      *type = INTERFACE_USER_OP;
      return MATCH_YES;
    }

  if (gfc_match_name (buffer) == MATCH_YES)
    {
      strcpy (name, buffer);
      *type = INTERFACE_GENERIC;
      return MATCH_YES;
    }

  *type = INTERFACE_NAMELESS;
  return MATCH_YES;

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


/* Match one of the five forms of an interface statement.  */

match
gfc_match_interface (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  interface_type type;
  gfc_symbol *sym;
  gfc_intrinsic_op operator;
  match m;

  m = gfc_match_space ();

  if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
    return MATCH_ERROR;


  /* If we're not looking at the end of the statement now, or if this
     is not a nameless interface but we did not see a space, punt.  */
  if (gfc_match_eos () != MATCH_YES
      || (type != INTERFACE_NAMELESS
	  && m != MATCH_YES))
    {
      gfc_error
	("Syntax error: Trailing garbage in INTERFACE statement at %C");
      return MATCH_ERROR;
    }

  current_interface.type = type;

  switch (type)
    {
    case INTERFACE_GENERIC:
      if (gfc_get_symbol (name, NULL, &sym))
	return MATCH_ERROR;

      if (!sym->attr.generic 
	  && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
	return MATCH_ERROR;

      current_interface.sym = gfc_new_block = sym;
      break;

    case INTERFACE_USER_OP:
      current_interface.uop = gfc_get_uop (name);
      break;

    case INTERFACE_INTRINSIC_OP:
      current_interface.op = operator;
      break;

    case INTERFACE_NAMELESS:
      break;
    }

  return MATCH_YES;
}


/* Match the different sort of generic-specs that can be present after
   the END INTERFACE itself.  */

match
gfc_match_end_interface (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  interface_type type;
  gfc_intrinsic_op operator;
  match m;

  m = gfc_match_space ();

  if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
    return MATCH_ERROR;

  /* If we're not looking at the end of the statement now, or if this
     is not a nameless interface but we did not see a space, punt.  */
  if (gfc_match_eos () != MATCH_YES
      || (type != INTERFACE_NAMELESS
	  && m != MATCH_YES))
    {
      gfc_error
	("Syntax error: Trailing garbage in END INTERFACE statement at %C");
      return MATCH_ERROR;
    }

  m = MATCH_YES;

  switch (current_interface.type)
    {
    case INTERFACE_NAMELESS:
      if (type != current_interface.type)
	{
	  gfc_error ("Expected a nameless interface at %C");
	  m = MATCH_ERROR;
	}

      break;

    case INTERFACE_INTRINSIC_OP:
      if (type != current_interface.type || operator != current_interface.op)
	{

	  if (current_interface.op == INTRINSIC_ASSIGN)
	    gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
	  else
	    gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
		       gfc_op2string (current_interface.op));

	  m = MATCH_ERROR;
	}

      break;

    case INTERFACE_USER_OP:
      /* Comparing the symbol node names is OK because only use-associated
         symbols can be renamed.  */
      if (type != current_interface.type
	  || strcmp (current_interface.uop->name, name) != 0)
	{
	  gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
		     current_interface.uop->name);
	  m = MATCH_ERROR;
	}

      break;

    case INTERFACE_GENERIC:
      if (type != current_interface.type
	  || strcmp (current_interface.sym->name, name) != 0)
	{
	  gfc_error ("Expecting 'END INTERFACE %s' at %C",
		     current_interface.sym->name);
	  m = MATCH_ERROR;
	}

      break;
    }

  return m;
}


/* Compare two derived types using the criteria in 4.4.2 of the standard,
   recursing through gfc_compare_types for the components.  */

int
gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
{
  gfc_component *dt1, *dt2;

  /* Special case for comparing derived types across namespaces.  If the
     true names and module names are the same and the module name is
     nonnull, then they are equal.  */
  if (strcmp (derived1->name, derived2->name) == 0
	&& derived1 != NULL && derived2 != NULL
	&& derived1->module != NULL && derived2->module != NULL
	&& strcmp (derived1->module, derived2->module) == 0)
    return 1;

  /* Compare type via the rules of the standard.  Both types must have
     the SEQUENCE attribute to be equal.  */

  if (strcmp (derived1->name, derived2->name))
    return 0;

  if (derived1->component_access == ACCESS_PRIVATE
	|| derived2->component_access == ACCESS_PRIVATE)
    return 0;

  if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
    return 0;

  dt1 = derived1->components;
  dt2 = derived2->components;

  /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
     simple test can speed things up.  Otherwise, lots of things have to
     match.  */
  for (;;)
    {
      if (strcmp (dt1->name, dt2->name) != 0)
	return 0;

      if (dt1->pointer != dt2->pointer)
	return 0;

      if (dt1->dimension != dt2->dimension)
	return 0;

      if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
	return 0;

      if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
	return 0;

      dt1 = dt1->next;
      dt2 = dt2->next;

      if (dt1 == NULL && dt2 == NULL)
	break;
      if (dt1 == NULL || dt2 == NULL)
	return 0;
    }

  return 1;
}

/* Compare two typespecs, recursively if necessary.  */

int
gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
{

  if (ts1->type != ts2->type)
    return 0;
  if (ts1->type != BT_DERIVED)
    return (ts1->kind == ts2->kind);

  /* Compare derived types.  */
  if (ts1->derived == ts2->derived)
    return 1;

  return gfc_compare_derived_types (ts1->derived ,ts2->derived);
}


/* Given two symbols that are formal arguments, compare their ranks
   and types.  Returns nonzero if they have the same rank and type,
   zero otherwise.  */

static int
compare_type_rank (gfc_symbol * s1, gfc_symbol * s2)
{
  int r1, r2;

  r1 = (s1->as != NULL) ? s1->as->rank : 0;
  r2 = (s2->as != NULL) ? s2->as->rank : 0;

  if (r1 != r2)
    return 0;			/* Ranks differ */

  return gfc_compare_types (&s1->ts, &s2->ts);
}


static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);

/* Given two symbols that are formal arguments, compare their types
   and rank and their formal interfaces if they are both dummy
   procedures.  Returns nonzero if the same, zero if different.  */

static int
compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2)
{

  if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
    return compare_type_rank (s1, s2);

  if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
    return 0;

  /* At this point, both symbols are procedures.  */
  if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
      || (s2->attr.function == 0 && s2->attr.subroutine == 0))
    return 0;

  if (s1->attr.function != s2->attr.function
      || s1->attr.subroutine != s2->attr.subroutine)
    return 0;

  if (s1->attr.function && compare_type_rank (s1, s2) == 0)
    return 0;

  return compare_interfaces (s1, s2, 0);	/* Recurse! */
}


/* Given a formal argument list and a keyword name, search the list
   for that keyword.  Returns the correct symbol node if found, NULL
   if not found.  */

static gfc_symbol *
find_keyword_arg (const char *name, gfc_formal_arglist * f)
{

  for (; f; f = f->next)
    if (strcmp (f->sym->name, name) == 0)
      return f->sym;

  return NULL;
}


/******** Interface checking subroutines **********/


/* Given an operator interface and the operator, make sure that all
   interfaces for that operator are legal.  */

static void
check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
{
  gfc_formal_arglist *formal;
  sym_intent i1, i2;
  gfc_symbol *sym;
  bt t1, t2;
  int args;

  if (intr == NULL)
    return;

  args = 0;
  t1 = t2 = BT_UNKNOWN;
  i1 = i2 = INTENT_UNKNOWN;

  for (formal = intr->sym->formal; formal; formal = formal->next)
    {
      sym = formal->sym;

      if (args == 0)
	{
	  t1 = sym->ts.type;
	  i1 = sym->attr.intent;
	}
      if (args == 1)
	{
	  t2 = sym->ts.type;
	  i2 = sym->attr.intent;
	}
      args++;
    }

  if (args == 0 || args > 2)
    goto num_args;

  sym = intr->sym;

  if (operator == INTRINSIC_ASSIGN)
    {
      if (!sym->attr.subroutine)
	{
	  gfc_error
	    ("Assignment operator interface at %L must be a SUBROUTINE",
	     &intr->where);
	  return;
	}
    }
  else
    {
      if (!sym->attr.function)
	{
	  gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
		     &intr->where);
	  return;
	}
    }

  switch (operator)
    {
    case INTRINSIC_PLUS:	/* Numeric unary or binary */
    case INTRINSIC_MINUS:
      if ((args == 1)
	  && (t1 == BT_INTEGER
	      || t1 == BT_REAL
	      || t1 == BT_COMPLEX))
	goto bad_repl;

      if ((args == 2)
	  && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
	  && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
	goto bad_repl;

      break;

    case INTRINSIC_POWER:	/* Binary numeric */
    case INTRINSIC_TIMES:
    case INTRINSIC_DIVIDE:

    case INTRINSIC_EQ:
    case INTRINSIC_NE:
      if (args == 1)
	goto num_args;

      if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
	  && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
	goto bad_repl;

      break;

    case INTRINSIC_GE:		/* Binary numeric operators that do not support */
    case INTRINSIC_LE:		/* complex numbers */
    case INTRINSIC_LT:
    case INTRINSIC_GT:
      if (args == 1)
	goto num_args;

      if ((t1 == BT_INTEGER || t1 == BT_REAL)
	  && (t2 == BT_INTEGER || t2 == BT_REAL))
	goto bad_repl;

      break;

    case INTRINSIC_OR:		/* Binary logical */
    case INTRINSIC_AND:
    case INTRINSIC_EQV:
    case INTRINSIC_NEQV:
      if (args == 1)
	goto num_args;
      if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
	goto bad_repl;
      break;

    case INTRINSIC_NOT:	/* Unary logical */
      if (args != 1)
	goto num_args;
      if (t1 == BT_LOGICAL)
	goto bad_repl;
      break;

    case INTRINSIC_CONCAT:	/* Binary string */
      if (args != 2)
	goto num_args;
      if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
	goto bad_repl;
      break;

    case INTRINSIC_ASSIGN:	/* Class by itself */
      if (args != 2)
	goto num_args;
      break;
    default:
      gfc_internal_error ("check_operator_interface(): Bad operator");
    }

  /* Check intents on operator interfaces.  */
  if (operator == INTRINSIC_ASSIGN)
    {
      if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
	gfc_error ("First argument of defined assignment at %L must be "
		   "INTENT(IN) or INTENT(INOUT)", &intr->where);

      if (i2 != INTENT_IN)
	gfc_error ("Second argument of defined assignment at %L must be "
		   "INTENT(IN)", &intr->where);
    }
  else
    {
      if (i1 != INTENT_IN)
	gfc_error ("First argument of operator interface at %L must be "
		   "INTENT(IN)", &intr->where);

      if (args == 2 && i2 != INTENT_IN)
	gfc_error ("Second argument of operator interface at %L must be "
		   "INTENT(IN)", &intr->where);
    }