gcc/fortran/module.c

/* Handle modules, which amounts to loading and saving symbols and
   their attendant structures.
   Copyright (C) 2000-2019 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 3, 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 COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */

/* The syntax of gfortran modules resembles that of lisp lists, i.e. 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 "coretypes.h"
#include "options.h"
#include "tree.h"
#include "gfortran.h"
#include "stringpool.h"
#include "arith.h"
#include "match.h"
#include "parse.h" /* FIXME */
#include "constructor.h"
#include "cpp.h"
#include "scanner.h"
#include <zlib.h>

#define MODULE_EXTENSION ".mod"
#define SUBMODULE_EXTENSION ".smod"

/* Don't put any single quote (') in MOD_VERSION, if you want it to be
   recognized.  */
#define MOD_VERSION "15"


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

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

/* Structure for list of symbols of intrinsic modules.  */
typedef struct
{
  int id;
  const char *name;
  int value;
  int standard;
}
intmod_sym;


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.  */

enum gfc_rsym_state
{
  UNUSED,
  NEEDED,
  USED
};

enum gfc_wsym_state
{
  UNREFERENCED = 0,
  NEEDS_WRITE,
  WRITTEN
};

typedef struct pointer_info
{
  BBT_HEADER (pointer_info);
  HOST_WIDE_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, *module, *binding_label;
      fixup_t *stfixup;
      gfc_symtree *symtree;
      enum gfc_rsym_state state;
      int ns, referenced, renamed;
      module_locus where;
    }
    rsym;

    struct
    {
      gfc_symbol *sym;
      enum gfc_wsym_state state;
    }
    wsym;
  }
  u;

}
pointer_info;

#define gfc_get_pointer_info() XCNEW (pointer_info)


/* Local variables */

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


/* The name of the module we're reading (USE'ing) or writing.  */
static const char *module_name;
/* The name of the .smod file that the submodule will write to.  */
static const char *submodule_name;

static gfc_use_list *module_list;

/* If we're reading an intrinsic module, this is its ID.  */
static intmod_id current_intmod;

/* Content of module.  */
static char* module_content;

static long module_pos;
static int module_line, module_column, only_flag;
static int prev_module_line, prev_module_column;

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 */

/* Tells mio_expr_ref to make symbols for unused equivalence members.  */
static bool in_load_equiv;



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

/* 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);

  if (iomode == IO_INPUT)
    {
      XDELETEVEC (p->u.rsym.true_name);
      XDELETEVEC (p->u.rsym.module);
      XDELETEVEC (p->u.rsym.binding_label);
    }

  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 (HOST_WIDE_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;
}


/* 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;
      free (f);
    }
}


/* Convert a string such that it starts with a lower-case character. Used
   to convert the symtree name of a derived-type to the symbol name or to
   the name of the associated generic function.  */

const char *
gfc_dt_lower_string (const char *name)
{
  if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
    return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
			   &name[1]);
  return gfc_get_string ("%s", name);
}


/* Convert a string such that it starts with an upper-case character. Used to
   return the symtree-name for a derived type; the symbol name itself and the
   symtree/symbol name of the associated generic function start with a lower-
   case character.  */

const char *
gfc_dt_upper_string (const char *name)
{
  if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
    return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
			   &name[1]);
  return gfc_get_string ("%s", name);
}

/* 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 (i.e., associate_integer_pointer must be called
   sometime later.  Returns the pointer_info structure.  */

static pointer_info *
add_fixup (HOST_WIDE_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 = (char **) gp;
      *cp = (char *) p->u.pointer;
    }
  else
    {
      f = XCNEW (fixup_t);

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

      f->pointer = (void **) gp;
    }

  return p;
}


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

/* Parser related subroutines */

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

static void
free_rename (gfc_use_rename *list)
{
  gfc_use_rename *next;

  for (; list; list = next)
    {
      next = list->next;
      free (list);
    }
}


/* Match a USE statement.  */

match
gfc_match_use (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
  gfc_use_rename *tail = NULL, *new_use;
  interface_type type, type2;
  gfc_intrinsic_op op;
  match m;
  gfc_use_list *use_list;
  gfc_symtree *st;
  locus loc;

  use_list = gfc_get_use_list ();

  if (gfc_match (" , ") == MATCH_YES)
    {
      if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
	{
	  if (!gfc_notify_std (GFC_STD_F2003, "module "
			       "nature in USE statement at %C"))
	    goto cleanup;

	  if (strcmp (module_nature, "intrinsic") == 0)
	    use_list->intrinsic = true;
	  else
	    {
	      if (strcmp (module_nature, "non_intrinsic") == 0)
		use_list->non_intrinsic = true;
	      else
		{
		  gfc_error ("Module nature in USE statement at %C shall "
			     "be either INTRINSIC or NON_INTRINSIC");
		  goto cleanup;
		}
	    }
	}
      else
	{
	  /* Help output a better error message than "Unclassifiable
	     statement".  */
	  gfc_match (" %n", module_nature);
	  if (strcmp (module_nature, "intrinsic") == 0
	      || strcmp (module_nature, "non_intrinsic") == 0)
	    gfc_error ("\"::\" was expected after module nature at %C "
		       "but was not found");
	  free (use_list);
	  return m;
	}
    }
  else
    {
      m = gfc_match (" ::");
      if (m == MATCH_YES &&
	  !gfc_notify_std(GFC_STD_F2003, "\"USE :: module\" at %C"))
	goto cleanup;

      if (m != MATCH_YES)
	{
	  m = gfc_match ("% ");
	  if (m != MATCH_YES)
	    {
	      free (use_list);
	      return m;
	    }
	}
    }

  use_list->where = gfc_current_locus;

  m = gfc_match_name (name);
  if (m != MATCH_YES)
    {
      free (use_list);
      return m;
    }

  use_list->module_name = gfc_get_string ("%s", name);

  if (gfc_match_eos () == MATCH_YES)
    goto done;

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

  if (gfc_match (" only :") == MATCH_YES)
    use_list->only_flag = true;

  if (gfc_match_eos () == MATCH_YES)
    goto done;

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

      if (use_list->rename == NULL)
	use_list->rename = new_use;
      else
	tail->next = new_use;
      tail = new_use;

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

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

	case INTERFACE_USER_OP:
	case INTERFACE_GENERIC:
	case INTERFACE_DTIO:
	  loc = gfc_current_locus;

	  m = gfc_match (" =>");

	  if (type == INTERFACE_USER_OP && m == MATCH_YES
	      && (!gfc_notify_std(GFC_STD_F2003, "Renaming "
				  "operators in USE statements at %C")))
	    goto cleanup;

	  if (type == INTERFACE_USER_OP)
	    new_use->op = INTRINSIC_USER;

	  st = gfc_find_symtree (gfc_current_ns->sym_root, name);
	  if (st && type != INTERFACE_USER_OP)
	    {
	      if (m == MATCH_YES)
		gfc_error ("Symbol %qs at %L conflicts with the rename symbol "
			   "at %L", name, &st->n.sym->declared_at, &loc);
	      else
		gfc_error ("Symbol %qs at %L conflicts with the symbol "
			   "at %L", name, &st->n.sym->declared_at, &loc);
	      goto cleanup;
	    }

	  if (use_list->only_flag)
	    {
	      if (m != MATCH_YES)
		strcpy (new_use->use_name, name);
	      else
		{
		  strcpy (new_use->local_name, name);
		  m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
		  if (type != type2)
		    goto syntax;
		  if (m == MATCH_NO)
		    goto syntax;
		  if (m == MATCH_ERROR)
		    goto cleanup;
		}
	    }
	  else
	    {
	      if (m != MATCH_YES)
		goto syntax;
	      strcpy (new_use->local_name, name);

	      m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
	      if (type != type2)
		goto syntax;
	      if (m == MATCH_NO)
		goto syntax;
	      if (m == MATCH_ERROR)
		goto cleanup;
	    }

	  if (strcmp (new_use->use_name, use_list->module_name) == 0
	      || strcmp (new_use->local_name, use_list->module_name) == 0)
	    {
	      gfc_error ("The name %qs at %C has already been used as "
			 "an external module name", use_list->module_name);
	      goto cleanup;
	    }
	  break;

	case INTERFACE_INTRINSIC_OP:
	  new_use->op = op;
	  break;

	default:
	  gcc_unreachable ();
	}

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

