module.c

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

/* Handle modules, which amounts to loading and saving symbols and
   their attendant structures.
   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.  */

/* The syntax of gfortran modules resembles that of lisp lists, ie a
   sequence of atoms, which can be left or right parenthesis, names,
   integers or strings.  Parenthesis are always matched which allows
   us to skip over sections at high speed without having to know
   anything about the internal structure of the lists.  A "name" is
   usually a fortran 95 identifier, but can also start with '@' in
   order to reference a hidden symbol.

   The first line of a module is an informational message about what
   created the module, the file it came from and when it was created.
   The second line is a warning for people not to edit the module.
   The rest of the module looks like:

   ( ( <Interface info for UPLUS> )
     ( <Interface info for UMINUS> )
     ...
   )
   ( ( <name of operator interface> <module of op interface> <i/f1> ... )
     ...
   )
   ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
     ...
   )
   ( ( <common name> <symbol> <saved flag>)
     ...
   )

   ( equivalence list )

   ( <Symbol Number (in no particular order)>
     <True name of symbol>
     <Module name of symbol>
     ( <symbol information> )
     ...
   )
   ( <Symtree name>
     <Ambiguous flag>
     <Symbol number>
     ...
   )

   In general, symbols refer to other symbols by their symbol number,
   which are zero based.  Symbols are written to the module in no
   particular order.  */

#include "config.h"
#include "system.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
#include "parse.h" /* FIXME */

#define MODULE_EXTENSION ".mod"


/* Structure that describes a position within a module file.  */

typedef struct
{
  int column, line;
  fpos_t pos;
}
module_locus;


typedef enum
{
  P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
}
pointer_t;

/* The fixup structure lists pointers to pointers that have to
   be updated when a pointer value becomes known.  */

typedef struct fixup_t
{
  void **pointer;
  struct fixup_t *next;
}
fixup_t;


/* Structure for holding extra info needed for pointers being read.  */

typedef struct pointer_info
{
  BBT_HEADER (pointer_info);
  int integer;
  pointer_t type;

  /* The first component of each member of the union is the pointer
     being stored.  */

  fixup_t *fixup;

  union
  {
    void *pointer;	/* Member for doing pointer searches.  */

    struct
    {
      gfc_symbol *sym;
      char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
      enum
      { UNUSED, NEEDED, USED }
      state;
      int ns, referenced;
      module_locus where;
      fixup_t *stfixup;
      gfc_symtree *symtree;
    }
    rsym;

    struct
    {
      gfc_symbol *sym;
      enum
      { UNREFERENCED = 0, NEEDS_WRITE, WRITTEN }
      state;
    }
    wsym;
  }
  u;

}
pointer_info;

#define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))


/* Lists of rename info for the USE statement.  */

typedef struct gfc_use_rename
{
  char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1];
  struct gfc_use_rename *next;
  int found;
  gfc_intrinsic_op operator;
  locus where;
}
gfc_use_rename;

#define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))

/* Local variables */

/* The FILE for the module we're reading or writing.  */
static FILE *module_fp;

/* The name of the module we're reading (USE'ing) or writing.  */
static char module_name[GFC_MAX_SYMBOL_LEN + 1];

static int module_line, module_column, only_flag;
static enum
{ IO_INPUT, IO_OUTPUT }
iomode;

static gfc_use_rename *gfc_rename_list;
static pointer_info *pi_root;
static int symbol_number;	/* Counter for assigning symbol numbers */



/*****************************************************************/

/* Pointer/integer conversion.  Pointers between structures are stored
   as integers in the module file.  The next couple of subroutines
   handle this translation for reading and writing.  */

/* Recursively free the tree of pointer structures.  */

static void
free_pi_tree (pointer_info * p)
{
  if (p == NULL)
    return;

  if (p->fixup != NULL)
    gfc_internal_error ("free_pi_tree(): Unresolved fixup");

  free_pi_tree (p->left);
  free_pi_tree (p->right);

  gfc_free (p);
}


/* Compare pointers when searching by pointer.  Used when writing a
   module.  */

static int
compare_pointers (void * _sn1, void * _sn2)
{
  pointer_info *sn1, *sn2;

  sn1 = (pointer_info *) _sn1;
  sn2 = (pointer_info *) _sn2;

  if (sn1->u.pointer < sn2->u.pointer)
    return -1;
  if (sn1->u.pointer > sn2->u.pointer)
    return 1;

  return 0;
}


