module.c

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

    {
      /* This departure from the standard is flagged as an error.
	 It does, in fact, work correctly. TODO: Allow it
	 conditionally?  */
      if (sym->attr.flavor == FL_NAMELIST)
	{
	  check_name = find_use_name (sym->name);
	  if (check_name && strcmp (check_name, sym->name) != 0)
	    gfc_error("Namelist %s cannot be renamed by USE"
		      " association to %s.",
		      sym->name, check_name);
	}

      m = NULL;
      while (peek_atom () != ATOM_RPAREN)
	{
	  n = gfc_get_namelist ();
	  mio_symbol_ref (&n->sym);

	  if (sym->namelist == NULL)
	    sym->namelist = n;
	  else
	    m->next = n;

	  m = n;
	}
      sym->namelist_tail = m;
    }

  mio_rparen ();
}


/* Save/restore lists of gfc_interface stuctures.  When loading an
   interface, we are really appending to the existing list of
   interfaces.  Checking for duplicate and ambiguous interfaces has to
   be done later when all symbols have been loaded.  */

static void
mio_interface_rest (gfc_interface ** ip)
{
  gfc_interface *tail, *p;

  if (iomode == IO_OUTPUT)
    {
      if (ip != NULL)
	for (p = *ip; p; p = p->next)
	  mio_symbol_ref (&p->sym);
    }
  else
    {

      if (*ip == NULL)
	tail = NULL;
      else
	{
	  tail = *ip;
	  while (tail->next)
	    tail = tail->next;
	}

      for (;;)
	{
	  if (peek_atom () == ATOM_RPAREN)
	    break;

	  p = gfc_get_interface ();
	  p->where = gfc_current_locus;
	  mio_symbol_ref (&p->sym);

	  if (tail == NULL)
	    *ip = p;
	  else
	    tail->next = p;

	  tail = p;
	}
    }

  mio_rparen ();
}


/* Save/restore a nameless operator interface.  */

static void
mio_interface (gfc_interface ** ip)
{

  mio_lparen ();
  mio_interface_rest (ip);
}


/* Save/restore a named operator interface.  */

static void
mio_symbol_interface (const char **name, const char **module,
		      gfc_interface ** ip)
{

  mio_lparen ();

  mio_pool_string (name);
  mio_pool_string (module);

  mio_interface_rest (ip);
}


static void
mio_namespace_ref (gfc_namespace ** nsp)
{
  gfc_namespace *ns;
  pointer_info *p;

  p = mio_pointer_ref (nsp);

  if (p->type == P_UNKNOWN)
    p->type = P_NAMESPACE;

  if (iomode == IO_INPUT && p->integer != 0)
    {
      ns = (gfc_namespace *)p->u.pointer;
      if (ns == NULL)
	{
	  ns = gfc_get_namespace (NULL, 0);
	  associate_integer_pointer (p, ns);
	}
      else
	ns->refs++;
    }
}


/* Unlike most other routines, the address of the symbol node is
   already fixed on input and the name/module has already been filled
   in.  */

static void
mio_symbol (gfc_symbol * sym)
{
  gfc_formal_arglist *formal;

  mio_lparen ();

  mio_symbol_attribute (&sym->attr);
  mio_typespec (&sym->ts);

  /* Contained procedures don't have formal namespaces.  Instead we output the
     procedure namespace.  The will contain the formal arguments.  */
  if (iomode == IO_OUTPUT)
    {
      formal = sym->formal;
      while (formal && !formal->sym)
	formal = formal->next;

      if (formal)
	mio_namespace_ref (&formal->sym->ns);
      else
	mio_namespace_ref (&sym->formal_ns);
    }
  else
    {
      mio_namespace_ref (&sym->formal_ns);
      if (sym->formal_ns)
	{
	  sym->formal_ns->proc_name = sym;
	  sym->refs++;
	}
    }

  /* Save/restore common block links */
  mio_symbol_ref (&sym->common_next);

  mio_formal_arglist (sym);

  if (sym->attr.flavor == FL_PARAMETER)
    mio_expr (&sym->value);

  mio_array_spec (&sym->as);

  mio_symbol_ref (&sym->result);

  if (sym->attr.cray_pointee)
    mio_symbol_ref (&sym->cp_pointer);

  /* Note that components are always saved, even if they are supposed
     to be private.  Component access is checked during searching.  */

  mio_component_list (&sym->components);

  if (sym->components != NULL)
    sym->component_access =
      MIO_NAME(gfc_access) (sym->component_access, access_types);

  mio_namelist (sym);
  mio_rparen ();
}


/************************* Top level subroutines *************************/

/* Skip a list between balanced left and right parens.  */

static void
skip_list (void)
{
  int level;

  level = 0;
  do
    {
      switch (parse_atom ())
	{
	case ATOM_LPAREN:
	  level++;
	  break;

	case ATOM_RPAREN:
	  level--;
	  break;

	case ATOM_STRING:
	  gfc_free (atom_string);
	  break;

	case ATOM_NAME:
	case ATOM_INTEGER:
	  break;
	}
    }
  while (level > 0);
}