done:
  if (module_list)
    {
      gfc_use_list *last = module_list;
      while (last->next)
	last = last->next;
      last->next = use_list;
    }
  else
    module_list = use_list;

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_USE);

cleanup:
  free_rename (use_list->rename);
  free (use_list);
  return MATCH_ERROR;
}


/* Match a SUBMODULE statement.

   According to F2008:11.2.3.2, "The submodule identifier is the
   ordered pair whose first element is the ancestor module name and
   whose second element is the submodule name. 'Submodule_name' is
   used for the submodule filename and uses '@' as a separator, whilst
   the name of the symbol for the module uses '.' as a a separator.
   The reasons for these choices are:
   (i) To follow another leading brand in the submodule filenames;
   (ii) Since '.' is not particularly visible in the filenames; and
   (iii) The linker does not permit '@' in mnemonics.  */

match
gfc_match_submodule (void)
{
  match m;
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_use_list *use_list;
  bool seen_colon = false;

  if (!gfc_notify_std (GFC_STD_F2008, "SUBMODULE declaration at %C"))
    return MATCH_ERROR;

  if (gfc_current_state () != COMP_NONE)
    {
      gfc_error ("SUBMODULE declaration at %C cannot appear within "
		 "another scoping unit");
      return MATCH_ERROR;
    }

  gfc_new_block = NULL;
  gcc_assert (module_list == NULL);

  if (gfc_match_char ('(') != MATCH_YES)
    goto syntax;

  while (1)
    {
      m = gfc_match (" %n", name);
      if (m != MATCH_YES)
	goto syntax;

      use_list = gfc_get_use_list ();
      use_list->where = gfc_current_locus;

      if (module_list)
	{
	  gfc_use_list *last = module_list;
	  while (last->next)
	    last = last->next;
	  last->next = use_list;
	  use_list->module_name
		= gfc_get_string ("%s.%s", module_list->module_name, name);
	  use_list->submodule_name
		= gfc_get_string ("%s@%s", module_list->module_name, name);
	}
      else
	{
	  module_list = use_list;
	  use_list->module_name = gfc_get_string ("%s", name);
	  use_list->submodule_name = use_list->module_name;
	}

      if (gfc_match_char (')') == MATCH_YES)
	break;

      if (gfc_match_char (':') != MATCH_YES
	  || seen_colon)
	goto syntax;

      seen_colon = true;
    }

  m = gfc_match (" %s%t", &gfc_new_block);
  if (m != MATCH_YES)
    goto syntax;

  submodule_name = gfc_get_string ("%s@%s", module_list->module_name,
				   gfc_new_block->name);

  gfc_new_block->name = gfc_get_string ("%s.%s",
					module_list->module_name,
					gfc_new_block->name);

  if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
		       gfc_new_block->name, NULL))
    return MATCH_ERROR;

  /* Just retain the ultimate .(s)mod file for reading, since it
     contains all the information in its ancestors.  */
  use_list = module_list;
  for (; module_list->next; use_list = module_list)
    {
      module_list = use_list->next;
      free (use_list);
    }

  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in SUBMODULE statement at %C");
  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. If interface is
   true, a user-defined operator is sought, otherwise only
   non-operators are sought.  */

static const char *
find_use_name_n (const char *name, int *inst, bool interface)
{
  gfc_use_rename *u;
  const char *low_name = NULL;
  int i;

  /* For derived types.  */
  if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
    low_name = gfc_dt_lower_string (name);

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

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

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

  u->found = 1;

  if (low_name)
    {
      if (u->local_name[0] == '\0')
	return name;
      return gfc_dt_upper_string (u->local_name);
    }

  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, bool interface)
{
  int i = 1;
  return find_use_name_n (name, &i, interface);
}


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

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


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

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

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

  return NULL;
}


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

/* The next couple of subroutines maintain a tree used to avoid a
   brute-force search for a combination of true name and module name.
   While symtree names, the name that a particular symbol is known by
   can changed with USE statements, we still have to keep track of the
   true names to generate the correct reference, and also avoid
   loading the same real symbol twice in a program unit.

   When we start reading, the true name tree is built and maintained
   as symbols are read.  The tree is searched as we load new symbols
   to see if it already exists someplace in the namespace.  */

typedef struct true_name
{
  BBT_HEADER (true_name);
  const char *name;
  gfc_symbol *sym;
}
true_name;

static true_name *true_name_root;


/* Compare two true_name structures.  */

static int
compare_true_names (void *_t1, void *_t2)
{
  true_name *t1, *t2;
  int c;

  t1 = (true_name *) _t1;
  t2 = (true_name *) _t2;

  c = ((t1->sym->module > t2->sym->module)
       - (t1->sym->module < t2->sym->module));
  if (c != 0)
    return c;

  return strcmp (t1->name, t2->name);
}


/* Given a true name, search the true name tree to see if it exists
   within the main namespace.  */