/* Compare integers when searching by integer.  Used when reading a
   module.  */

static int
compare_integers (void * _sn1, void * _sn2)
{
  pointer_info *sn1, *sn2;

  sn1 = (pointer_info *) _sn1;
  sn2 = (pointer_info *) _sn2;

  if (sn1->integer < sn2->integer)
    return -1;
  if (sn1->integer > sn2->integer)
    return 1;

  return 0;
}


/* Initialize the pointer_info tree.  */

static void
init_pi_tree (void)
{
  compare_fn compare;
  pointer_info *p;

  pi_root = NULL;
  compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;

  /* Pointer 0 is the NULL pointer.  */
  p = gfc_get_pointer_info ();
  p->u.pointer = NULL;
  p->integer = 0;
  p->type = P_OTHER;

  gfc_insert_bbt (&pi_root, p, compare);

  /* Pointer 1 is the current namespace.  */
  p = gfc_get_pointer_info ();
  p->u.pointer = gfc_current_ns;
  p->integer = 1;
  p->type = P_NAMESPACE;

  gfc_insert_bbt (&pi_root, p, compare);

  symbol_number = 2;
}


/* During module writing, call here with a pointer to something,
   returning the pointer_info node.  */

static pointer_info *
find_pointer (void *gp)
{
  pointer_info *p;

  p = pi_root;
  while (p != NULL)
    {
      if (p->u.pointer == gp)
	break;
      p = (gp < p->u.pointer) ? p->left : p->right;
    }

  return p;
}


/* Given a pointer while writing, returns the pointer_info tree node,
   creating it if it doesn't exist.  */

static pointer_info *
get_pointer (void *gp)
{
  pointer_info *p;

  p = find_pointer (gp);
  if (p != NULL)
    return p;

  /* Pointer doesn't have an integer.  Give it one.  */
  p = gfc_get_pointer_info ();

  p->u.pointer = gp;
  p->integer = symbol_number++;

  gfc_insert_bbt (&pi_root, p, compare_pointers);

  return p;
}


/* Given an integer during reading, find it in the pointer_info tree,
   creating the node if not found.  */

static pointer_info *
get_integer (int integer)
{
  pointer_info *p, t;
  int c;

  t.integer = integer;

  p = pi_root;
  while (p != NULL)
    {
      c = compare_integers (&t, p);
      if (c == 0)
	break;

      p = (c < 0) ? p->left : p->right;
    }

  if (p != NULL)
    return p;

  p = gfc_get_pointer_info ();
  p->integer = integer;
  p->u.pointer = NULL;

  gfc_insert_bbt (&pi_root, p, compare_integers);

  return p;
}


/* Recursive function to find a pointer within a tree by brute force.  */

static pointer_info *
fp2 (pointer_info * p, const void *target)
{
  pointer_info *q;

  if (p == NULL)
    return NULL;

  if (p->u.pointer == target)
    return p;

  q = fp2 (p->left, target);
  if (q != NULL)
    return q;

  return fp2 (p->right, target);
}


/* During reading, find a pointer_info node from the pointer value.
   This amounts to a brute-force search.  */

static pointer_info *
find_pointer2 (void *p)
{

  return fp2 (pi_root, p);
}


/* Resolve any fixups using a known pointer.  */
static void
resolve_fixups (fixup_t *f, void * gp)
{
  fixup_t *next;

  for (; f; f = next)
    {
      next = f->next;
      *(f->pointer) = gp;
      gfc_free (f);
    }
}

/* Call here during module reading when we know what pointer to
   associate with an integer.  Any fixups that exist are resolved at
   this time.  */

static void
associate_integer_pointer (pointer_info * p, void *gp)
{
  if (p->u.pointer != NULL)
    gfc_internal_error ("associate_integer_pointer(): Already associated");

  p->u.pointer = gp;

  resolve_fixups (p->fixup, gp);

  p->fixup = NULL;
}


/* During module reading, given an integer and a pointer to a pointer,
   either store the pointer from an already-known value or create a
   fixup structure in order to store things later.  Returns zero if
   the reference has been actually stored, or nonzero if the reference
   must be fixed later (ie associate_integer_pointer must be called
   sometime later.  Returns the pointer_info structure.  */