/* Load operator interfaces from the module.  Interfaces are unusual
   in that they attach themselves to existing symbols.  */

static void
load_operator_interfaces (void)
{
  const char *p;
  char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
  gfc_user_op *uop;

  mio_lparen ();

  while (peek_atom () != ATOM_RPAREN)
    {
      mio_lparen ();

      mio_internal_string (name);
      mio_internal_string (module);

      /* Decide if we need to load this one or not.  */
      p = find_use_name (name);
      if (p == NULL)
	{
	  while (parse_atom () != ATOM_RPAREN);
	}
      else
	{
	  uop = gfc_get_uop (p);
	  mio_interface_rest (&uop->operator);
	}
    }

  mio_rparen ();
}


/* Load interfaces from the module.  Interfaces are unusual in that
   they attach themselves to existing symbols.  */

static void
load_generic_interfaces (void)
{
  const char *p;
  char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *sym;

  mio_lparen ();

  while (peek_atom () != ATOM_RPAREN)
    {
      mio_lparen ();

      mio_internal_string (name);
      mio_internal_string (module);

      /* Decide if we need to load this one or not.  */
      p = find_use_name (name);

      if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
	{
	  while (parse_atom () != ATOM_RPAREN);
	  continue;
	}

      if (sym == NULL)
	{
	  gfc_get_symbol (p, NULL, &sym);

	  sym->attr.flavor = FL_PROCEDURE;
	  sym->attr.generic = 1;
	  sym->attr.use_assoc = 1;
	}

      mio_interface_rest (&sym->generic);
    }

  mio_rparen ();
}


/* Load common blocks.  */

static void
load_commons(void)
{
  char name[GFC_MAX_SYMBOL_LEN+1];
  gfc_common_head *p;

  mio_lparen ();

  while (peek_atom () != ATOM_RPAREN)
    {
      mio_lparen ();
      mio_internal_string (name);

      p = gfc_get_common (name, 1);

      mio_symbol_ref (&p->head);
      mio_integer (&p->saved);
      p->use_assoc = 1;

      mio_rparen();
    }

  mio_rparen();
}

/* load_equiv()-- Load equivalences. */

static void
load_equiv(void)
{
  gfc_equiv *head, *tail, *end;

  mio_lparen();

  end = gfc_current_ns->equiv;
  while(end != NULL && end->next != NULL)
    end = end->next;

  while(peek_atom() != ATOM_RPAREN) {
    mio_lparen();
    head = tail = NULL;

    while(peek_atom() != ATOM_RPAREN)
      {
	if (head == NULL)
	  head = tail = gfc_get_equiv();
	else
	  {
	    tail->eq = gfc_get_equiv();
	    tail = tail->eq;
	  }

	mio_pool_string(&tail->module);
	mio_expr(&tail->expr);
      }

    if (end == NULL)
      gfc_current_ns->equiv = head;
    else
      end->next = head;

    end = head;
    mio_rparen();
  }

  mio_rparen();
}

/* Recursive function to traverse the pointer_info tree and load a
   needed symbol.  We return nonzero if we load a symbol and stop the
   traversal, because the act of loading can alter the tree.  */

static int
load_needed (pointer_info * p)
{
  gfc_namespace *ns;
  pointer_info *q;
  gfc_symbol *sym;

  if (p == NULL)
    return 0;
  if (load_needed (p->left))
    return 1;
  if (load_needed (p->right))
    return 1;

  if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
    return 0;

  p->u.rsym.state = USED;

  set_module_locus (&p->u.rsym.where);

  sym = p->u.rsym.sym;
  if (sym == NULL)
    {
      q = get_integer (p->u.rsym.ns);

      ns = (gfc_namespace *) q->u.pointer;
      if (ns == NULL)
	{
	  /* Create an interface namespace if necessary.  These are
	     the namespaces that hold the formal parameters of module
	     procedures.  */

	  ns = gfc_get_namespace (NULL, 0);
	  associate_integer_pointer (q, ns);
	}

      sym = gfc_new_symbol (p->u.rsym.true_name, ns);
      sym->module = gfc_get_string (p->u.rsym.module);

      associate_integer_pointer (p, sym);
    }

  mio_symbol (sym);
  sym->attr.use_assoc = 1;

  return 1;
}


/* Recursive function for cleaning up things after a module has been
   read.  */

static void
read_cleanup (pointer_info * p)
{
  gfc_symtree *st;
  pointer_info *q;

  if (p == NULL)
    return;

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

  if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
    {
      /* Add hidden symbols to the symtree.  */
      q = get_integer (p->u.rsym.ns);
      st = get_unique_symtree ((gfc_namespace *) q->u.pointer);

      st->n.sym = p->u.rsym.sym;
      st->n.sym->refs++;

      /* Fixup any symtree references.  */
      p->u.rsym.symtree = st;
      resolve_fixups (p->u.rsym.stfixup, st);
      p->u.rsym.stfixup = NULL;
    }

  /* Free unused symbols.  */
  if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
    gfc_free_symbol (p->u.rsym.sym);
}