static gfc_symbol *
find_true_name (const char *name, const char *module)
{
  true_name t, *p;
  gfc_symbol sym;
  int c;

  t.name = gfc_get_string ("%s", name);
  if (module != NULL)
    sym.module = gfc_get_string ("%s", module);
  else
    sym.module = NULL;
  t.sym = &sym;

  p = true_name_root;
  while (p != NULL)
    {
      c = compare_true_names ((void *) (&t), (void *) p);
      if (c == 0)
	return p->sym;

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

  return NULL;
}


/* Given a gfc_symbol pointer that is not in the true name tree, add it.  */

static void
add_true_name (gfc_symbol *sym)
{
  true_name *t;

  t = XCNEW (true_name);
  t->sym = sym;
  if (gfc_fl_struct (sym->attr.flavor))
    t->name = gfc_dt_upper_string (sym->name);
  else
    t->name = sym->name;

  gfc_insert_bbt (&true_name_root, t, compare_true_names);
}


/* Recursive function to build the initial true name tree by
   recursively traversing the current namespace.  */

static void
build_tnt (gfc_symtree *st)
{
  const char *name;
  if (st == NULL)
    return;

  build_tnt (st->left);
  build_tnt (st->right);

  if (gfc_fl_struct (st->n.sym->attr.flavor))
    name = gfc_dt_upper_string (st->n.sym->name);
  else
    name = st->n.sym->name;

  if (find_true_name (name, st->n.sym->module) != NULL)
    return;

  add_true_name (st->n.sym);
}


/* Initialize the true name tree with the current namespace.  */

static void
init_true_name_tree (void)
{
  true_name_root = NULL;
  build_tnt (gfc_current_ns->sym_root);
}


/* Recursively free a true name tree node.  */

static void
free_true_name (true_name *t)
{
  if (t == NULL)
    return;
  free_true_name (t->left);
  free_true_name (t->right);

  free (t);
}


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

/* Module reading and writing.  */

/* The following are versions similar to the ones in scanner.c, but
   for dealing with compressed module files.  */

static gzFile
gzopen_included_file_1 (const char *name, gfc_directorylist *list,
                     bool module, bool system)
{
  char *fullname;
  gfc_directorylist *p;
  gzFile f;

  for (p = list; p; p = p->next)
    {
      if (module && !p->use_for_modules)
       continue;

      fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
      strcpy (fullname, p->path);
      strcat (fullname, name);

      f = gzopen (fullname, "r");
      if (f != NULL)
       {
         if (gfc_cpp_makedep ())
           gfc_cpp_add_dep (fullname, system);

         return f;
       }
    }

  return NULL;
}

static gzFile
gzopen_included_file (const char *name, bool include_cwd, bool module)
{
  gzFile f = NULL;

  if (IS_ABSOLUTE_PATH (name) || include_cwd)
    {
      f = gzopen (name, "r");
      if (f && gfc_cpp_makedep ())
       gfc_cpp_add_dep (name, false);
    }

  if (!f)
    f = gzopen_included_file_1 (name, include_dirs, module, false);

  return f;
}

static gzFile
gzopen_intrinsic_module (const char* name)
{
  gzFile f = NULL;

  if (IS_ABSOLUTE_PATH (name))
    {
      f = gzopen (name, "r");
      if (f && gfc_cpp_makedep ())
        gfc_cpp_add_dep (name, true);
    }

  if (!f)
    f = gzopen_included_file_1 (name, intrinsic_modules_dirs, true, true);

  return f;
}


enum atom_type
{
  ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
};

static atom_type last_atom;


/* The name buffer must be at least as long as a symbol name.  Right
   now it's not clear how we're going to store numeric constants--
   probably as a hexadecimal string, since this will allow the exact
   number to be preserved (this can't be done by a decimal
   representation).  Worry about that later.  TODO!  */

#define MAX_ATOM_SIZE 100

static HOST_WIDE_INT atom_int;
static char *atom_string, atom_name[MAX_ATOM_SIZE];


/* Report problems with a module.  Error reporting is not very
   elaborate, since this sorts of errors shouldn't really happen.
   This subroutine never returns.  */

static void bad_module (const char *) ATTRIBUTE_NORETURN;

static void
bad_module (const char *msgid)
{
  XDELETEVEC (module_content);
  module_content = NULL;

  switch (iomode)
    {
    case IO_INPUT:
      gfc_fatal_error ("Reading module %qs at line %d column %d: %s",
	  	       module_name, module_line, module_column, msgid);
      break;
    case IO_OUTPUT:
      gfc_fatal_error ("Writing module %qs at line %d column %d: %s",
	  	       module_name, module_line, module_column, msgid);
      break;
    default:
      gfc_fatal_error ("Module %qs at line %d column %d: %s",
	  	       module_name, module_line, module_column, msgid);
      break;
    }
}


/* Set the module's input pointer.  */

static void
set_module_locus (module_locus *m)
{
  module_column = m->column;
  module_line = m->line;
  module_pos = m->pos;
}


/* Get the module's input pointer so that we can restore it later.  */

static void
get_module_locus (module_locus *m)
{
  m->column = module_column;
  m->line = module_line;
  m->pos = module_pos;
}


/* Get the next character in the module, updating our reckoning of
   where we are.  */

static int
module_char (void)
{
  const char c = module_content[module_pos++];
  if (c == '\0')
    bad_module ("Unexpected EOF");

  prev_module_line = module_line;
  prev_module_column = module_column;

  if (c == '\n')
    {
      module_line++;
      module_column = 0;
    }

  module_column++;
  return c;
}

/* Unget a character while remembering the line and column.  Works for
   a single character only.  */

static void
module_unget_char (void)
{
  module_line = prev_module_line;
  module_column = prev_module_column;
  module_pos--;
}

/* Parse a string constant.  The delimiter is guaranteed to be a
   single quote.  */

static void
parse_string (void)
{
  int c;
  size_t cursz = 30;
  size_t len = 0;

  atom_string = XNEWVEC (char, cursz);

  for ( ; ; )
    {
      c = module_char ();

      if (c == '\'')
	{
	  int c2 = module_char ();
	  if (c2 != '\'')
	    {
	      module_unget_char ();
	      break;
	    }
	}

      if (len >= cursz)
	{
	  cursz *= 2;
	  atom_string = XRESIZEVEC (char, atom_string, cursz);
	}
      atom_string[len] = c;
      len++;
    }

  atom_string = XRESIZEVEC (char, atom_string, len + 1);
  atom_string[len] = '\0'; 	/* C-style string for debug purposes.  */
}


/* Parse an integer. Should fit in a HOST_WIDE_INT.  */

static void
parse_integer (int c)
{
  atom_int = c - '0';

  for (;;)
    {
      c = module_char ();
      if (!ISDIGIT (c))
	{
	  module_unget_char ();
	  break;
	}

      atom_int = 10 * atom_int + c - '0';
    }

}


/* Parse a name.  */

static void
parse_name (int c)
{
  char *p;
  int len;

  p = atom_name;

  *p++ = c;
  len = 1;

  for (;;)
    {
      c = module_char ();
      if (!ISALNUM (c) && c != '_' && c != '-')
	{
	  module_unget_char ();
	  break;
	}

      *p++ = c;
      if (++len > GFC_MAX_SYMBOL_LEN)
	bad_module ("Name too long");
    }

  *p = '\0';

}


/* Read the next atom in the module's input stream.  */

static atom_type
parse_atom (void)
{
  int c;

  do
    {
      c = module_char ();
    }
  while (c == ' ' || c == '\r' || c == '\n');

  switch (c)
    {
    case '(':
      return ATOM_LPAREN;

    case ')':
      return ATOM_RPAREN;

    case '\'':
      parse_string ();
      return ATOM_STRING;

    case '0':
    case '1':
    case '2':
    case '3':
    case '4':
    case '5':
    case '6':
    case '7':
    case '8':
    case '9':
      parse_integer (c);
      return ATOM_INTEGER;

    case 'a':
    case 'b':
    case 'c':
    case 'd':
    case 'e':
    case 'f':
    case 'g':
    case 'h':
    case 'i':
    case 'j':
    case 'k':
    case 'l':
    case 'm':
    case 'n':
    case 'o':
    case 'p':
    case 'q':
    case 'r':
    case 's':
    case 't':
    case 'u':
    case 'v':
    case 'w':
    case 'x':
    case 'y':
    case 'z':
    case 'A':
    case 'B':
    case 'C':
    case 'D':
    case 'E':
    case 'F':
    case 'G':
    case 'H':
    case 'I':
    case 'J':
    case 'K':
    case 'L':
    case 'M':
    case 'N':
    case 'O':
    case 'P':
    case 'Q':
    case 'R':
    case 'S':
    case 'T':
    case 'U':
    case 'V':
    case 'W':
    case 'X':
    case 'Y':
    case 'Z':
      parse_name (c);
      return ATOM_NAME;

    default:
      bad_module ("Bad name");
    }

  /* Not reached.  */
}


/* Peek at the next atom on the input.  */

static atom_type
peek_atom (void)
{
  int c;

  do
    {
      c = module_char ();
    }
  while (c == ' ' || c == '\r' || c == '\n');

  switch (c)
    {
    case '(':
      module_unget_char ();
      return ATOM_LPAREN;

    case ')':
      module_unget_char ();
      return ATOM_RPAREN;

    case '\'':
      module_unget_char ();
      return ATOM_STRING;

    case '0':
    case '1':
    case '2':
    case '3':
    case '4':
    case '5':
    case '6':
    case '7':
    case '8':
    case '9':
      module_unget_char ();
      return ATOM_INTEGER;

    case 'a':
    case 'b':
    case 'c':
    case 'd':
    case 'e':
    case 'f':
    case 'g':
    case 'h':
    case 'i':
    case 'j':
    case 'k':
    case 'l':
    case 'm':
    case 'n':
    case 'o':
    case 'p':
    case 'q':
    case 'r':
    case 's':
    case 't':
    case 'u':
    case 'v':
    case 'w':
    case 'x':
    case 'y':
    case 'z':
    case 'A':
    case 'B':
    case 'C':
    case 'D':
    case 'E':
    case 'F':
    case 'G':
    case 'H':
    case 'I':
    case 'J':
    case 'K':
    case 'L':
    case 'M':
    case 'N':
    case 'O':
    case 'P':
    case 'Q':
    case 'R':
    case 'S':
    case 'T':
    case 'U':
    case 'V':
    case 'W':
    case 'X':
    case 'Y':
    case 'Z':
      module_unget_char ();
      return ATOM_NAME;

    default:
      bad_module ("Bad name");
    }
}


/* Read the next atom from the input, requiring that it be a
   particular kind.  */

static void
require_atom (atom_type type)
{
  atom_type t;
  const char *p;
  int column, line;

  column = module_column;
  line = module_line;

  t = parse_atom ();
  if (t != type)
    {
      switch (type)
	{
	case ATOM_NAME:
	  p = _("Expected name");
	  break;
	case ATOM_LPAREN:
	  p = _("Expected left parenthesis");
	  break;
	case ATOM_RPAREN:
	  p = _("Expected right parenthesis");
	  break;
	case ATOM_INTEGER:
	  p = _("Expected integer");
	  break;
	case ATOM_STRING:
	  p = _("Expected string");
	  break;
	default:
	  gfc_internal_error ("require_atom(): bad atom type required");
	}

      module_column = column;
      module_line = line;
      bad_module (p);
    }
}


/* Given a pointer to an mstring array, require that the current input
   be one of the strings in the array.  We return the enum value.  */

static int
find_enum (const mstring *m)
{
  int i;

  i = gfc_string2code (m, atom_name);
  if (i >= 0)
    return i;

  bad_module ("find_enum(): Enum not found");

  /* Not reached.  */
}


/* Read a string. The caller is responsible for freeing.  */

static char*
read_string (void)
{
  char* p;
  require_atom (ATOM_STRING);
  p = atom_string;
  atom_string = NULL;
  return p;
}


/**************** Module output subroutines ***************************/

/* Output a character to a module file.  */

static void
write_char (char out)
{
  if (gzputc (module_fp, out) == EOF)
    gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno));

  if (out != '\n')
    module_column++;
  else
    {
      module_column = 1;
      module_line++;
    }
}