static pointer_info *
add_fixup (int integer, void *gp)
{
  pointer_info *p;
  fixup_t *f;
  char **cp;

  p = get_integer (integer);

  if (p->integer == 0 || p->u.pointer != NULL)
    {
      cp = gp;
      *cp = p->u.pointer;
    }
  else
    {
      f = gfc_getmem (sizeof (fixup_t));

      f->next = p->fixup;
      p->fixup = f;

      f->pointer = gp;
    }

  return p;
}


/*****************************************************************/

/* Parser related subroutines */

/* Free the rename list left behind by a USE statement.  */

static void
free_rename (void)
{
  gfc_use_rename *next;

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


/* Match a USE statement.  */

match
gfc_match_use (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_use_rename *tail = NULL, *new;
  interface_type type;
  gfc_intrinsic_op operator;
  match m;

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

  free_rename ();
  only_flag = 0;

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

  if (gfc_match (" only :") == MATCH_YES)
    only_flag = 1;

  if (gfc_match_eos () == MATCH_YES)
    return MATCH_YES;

  for (;;)
    {
      /* Get a new rename struct and add it to the rename list.  */
      new = gfc_get_use_rename ();
      new->where = gfc_current_locus;
      new->found = 0;

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

      /* See what kind of interface we're dealing with.  Assume it is
         not an operator.  */
      new->operator = INTRINSIC_NONE;
      if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
	goto cleanup;

      switch (type)
	{
	case INTERFACE_NAMELESS:
	  gfc_error ("Missing generic specification in USE statement at %C");
	  goto cleanup;

	case INTERFACE_GENERIC:
	  m = gfc_match (" =>");

	  if (only_flag)
	    {
	      if (m != MATCH_YES)
		strcpy (new->use_name, name);
	      else
		{
		  strcpy (new->local_name, name);

		  m = gfc_match_name (new->use_name);
		  if (m == MATCH_NO)
		    goto syntax;
		  if (m == MATCH_ERROR)
		    goto cleanup;
		}
	    }
	  else
	    {
	      if (m != MATCH_YES)
		goto syntax;
	      strcpy (new->local_name, name);

	      m = gfc_match_name (new->use_name);
	      if (m == MATCH_NO)
		goto syntax;
	      if (m == MATCH_ERROR)
		goto cleanup;
	    }

	  break;

	case INTERFACE_USER_OP:
	  strcpy (new->use_name, name);
	  /* Fall through */

	case INTERFACE_INTRINSIC_OP:
	  new->operator = operator;
	  break;
	}

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

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_USE);

cleanup:
  free_rename ();
  return MATCH_ERROR;
 }


/* Given a name and a number, inst, return the inst name
   under which to load this symbol. Returns NULL if this
   symbol shouldn't be loaded. If inst is zero, returns
   the number of instances of this name.  */

static const char *
find_use_name_n (const char *name, int *inst)
{
  gfc_use_rename *u;
  int i;

  i = 0;
  for (u = gfc_rename_list; u; u = u->next)
    {
      if (strcmp (u->use_name, name) != 0)
	continue;
      if (++i == *inst)
	break;
    }

  if (!*inst)
    {
      *inst = i;
      return NULL;
    }

  if (u == NULL)
    return only_flag ? NULL : name;

  u->found = 1;

  return (u->local_name[0] != '\0') ? u->local_name : name;
}

/* Given a name, return the name under which to load this symbol.
   Returns NULL if this symbol shouldn't be loaded.  */

static const char *
find_use_name (const char *name)
{
  int i = 1;
  return find_use_name_n (name, &i);
}

/* Given a real name, return the number of use names associated
   with it.  */

static int
number_use_names (const char *name)
{
  int i = 0;
  const char *c;
  c = find_use_name_n (name, &i);
  return i;
}


/* Try to find the operator in the current list.  */

static gfc_use_rename *
find_use_operator (gfc_intrinsic_op operator)
{
  gfc_use_rename *u;

  for (u = gfc_rename_list; u; u = u->next)
    if (u->operator == operator)
      return u;

  return NULL;
}


/*****************************************************************/