/* Read a module file.  */

static void
read_module (void)
{
  module_locus operator_interfaces, user_operators;
  const char *p;
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_intrinsic_op i;
  int ambiguous, j, nuse, symbol;
  pointer_info *info;
  gfc_use_rename *u;
  gfc_symtree *st;
  gfc_symbol *sym;

  get_module_locus (&operator_interfaces);	/* Skip these for now */
  skip_list ();

  get_module_locus (&user_operators);
  skip_list ();
  skip_list ();

  /* Skip commons and equivalences for now.  */
  skip_list ();
  skip_list ();

  mio_lparen ();

  /* Create the fixup nodes for all the symbols.  */

  while (peek_atom () != ATOM_RPAREN)
    {
      require_atom (ATOM_INTEGER);
      info = get_integer (atom_int);

      info->type = P_SYMBOL;
      info->u.rsym.state = UNUSED;

      mio_internal_string (info->u.rsym.true_name);
      mio_internal_string (info->u.rsym.module);

      require_atom (ATOM_INTEGER);
      info->u.rsym.ns = atom_int;

      get_module_locus (&info->u.rsym.where);
      skip_list ();

      /* See if the symbol has already been loaded by a previous module.
         If so, we reference the existing symbol and prevent it from
         being loaded again.  */

      sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);

        /* See if the symbol has already been loaded by a previous module.
	 If so, we reference the existing symbol and prevent it from
	 being loaded again.  This should not happen if the symbol being
	 read is an index for an assumed shape dummy array (ns != 1).  */

      sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);

      if (sym == NULL
	   || (sym->attr.flavor == FL_VARIABLE
	       && info->u.rsym.ns !=1))
	continue;

      info->u.rsym.state = USED;
      info->u.rsym.referenced = 1;
      info->u.rsym.sym = sym;
    }

  mio_rparen ();

  /* Parse the symtree lists.  This lets us mark which symbols need to
     be loaded.  Renaming is also done at this point by replacing the
     symtree name.  */

  mio_lparen ();

  while (peek_atom () != ATOM_RPAREN)
    {
      mio_internal_string (name);
      mio_integer (&ambiguous);
      mio_integer (&symbol);

      info = get_integer (symbol);

      /* See how many use names there are.  If none, go through the start
	 of the loop at least once.  */
      nuse = number_use_names (name);
      if (nuse == 0)
	nuse = 1;

      for (j = 1; j <= nuse; j++)
	{
	  /* Get the jth local name for this symbol.  */
	  p = find_use_name_n (name, &j);

	  /* Skip symtree nodes not in an ONLY clause.  */
	  if (p == NULL)
	    continue;

	  /* Check for ambiguous symbols.  */
	  st = gfc_find_symtree (gfc_current_ns->sym_root, p);

	  if (st != NULL)
	    {
	      if (st->n.sym != info->u.rsym.sym)
		st->ambiguous = 1;
	      info->u.rsym.symtree = st;
	    }
	  else
	    {
	      /* Create a symtree node in the current namespace for this symbol.  */
	      st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) :
	      gfc_new_symtree (&gfc_current_ns->sym_root, p);

	      st->ambiguous = ambiguous;

	      sym = info->u.rsym.sym;

	      /* Create a symbol node if it doesn't already exist.  */
	      if (sym == NULL)
		{
		  sym = info->u.rsym.sym =
		      gfc_new_symbol (info->u.rsym.true_name,
				      gfc_current_ns);

		  sym->module = gfc_get_string (info->u.rsym.module);
		}

	      st->n.sym = sym;
	      st->n.sym->refs++;

	      /* Store the symtree pointing to this symbol.  */
	      info->u.rsym.symtree = st;

	      if (info->u.rsym.state == UNUSED)
	        info->u.rsym.state = NEEDED;
	      info->u.rsym.referenced = 1;
	    }
	}
    }

  mio_rparen ();

  /* Load intrinsic operator interfaces.  */
  set_module_locus (&operator_interfaces);
  mio_lparen ();

  for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
    {
      if (i == INTRINSIC_USER)
	continue;

      if (only_flag)
	{
	  u = find_use_operator (i);

	  if (u == NULL)
	    {
	      skip_list ();
	      continue;
	    }

	  u->found = 1;
	}

      mio_interface (&gfc_current_ns->operator[i]);
    }

  mio_rparen ();

  /* Load generic and user operator interfaces.  These must follow the
     loading of symtree because otherwise symbols can be marked as
     ambiguous.  */

  set_module_locus (&user_operators);

  load_operator_interfaces ();
  load_generic_interfaces ();

  load_commons ();
  load_equiv();

  /* At this point, we read those symbols that are needed but haven't
     been loaded yet.