/* Write an atom to a module.  The line wrapping isn't perfect, but it
   should work most of the time.  This isn't that big of a deal, since
   the file really isn't meant to be read by people anyway.  */

static void
write_atom (atom_type atom, const void *v)
{
  char buffer[32];

  /* Workaround -Wmaybe-uninitialized false positive during
     profiledbootstrap by initializing them.  */
  int len;
  HOST_WIDE_INT i = 0;
  const char *p;

  switch (atom)
    {
    case ATOM_STRING:
    case ATOM_NAME:
      p = (const char *) v;
      break;

    case ATOM_LPAREN:
      p = "(";
      break;

    case ATOM_RPAREN:
      p = ")";
      break;

    case ATOM_INTEGER:
      i = *((const HOST_WIDE_INT *) v);

      snprintf (buffer, sizeof (buffer), HOST_WIDE_INT_PRINT_DEC, i);
      p = buffer;
      break;

    default:
      gfc_internal_error ("write_atom(): Trying to write dab atom");

    }

  if(p == NULL || *p == '\0')
     len = 0;
  else
  len = strlen (p);

  if (atom != ATOM_RPAREN)
    {
      if (module_column + len > 72)
	write_char ('\n');
      else
	{

	  if (last_atom != ATOM_LPAREN && module_column != 1)
	    write_char (' ');
	}
    }

  if (atom == ATOM_STRING)
    write_char ('\'');

  while (p != NULL && *p)
    {
      if (atom == ATOM_STRING && *p == '\'')
	write_char ('\'');
      write_char (*p++);
    }

  if (atom == ATOM_STRING)
    write_char ('\'');

  last_atom = atom;
}



/***************** Mid-level I/O subroutines *****************/

/* These subroutines let their caller read or write atoms without
   caring about which of the two is actually happening.  This lets a
   subroutine concentrate on the actual format of the data being
   written.  */

static void mio_expr (gfc_expr **);
pointer_info *mio_symbol_ref (gfc_symbol **);
pointer_info *mio_interface_rest (gfc_interface **);
static void mio_symtree_ref (gfc_symtree **);

/* Read or write an enumerated value.  On writing, we return the input
   value for the convenience of callers.  We avoid using an integer
   pointer because enums are sometimes inside bitfields.  */

static int
mio_name (int t, const mstring *m)
{
  if (iomode == IO_OUTPUT)
    write_atom (ATOM_NAME, gfc_code2string (m, t));
  else
    {
      require_atom (ATOM_NAME);
      t = find_enum (m);
    }

  return t;
}

/* Specialization of mio_name.  */

#define DECL_MIO_NAME(TYPE) \
 static inline TYPE \
 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
 { \
   return (TYPE) mio_name ((int) t, m); \
 }
#define MIO_NAME(TYPE) mio_name_##TYPE

static void
mio_lparen (void)
{
  if (iomode == IO_OUTPUT)
    write_atom (ATOM_LPAREN, NULL);
  else
    require_atom (ATOM_LPAREN);
}


static void
mio_rparen (void)
{
  if (iomode == IO_OUTPUT)
    write_atom (ATOM_RPAREN, NULL);
  else
    require_atom (ATOM_RPAREN);
}


static void
mio_integer (int *ip)
{
  if (iomode == IO_OUTPUT)
    {
      HOST_WIDE_INT hwi = *ip;
      write_atom (ATOM_INTEGER, &hwi);
    }
  else
    {
      require_atom (ATOM_INTEGER);
      *ip = atom_int;
    }
}

static void
mio_hwi (HOST_WIDE_INT *hwi)
{
  if (iomode == IO_OUTPUT)
    write_atom (ATOM_INTEGER, hwi);
  else
    {
      require_atom (ATOM_INTEGER);
      *hwi = atom_int;
    }
}


/* Read or write a gfc_intrinsic_op value.  */

static void
mio_intrinsic_op (gfc_intrinsic_op* op)
{
  /* FIXME: Would be nicer to do this via the operators symbolic name.  */
  if (iomode == IO_OUTPUT)
    {
      HOST_WIDE_INT converted = (HOST_WIDE_INT) *op;
      write_atom (ATOM_INTEGER, &converted);
    }
  else
    {
      require_atom (ATOM_INTEGER);
      *op = (gfc_intrinsic_op) atom_int;
    }
}


/* Read or write a character pointer that points to a string on the heap.  */

static const char *
mio_allocated_string (const char *s)
{
  if (iomode == IO_OUTPUT)
    {
      write_atom (ATOM_STRING, s);
      return s;
    }
  else
    {
      require_atom (ATOM_STRING);
      return atom_string;
    }
}


/* Functions for quoting and unquoting strings.  */

static char *
quote_string (const gfc_char_t *s, const size_t slength)
{
  const gfc_char_t *p;
  char *res, *q;
  size_t len = 0, i;

  /* Calculate the length we'll need: a backslash takes two ("\\"),
     non-printable characters take 10 ("\Uxxxxxxxx") and others take 1.  */
  for (p = s, i = 0; i < slength; p++, i++)
    {
      if (*p == '\\')
	len += 2;
      else if (!gfc_wide_is_printable (*p))
	len += 10;
      else
	len++;
    }

  q = res = XCNEWVEC (char, len + 1);
  for (p = s, i = 0; i < slength; p++, i++)
    {
      if (*p == '\\')
	*q++ = '\\', *q++ = '\\';
      else if (!gfc_wide_is_printable (*p))
	{
	  sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x",
		   (unsigned HOST_WIDE_INT) *p);
	  q += 10;
	}
      else
	*q++ = (unsigned char) *p;
    }

  res[len] = '\0';
  return res;
}

static gfc_char_t *
unquote_string (const char *s)
{
  size_t len, i;
  const char *p;
  gfc_char_t *res;

  for (p = s, len = 0; *p; p++, len++)
    {
      if (*p != '\\')
	continue;

      if (p[1] == '\\')
	p++;
      else if (p[1] == 'U')
	p += 9; /* That is a "\U????????".  */
      else
	gfc_internal_error ("unquote_string(): got bad string");
    }

  res = gfc_get_wide_string (len + 1);
  for (i = 0, p = s; i < len; i++, p++)
    {
      gcc_assert (*p);

      if (*p != '\\')
	res[i] = (unsigned char) *p;
      else if (p[1] == '\\')
	{
	  res[i] = (unsigned char) '\\';
	  p++;
	}
      else
	{
	  /* We read the 8-digits hexadecimal constant that follows.  */
	  int j;
	  unsigned n;
	  gfc_char_t c = 0;

	  gcc_assert (p[1] == 'U');
	  for (j = 0; j < 8; j++)
	    {
	      c = c << 4;
	      gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1);
	      c += n;
	    }

	  res[i] = c;
	  p += 9;
	}
    }

  res[len] = '\0';
  return res;
}


/* Read or write a character pointer that points to a wide string on the
   heap, performing quoting/unquoting of nonprintable characters using the
   form \U???????? (where each ? is a hexadecimal digit).
   Length is the length of the string, only known and used in output mode.  */

static const gfc_char_t *
mio_allocated_wide_string (const gfc_char_t *s, const size_t length)
{
  if (iomode == IO_OUTPUT)
    {
      char *quoted = quote_string (s, length);
      write_atom (ATOM_STRING, quoted);
      free (quoted);
      return s;
    }
  else
    {
      gfc_char_t *unquoted;

      require_atom (ATOM_STRING);
      unquoted = unquote_string (atom_string);
      free (atom_string);
      return unquoted;
    }
}


/* Read or write a string that is in static memory.  */

static void
mio_pool_string (const char **stringp)
{
  /* TODO: one could write the string only once, and refer to it via a
     fixup pointer.  */

  /* As a special case we have to deal with a NULL string.  This
     happens for the 'module' member of 'gfc_symbol's that are not in a
     module.  We read / write these as the empty string.  */
  if (iomode == IO_OUTPUT)
    {
      const char *p = *stringp == NULL ? "" : *stringp;
      write_atom (ATOM_STRING, p);
    }
  else
    {
      require_atom (ATOM_STRING);
      *stringp = (atom_string[0] == '\0'
		  ? NULL : gfc_get_string ("%s", atom_string));
      free (atom_string);
    }
}


/* Read or write a string that is inside of some already-allocated
   structure.  */

static void
mio_internal_string (char *string)
{
  if (iomode == IO_OUTPUT)
    write_atom (ATOM_STRING, string);
  else
    {
      require_atom (ATOM_STRING);
      strcpy (string, atom_string);
      free (atom_string);
    }
}


enum ab_attribute
{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
  AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
  AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
  AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
  AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
  AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
  AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP,
  AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
  AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
  AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET,
  AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE,
  AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
  AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK,
  AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE,
  AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING,
  AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER,
  AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ
};

static const mstring attr_bits[] =
{
    minit ("ALLOCATABLE", AB_ALLOCATABLE),
    minit ("ARTIFICIAL", AB_ARTIFICIAL),
    minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
    minit ("DIMENSION", AB_DIMENSION),
    minit ("CODIMENSION", AB_CODIMENSION),
    minit ("CONTIGUOUS", AB_CONTIGUOUS),
    minit ("EXTERNAL", AB_EXTERNAL),
    minit ("INTRINSIC", AB_INTRINSIC),
    minit ("OPTIONAL", AB_OPTIONAL),
    minit ("POINTER", AB_POINTER),
    minit ("VOLATILE", AB_VOLATILE),
    minit ("TARGET", AB_TARGET),
    minit ("THREADPRIVATE", AB_THREADPRIVATE),
    minit ("DUMMY", AB_DUMMY),
    minit ("RESULT", AB_RESULT),
    minit ("DATA", AB_DATA),
    minit ("IN_NAMELIST", AB_IN_NAMELIST),
    minit ("IN_COMMON", AB_IN_COMMON),
    minit ("FUNCTION", AB_FUNCTION),
    minit ("SUBROUTINE", AB_SUBROUTINE),
    minit ("SEQUENCE", AB_SEQUENCE),
    minit ("ELEMENTAL", AB_ELEMENTAL),
    minit ("PURE", AB_PURE),
    minit ("RECURSIVE", AB_RECURSIVE),
    minit ("GENERIC", AB_GENERIC),
    minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
    minit ("CRAY_POINTER", AB_CRAY_POINTER),
    minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
    minit ("IS_BIND_C", AB_IS_BIND_C),
    minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
    minit ("IS_ISO_C", AB_IS_ISO_C),
    minit ("VALUE", AB_VALUE),
    minit ("ALLOC_COMP", AB_ALLOC_COMP),
    minit ("COARRAY_COMP", AB_COARRAY_COMP),
    minit ("LOCK_COMP", AB_LOCK_COMP),
    minit ("EVENT_COMP", AB_EVENT_COMP),
    minit ("POINTER_COMP", AB_POINTER_COMP),
    minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
    minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
    minit ("ZERO_COMP", AB_ZERO_COMP),
    minit ("PROTECTED", AB_PROTECTED),
    minit ("ABSTRACT", AB_ABSTRACT),
    minit ("IS_CLASS", AB_IS_CLASS),
    minit ("PROCEDURE", AB_PROCEDURE),
    minit ("PROC_POINTER", AB_PROC_POINTER),
    minit ("VTYPE", AB_VTYPE),
    minit ("VTAB", AB_VTAB),
    minit ("CLASS_POINTER", AB_CLASS_POINTER),
    minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
    minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
    minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET),
    minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY),
    minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE),
    minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE),
    minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN),
    minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR),
    minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT),
    minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK),
    minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK),
    minit ("PDT_KIND", AB_PDT_KIND),
    minit ("PDT_LEN", AB_PDT_LEN),
    minit ("PDT_TYPE", AB_PDT_TYPE),
    minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE),
    minit ("PDT_ARRAY", AB_PDT_ARRAY),
    minit ("PDT_STRING", AB_PDT_STRING),
    minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG),
    minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER),
    minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR),
    minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ),
    minit (NULL, -1)
};

/* For binding attributes.  */
static const mstring binding_passing[] =
{
    minit ("PASS", 0),
    minit ("NOPASS", 1),
    minit (NULL, -1)
};
static const mstring binding_overriding[] =
{
    minit ("OVERRIDABLE", 0),
    minit ("NON_OVERRIDABLE", 1),
    minit ("DEFERRED", 2),
    minit (NULL, -1)
};
static const mstring binding_generic[] =
{
    minit ("SPECIFIC", 0),
    minit ("GENERIC", 1),
    minit (NULL, -1)
};
static const mstring binding_ppc[] =
{
    minit ("NO_PPC", 0),
    minit ("PPC", 1),
    minit (NULL, -1)
};

/* Specialization of mio_name.  */
DECL_MIO_NAME (ab_attribute)
DECL_MIO_NAME (ar_type)
DECL_MIO_NAME (array_type)
DECL_MIO_NAME (bt)
DECL_MIO_NAME (expr_t)
DECL_MIO_NAME (gfc_access)
DECL_MIO_NAME (gfc_intrinsic_op)
DECL_MIO_NAME (ifsrc)
DECL_MIO_NAME (save_state)
DECL_MIO_NAME (procedure_type)
DECL_MIO_NAME (ref_type)
DECL_MIO_NAME (sym_flavor)
DECL_MIO_NAME (sym_intent)
DECL_MIO_NAME (inquiry_type)
#undef DECL_MIO_NAME

/* Verify OACC_ROUTINE_LOP_NONE.  */

static void
verify_OACC_ROUTINE_LOP_NONE (enum oacc_routine_lop lop)
{
  if (lop != OACC_ROUTINE_LOP_NONE)
    bad_module ("Unsupported: multiple OpenACC 'routine' levels of parallelism");
}

/* Symbol attributes are stored in list with the first three elements
   being the enumerated fields, while the remaining elements (if any)
   indicate the individual attribute bits.  The access field is not
   saved-- it controls what symbols are exported when a module is
   written.  */

static void
mio_symbol_attribute (symbol_attribute *attr)
{
  atom_type t;
  unsigned ext_attr,extension_level;

  mio_lparen ();

  attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
  attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
  attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
  attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
  attr->save = MIO_NAME (save_state) (attr->save, save_status);

  ext_attr = attr->ext_attr;
  mio_integer ((int *) &ext_attr);
  attr->ext_attr = ext_attr;

  extension_level = attr->extension;
  mio_integer ((int *) &extension_level);
  attr->extension = extension_level;

  if (iomode == IO_OUTPUT)
    {
      if (attr->allocatable)
	MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
      if (attr->artificial)
	MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits);
      if (attr->asynchronous)
	MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
      if (attr->dimension)
	MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
      if (attr->codimension)
	MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
      if (attr->contiguous)
	MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
      if (attr->external)
	MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
      if (attr->intrinsic)
	MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
      if (attr->optional)
	MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
      if (attr->pointer)
	MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
      if (attr->class_pointer)
	MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
      if (attr->is_protected)
	MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
      if (attr->value)
	MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
      if (attr->volatile_)
	MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
      if (attr->target)
	MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
      if (attr->threadprivate)
	MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
      if (attr->dummy)
	MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
      if (attr->result)
	MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
      /* We deliberately don't preserve the "entry" flag.  */

      if (attr->data)
	MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
      if (attr->in_namelist)
	MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
      if (attr->in_common)
	MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);

      if (attr->function)
	MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
      if (attr->subroutine)
	MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
      if (attr->generic)
	MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
      if (attr->abstract)
	MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);

      if (attr->sequence)
	MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
      if (attr->elemental)
	MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
      if (attr->pure)
	MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
      if (attr->implicit_pure)
	MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
      if (attr->unlimited_polymorphic)
	MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits);
      if (attr->recursive)
	MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
      if (attr->always_explicit)
	MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
      if (attr->cray_pointer)
	MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
      if (attr->cray_pointee)
	MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
      if (attr->is_bind_c)
	MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
      if (attr->is_c_interop)
	MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
      if (attr->is_iso_c)
	MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
      if (attr->alloc_comp)
	MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
      if (attr->pointer_comp)
	MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
      if (attr->proc_pointer_comp)
	MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits);
      if (attr->private_comp)
	MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
      if (attr->coarray_comp)
	MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
      if (attr->lock_comp)
	MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
      if (attr->event_comp)
	MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits);
      if (attr->zero_comp)
	MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
      if (attr->is_class)
	MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
      if (attr->procedure)
	MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
      if (attr->proc_pointer)
	MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
      if (attr->vtype)
	MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
      if (attr->vtab)
	MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
      if (attr->omp_declare_target)
	MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits);
      if (attr->array_outer_dependency)
	MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits);
      if (attr->module_procedure)
	MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits);
      if (attr->oacc_declare_create)
	MIO_NAME (ab_attribute) (AB_OACC_DECLARE_CREATE, attr_bits);
      if (attr->oacc_declare_copyin)
	MIO_NAME (ab_attribute) (AB_OACC_DECLARE_COPYIN, attr_bits);
      if (attr->oacc_declare_deviceptr)
	MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICEPTR, attr_bits);
      if (attr->oacc_declare_device_resident)
	MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICE_RESIDENT, attr_bits);
      if (attr->oacc_declare_link)
	MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits);
      if (attr->omp_declare_target_link)
	MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits);
      if (attr->pdt_kind)
	MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits);
      if (attr->pdt_len)
	MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits);
      if (attr->pdt_type)
	MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits);
      if (attr->pdt_template)
	MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits);
      if (attr->pdt_array)
	MIO_NAME (ab_attribute) (AB_PDT_ARRAY, attr_bits);
      if (attr->pdt_string)
	MIO_NAME (ab_attribute) (AB_PDT_STRING, attr_bits);
      switch (attr->oacc_routine_lop)
	{
	case OACC_ROUTINE_LOP_NONE:
	  /* This is the default anyway, and for maintaining compatibility with
	     the current MOD_VERSION, we're not emitting anything in that
	     case.  */
	  break;
	case OACC_ROUTINE_LOP_GANG:
	  MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_GANG, attr_bits);
	  break;
	case OACC_ROUTINE_LOP_WORKER:
	  MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_WORKER, attr_bits);
	  break;
	case OACC_ROUTINE_LOP_VECTOR:
	  MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_VECTOR, attr_bits);
	  break;
	case OACC_ROUTINE_LOP_SEQ:
	  MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_SEQ, attr_bits);
	  break;
	case OACC_ROUTINE_LOP_ERROR:
	  /* ... intentionally omitted here; it's only unsed internally.  */
	default:
	  gcc_unreachable ();
	}

      mio_rparen ();

    }
  else
    {
      for (;;)
	{
	  t = parse_atom ();
	  if (t == ATOM_RPAREN)
	    break;
	  if (t != ATOM_NAME)
	    bad_module ("Expected attribute bit name");

	  switch ((ab_attribute) find_enum (attr_bits))
	    {
	    case AB_ALLOCATABLE:
	      attr->allocatable = 1;
	      break;
	    case AB_ARTIFICIAL:
	      attr->artificial = 1;
	      break;
	    case AB_ASYNCHRONOUS:
	      attr->asynchronous = 1;
	      break;
	    case AB_DIMENSION:
	      attr->dimension = 1;
	      break;
	    case AB_CODIMENSION:
	      attr->codimension = 1;
	      break;
	    case AB_CONTIGUOUS:
	      attr->contiguous = 1;
	      break;
	    case AB_EXTERNAL:
	      attr->external = 1;
	      break;
	    case AB_INTRINSIC:
	      attr->intrinsic = 1;
	      break;
	    case AB_OPTIONAL:
	      attr->optional = 1;
	      break;
	    case AB_POINTER:
	      attr->pointer = 1;
	      break;
	    case AB_CLASS_POINTER:
	      attr->class_pointer = 1;
	      break;
	    case AB_PROTECTED:
	      attr->is_protected = 1;
	      break;
	    case AB_VALUE:
	      attr->value = 1;
	      break;
	    case AB_VOLATILE:
	      attr->volatile_ = 1;
	      break;
	    case AB_TARGET:
	      attr->target = 1;
	      break;
	    case AB_THREADPRIVATE:
	      attr->threadprivate = 1;
	      break;
	    case AB_DUMMY:
	      attr->dummy = 1;
	      break;
	    case AB_RESULT:
	      attr->result = 1;
	      break;
	    case AB_DATA:
	      attr->data = 1;
	      break;
	    case AB_IN_NAMELIST:
	      attr->in_namelist = 1;
	      break;
	    case AB_IN_COMMON:
	      attr->in_common = 1;
	      break;
	    case AB_FUNCTION:
	      attr->function = 1;
	      break;
	    case AB_SUBROUTINE:
	      attr->subroutine = 1;
	      break;
	    case AB_GENERIC:
	      attr->generic = 1;
	      break;
	    case AB_ABSTRACT:
	      attr->abstract = 1;
	      break;
	    case AB_SEQUENCE:
	      attr->sequence = 1;
	      break;
	    case AB_ELEMENTAL:
	      attr->elemental = 1;
	      break;
	    case AB_PURE:
	      attr->pure = 1;
	      break;
	    case AB_IMPLICIT_PURE:
	      attr->implicit_pure = 1;
	      break;
	    case AB_UNLIMITED_POLY:
	      attr->unlimited_polymorphic = 1;
	      break;
	    case AB_RECURSIVE:
	      attr->recursive = 1;
	      break;
	    case AB_ALWAYS_EXPLICIT:
	      attr->always_explicit = 1;
	      break;
	    case AB_CRAY_POINTER:
	      attr->cray_pointer = 1;
	      break;
	    case AB_CRAY_POINTEE:
	      attr->cray_pointee = 1;
	      break;
	    case AB_IS_BIND_C:
	      attr->is_bind_c = 1;
	      break;
	    case AB_IS_C_INTEROP:
	      attr->is_c_interop = 1;
	      break;
	    case AB_IS_ISO_C:
	      attr->is_iso_c = 1;
	      break;
	    case AB_ALLOC_COMP:
	      attr->alloc_comp = 1;
	      break;
	    case AB_COARRAY_COMP:
	      attr->coarray_comp = 1;
	      break;
	    case AB_LOCK_COMP:
	      attr->lock_comp = 1;
	      break;
	    case AB_EVENT_COMP:
	      attr->event_comp = 1;
	      break;
	    case AB_POINTER_COMP:
	      attr->pointer_comp = 1;
	      break;
	    case AB_PROC_POINTER_COMP:
	      attr->proc_pointer_comp = 1;
	      break;
	    case AB_PRIVATE_COMP:
	      attr->private_comp = 1;
	      break;
	    case AB_ZERO_COMP:
	      attr->zero_comp = 1;
	      break;
	    case AB_IS_CLASS:
	      attr->is_class = 1;
	      break;
	    case AB_PROCEDURE:
	      attr->procedure = 1;
	      break;
	    case AB_PROC_POINTER:
	      attr->proc_pointer = 1;
	      break;
	    case AB_VTYPE:
	      attr->vtype = 1;
	      break;
	    case AB_VTAB:
	      attr->vtab = 1;
	      break;
	    case AB_OMP_DECLARE_TARGET:
	      attr->omp_declare_target = 1;
	      break;
	    case AB_OMP_DECLARE_TARGET_LINK:
	      attr->omp_declare_target_link = 1;
	      break;
	    case AB_ARRAY_OUTER_DEPENDENCY:
	      attr->array_outer_dependency =1;
	      break;
	    case AB_MODULE_PROCEDURE:
	      attr->module_procedure =1;
	      break;
	    case AB_OACC_DECLARE_CREATE:
	      attr->oacc_declare_create = 1;
	      break;
	    case AB_OACC_DECLARE_COPYIN:
	      attr->oacc_declare_copyin = 1;
	      break;
	    case AB_OACC_DECLARE_DEVICEPTR:
	      attr->oacc_declare_deviceptr = 1;
	      break;
	    case AB_OACC_DECLARE_DEVICE_RESIDENT:
	      attr->oacc_declare_device_resident = 1;
	      break;
	    case AB_OACC_DECLARE_LINK:
	      attr->oacc_declare_link = 1;
	      break;
	    case AB_PDT_KIND:
	      attr->pdt_kind = 1;
	      break;
	    case AB_PDT_LEN:
	      attr->pdt_len = 1;
	      break;
	    case AB_PDT_TYPE:
	      attr->pdt_type = 1;
	      break;
	    case AB_PDT_TEMPLATE:
	      attr->pdt_template = 1;
	      break;
	    case AB_PDT_ARRAY:
	      attr->pdt_array = 1;
	      break;
	    case AB_PDT_STRING:
	      attr->pdt_string = 1;
	      break;
	    case AB_OACC_ROUTINE_LOP_GANG:
	      verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
	      attr->oacc_routine_lop = OACC_ROUTINE_LOP_GANG;
	      break;
	    case AB_OACC_ROUTINE_LOP_WORKER:
	      verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
	      attr->oacc_routine_lop = OACC_ROUTINE_LOP_WORKER;
	      break;
	    case AB_OACC_ROUTINE_LOP_VECTOR:
	      verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
	      attr->oacc_routine_lop = OACC_ROUTINE_LOP_VECTOR;
	      break;
	    case AB_OACC_ROUTINE_LOP_SEQ:
	      verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
	      attr->oacc_routine_lop = OACC_ROUTINE_LOP_SEQ;
	      break;
	    }
	}
    }
}


static const mstring bt_types[] = {
    minit ("INTEGER", BT_INTEGER),
    minit ("REAL", BT_REAL),
    minit ("COMPLEX", BT_COMPLEX),
    minit ("LOGICAL", BT_LOGICAL),
    minit ("CHARACTER", BT_CHARACTER),
    minit ("UNION", BT_UNION),
    minit ("DERIVED", BT_DERIVED),
    minit ("CLASS", BT_CLASS),
    minit ("PROCEDURE", BT_PROCEDURE),
    minit ("UNKNOWN", BT_UNKNOWN),
    minit ("VOID", BT_VOID),
    minit ("ASSUMED", BT_ASSUMED),
    minit (NULL, -1)
};


static void
mio_charlen (gfc_charlen **clp)
{
  gfc_charlen *cl;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      cl = *clp;
      if (cl != NULL)
	mio_expr (&cl->length);
    }
  else
    {
      if (peek_atom () != ATOM_RPAREN)
	{
	  cl = gfc_new_charlen (gfc_current_ns, NULL);
	  mio_expr (&cl->length);
	  *clp = cl;
	}
    }

  mio_rparen ();
}


/* See if a name is a generated name.  */

static int
check_unique_name (const char *name)
{
  return *name == '@';
}


static void
mio_typespec (gfc_typespec *ts)
{
  mio_lparen ();

  ts->type = MIO_NAME (bt) (ts->type, bt_types);

  if (!gfc_bt_struct (ts->type) && ts->type != BT_CLASS)
    mio_integer (&ts->kind);
  else
    mio_symbol_ref (&ts->u.derived);

  mio_symbol_ref (&ts->interface);

  /* Add info for C interop and is_iso_c.  */
  mio_integer (&ts->is_c_interop);
  mio_integer (&ts->is_iso_c);

  /* If the typespec is for an identifier either from iso_c_binding, or
     a constant that was initialized to an identifier from it, use the
     f90_type.  Otherwise, use the ts->type, since it shouldn't matter.  */
  if (ts->is_iso_c)
    ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
  else
    ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);

  if (ts->type != BT_CHARACTER)
    {
      /* ts->u.cl is only valid for BT_CHARACTER.  */
      mio_lparen ();
      mio_rparen ();
    }
  else
    mio_charlen (&ts->u.cl);

  /* So as not to disturb the existing API, use an ATOM_NAME to
     transmit deferred characteristic for characters (F2003).  */
  if (iomode == IO_OUTPUT)
    {
      if (ts->type == BT_CHARACTER && ts->deferred)
	write_atom (ATOM_NAME, "DEFERRED_CL");
    }
  else if (peek_atom () != ATOM_RPAREN)
    {
      if (parse_atom () != ATOM_NAME)
	bad_module ("Expected string");
      ts->deferred = 1;
    }

  mio_rparen ();
}


static const mstring array_spec_types[] = {
    minit ("EXPLICIT", AS_EXPLICIT),
    minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
    minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
    minit ("DEFERRED", AS_DEFERRED),
    minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
    minit (NULL, -1)
};


static void
mio_array_spec (gfc_array_spec **asp)
{
  gfc_array_spec *as;
  int i;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      int rank;

      if (*asp == NULL)
	goto done;
      as = *asp;

      /* mio_integer expects nonnegative values.  */
      rank = as->rank > 0 ? as->rank : 0;
      mio_integer (&rank);
    }
  else
    {
      if (peek_atom () == ATOM_RPAREN)
	{
	  *asp = NULL;
	  goto done;
	}

      *asp = as = gfc_get_array_spec ();
      mio_integer (&as->rank);
    }

  mio_integer (&as->corank);
  as->type = MIO_NAME (array_type) (as->type, array_spec_types);

  if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK)
    as->rank = -1;
  if (iomode == IO_INPUT && as->corank)
    as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT;

  if (as->rank + as->corank > 0)
    for (i = 0; i < as->rank + as->corank; i++)
      {
	mio_expr (&as->lower[i]);
	mio_expr (&as->upper[i]);
      }

done:
  mio_rparen ();
}


/* Given a pointer to an array reference structure (which lives in a
   gfc_ref structure), find the corresponding array specification
   structure.  Storing the pointer in the ref structure doesn't quite
   work when loading from a module. Generating code for an array
   reference also needs more information than just the array spec.  */

static const mstring array_ref_types[] = {
    minit ("FULL", AR_FULL),
    minit ("ELEMENT", AR_ELEMENT),
    minit ("SECTION", AR_SECTION),
    minit (NULL, -1)
};


static void
mio_array_ref (gfc_array_ref *ar)
{
  int i;

  mio_lparen ();
  ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
  mio_integer (&ar->dimen);

  switch (ar->type)
    {
    case AR_FULL:
      break;

    case AR_ELEMENT:
      for (i = 0; i < ar->dimen; i++)
	mio_expr (&ar->start[i]);

      break;

    case AR_SECTION:
      for (i = 0; i < ar->dimen; i++)
	{
	  mio_expr (&ar->start[i]);
	  mio_expr (&ar->end[i]);
	  mio_expr (&ar->stride[i]);
	}

      break;

    case AR_UNKNOWN:
      gfc_internal_error ("mio_array_ref(): Unknown array ref");
    }

  /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
     we can't call mio_integer directly.  Instead loop over each element
     and cast it to/from an integer.  */
  if (iomode == IO_OUTPUT)
    {
      for (i = 0; i < ar->dimen; i++)
	{
	  HOST_WIDE_INT tmp = (HOST_WIDE_INT)ar->dimen_type[i];
	  write_atom (ATOM_INTEGER, &tmp);
	}
    }
  else
    {
      for (i = 0; i < ar->dimen; i++)
	{
	  require_atom (ATOM_INTEGER);
	  ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
	}
    }

  if (iomode == IO_INPUT)
    {
      ar->where = gfc_current_locus;

      for (i = 0; i < ar->dimen; i++)
	ar->c_where[i] = gfc_current_locus;
    }

  mio_rparen ();
}


/* Saves or restores a pointer.  The pointer is converted back and
   forth from an integer.  We return the pointer_info pointer so that
   the caller can take additional action based on the pointer type.  */

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

  if (iomode == IO_OUTPUT)
    {
      p = get_pointer (*((char **) gp));
      HOST_WIDE_INT hwi = p->integer;
      write_atom (ATOM_INTEGER, &hwi);
    }
  else
    {
      require_atom (ATOM_INTEGER);
      p = add_fixup (atom_int, gp);
    }

  return p;
}


/* Save and load references to components that occur within
   expressions.  We have to describe these references by a number and
   by name.  The number is necessary for forward references during
   reading, and the name is necessary if the symbol already exists in
   the namespace and is not loaded again.  */

static void
mio_component_ref (gfc_component **cp)
{
  pointer_info *p;

  p = mio_pointer_ref (cp);
  if (p->type == P_UNKNOWN)
    p->type = P_COMPONENT;
}


static void mio_namespace_ref (gfc_namespace **nsp);
static void mio_formal_arglist (gfc_formal_arglist **formal);
static void mio_typebound_proc (gfc_typebound_proc** proc);
static void mio_actual_arglist (gfc_actual_arglist **ap, bool pdt);

static void
mio_component (gfc_component *c, int vtype)
{
  pointer_info *p;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      p = get_pointer (c);
      mio_hwi (&p->integer);
    }
  else
    {
      HOST_WIDE_INT n;
      mio_hwi (&n);
      p = get_integer (n);
      associate_integer_pointer (p, c);
    }

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

  mio_pool_string (&c->name);
  mio_typespec (&c->ts);
  mio_array_spec (&c->as);

  /* PDT templates store the expression for the kind of a component here.  */
  mio_expr (&c->kind_expr);

  /* PDT types store the component specification list here. */
  mio_actual_arglist (&c->param_list, true);

  mio_symbol_attribute (&c->attr);
  if (c->ts.type == BT_CLASS)
    c->attr.class_ok = 1;
  c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);

  if (!vtype || strcmp (c->name, "_final") == 0
      || strcmp (c->name, "_hash") == 0)
    mio_expr (&c->initializer);

  if (c->attr.proc_pointer)
    mio_typebound_proc (&c->tb);

  c->loc = gfc_current_locus;

  mio_rparen ();
}


static void
mio_component_list (gfc_component **cp, int vtype)
{
  gfc_component *c, *tail;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      for (c = *cp; c; c = c->next)
	mio_component (c, vtype);
    }
  else
    {
      *cp = NULL;
      tail = NULL;

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

	  c = gfc_get_component ();
	  mio_component (c, vtype);

	  if (tail == NULL)
	    *cp = c;
	  else
	    tail->next = c;

	  tail = c;
	}
    }

  mio_rparen ();
}


static void
mio_actual_arg (gfc_actual_arglist *a, bool pdt)
{
  mio_lparen ();
  mio_pool_string (&a->name);
  mio_expr (&a->expr);
  if (pdt)
    mio_integer ((int *)&a->spec_type);
  mio_rparen ();
}


static void
mio_actual_arglist (gfc_actual_arglist **ap, bool pdt)
{
  gfc_actual_arglist *a, *tail;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      for (a = *ap; a; a = a->next)
	mio_actual_arg (a, pdt);

    }
  else
    {
      tail = NULL;

      for (;;)
	{
	  if (peek_atom () != ATOM_LPAREN)
	    break;

	  a = gfc_get_actual_arglist ();

	  if (tail == NULL)
	    *ap = a;
	  else
	    tail->next = a;

	  tail = a;
	  mio_actual_arg (a, pdt);
	}
    }

  mio_rparen ();
}


/* Read and write formal argument lists.  */

static void
mio_formal_arglist (gfc_formal_arglist **formal)
{
  gfc_formal_arglist *f, *tail;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      for (f = *formal; f; f = f->next)
	mio_symbol_ref (&f->sym);
    }
  else
    {
      *formal = tail = NULL;

      while (peek_atom () != ATOM_RPAREN)
	{
	  f = gfc_get_formal_arglist ();
	  mio_symbol_ref (&f->sym);

	  if (*formal == NULL)
	    *formal = f;
	  else
	    tail->next = f;

	  tail = f;
	}
    }

  mio_rparen ();
}


/* Save or restore a reference to a symbol node.  */

pointer_info *
mio_symbol_ref (gfc_symbol **symp)
{
  pointer_info *p;

  p = mio_pointer_ref (symp);
  if (p->type == P_UNKNOWN)
    p->type = P_SYMBOL;

  if (iomode == IO_OUTPUT)
    {
      if (p->u.wsym.state == UNREFERENCED)
	p->u.wsym.state = NEEDS_WRITE;
    }
  else
    {
      if (p->u.rsym.state == UNUSED)
	p->u.rsym.state = NEEDED;
    }
  return p;
}


/* Save or restore a reference to a symtree node.  */

static void
mio_symtree_ref (gfc_symtree **stp)
{
  pointer_info *p;
  fixup_t *f;

  if (iomode == IO_OUTPUT)
    mio_symbol_ref (&(*stp)->n.sym);
  else
    {
      require_atom (ATOM_INTEGER);
      p = get_integer (atom_int);

      /* An unused equivalence member; make a symbol and a symtree
	 for it.  */
      if (in_load_equiv && p->u.rsym.symtree == NULL)
	{
	  /* Since this is not used, it must have a unique name.  */
	  p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);

	  /* Make the symbol.  */
	  if (p->u.rsym.sym == NULL)
	    {
	      p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
					      gfc_current_ns);
	      p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module);
	    }

	  p->u.rsym.symtree->n.sym = p->u.rsym.sym;
	  p->u.rsym.symtree->n.sym->refs++;
	  p->u.rsym.referenced = 1;

	  /* If the symbol is PRIVATE and in COMMON, load_commons will
	     generate a fixup symbol, which must be associated.  */
	  if (p->fixup)
	    resolve_fixups (p->fixup, p->u.rsym.sym);
	  p->fixup = NULL;
	}

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

      if (p->u.rsym.state == UNUSED)
	p->u.rsym.state = NEEDED;

      if (p->u.rsym.symtree != NULL)
	{
	  *stp = p->u.rsym.symtree;
	}
      else
	{
	  f = XCNEW (fixup_t);

	  f->next = p->u.rsym.stfixup;
	  p->u.rsym.stfixup = f;

	  f->pointer = (void **) stp;
	}
    }
}


static void
mio_iterator (gfc_iterator **ip)
{
  gfc_iterator *iter;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      if (*ip == NULL)
	goto done;
    }
  else
    {
      if (peek_atom () == ATOM_RPAREN)
	{
	  *ip = NULL;
	  goto done;
	}

      *ip = gfc_get_iterator ();
    }

  iter = *ip;

  mio_expr (&iter->var);
  mio_expr (&iter->start);
  mio_expr (&iter->end);
  mio_expr (&iter->step);

done:
  mio_rparen ();
}


static void
mio_constructor (gfc_constructor_base *cp)
{
  gfc_constructor *c;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
	{
	  mio_lparen ();
	  mio_expr (&c->expr);
	  mio_iterator (&c->iterator);
	  mio_rparen ();
	}
    }
  else
    {
      while (peek_atom () != ATOM_RPAREN)
	{
	  c = gfc_constructor_append_expr (cp, NULL, NULL);

	  mio_lparen ();
	  mio_expr (&c->expr);
	  mio_iterator (&c->iterator);
	  mio_rparen ();
	}
    }

  mio_rparen ();
}


static const mstring ref_types[] = {
    minit ("ARRAY", REF_ARRAY),
    minit ("COMPONENT", REF_COMPONENT),
    minit ("SUBSTRING", REF_SUBSTRING),
    minit ("INQUIRY", REF_INQUIRY),
    minit (NULL, -1)
};

static const mstring inquiry_types[] = {
    minit ("RE", INQUIRY_RE),
    minit ("IM", INQUIRY_IM),
    minit ("KIND", INQUIRY_KIND),
    minit ("LEN", INQUIRY_LEN),
    minit (NULL, -1)
};


static void
mio_ref (gfc_ref **rp)
{
  gfc_ref *r;

  mio_lparen ();

  r = *rp;
  r->type = MIO_NAME (ref_type) (r->type, ref_types);

  switch (r->type)
    {
    case REF_ARRAY:
      mio_array_ref (&r->u.ar);
      break;

    case REF_COMPONENT:
      mio_symbol_ref (&r->u.c.sym);
      mio_component_ref (&r->u.c.component);
      break;

    case REF_SUBSTRING:
      mio_expr (&r->u.ss.start);
      mio_expr (&r->u.ss.end);
      mio_charlen (&r->u.ss.length);
      break;

    case REF_INQUIRY:
      r->u.i = MIO_NAME (inquiry_type) (r->u.i, inquiry_types);
      break;
    }

  mio_rparen ();
}


static void
mio_ref_list (gfc_ref **rp)
{
  gfc_ref *ref, *head, *tail;

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      for (ref = *rp; ref; ref = ref->next)
	mio_ref (&ref);
    }
  else
    {
      head = tail = NULL;

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

	  mio_ref (&tail);
	}

      *rp = head;
    }

  mio_rparen ();
}


/* Read and write an integer value.  */

static void
mio_gmp_integer (mpz_t *integer)
{
  char *p;

  if (iomode == IO_INPUT)
    {
      if (parse_atom () != ATOM_STRING)
	bad_module ("Expected integer string");

      mpz_init (*integer);
      if (mpz_set_str (*integer, atom_string, 10))
	bad_module ("Error converting integer");

      free (atom_string);
    }
  else
    {
      p = mpz_get_str (NULL, 10, *integer);
      write_atom (ATOM_STRING, p);
      free (p);
    }