module.c

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

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)
    write_atom (ATOM_INTEGER, ip);
  else
    {
      require_atom (ATOM_INTEGER);
      *ip = 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;
    }
}


/* 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 (atom_string);
      gfc_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);
      gfc_free (atom_string);
    }
}



typedef enum
{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
  AB_POINTER, AB_SAVE, 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_attribute;

static const mstring attr_bits[] =
{
    minit ("ALLOCATABLE", AB_ALLOCATABLE),
    minit ("DIMENSION", AB_DIMENSION),
    minit ("EXTERNAL", AB_EXTERNAL),
    minit ("INTRINSIC", AB_INTRINSIC),
    minit ("OPTIONAL", AB_OPTIONAL),
    minit ("POINTER", AB_POINTER),
    minit ("SAVE", AB_SAVE),
    minit ("TARGET", AB_TARGET),
    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 (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(procedure_type)
DECL_MIO_NAME(ref_type)
DECL_MIO_NAME(sym_flavor)
DECL_MIO_NAME(sym_intent)
#undef DECL_MIO_NAME

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

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

  if (iomode == IO_OUTPUT)
    {
      if (attr->allocatable)
	MIO_NAME(ab_attribute) (AB_ALLOCATABLE, attr_bits);
      if (attr->dimension)
	MIO_NAME(ab_attribute) (AB_DIMENSION, 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->save)
	MIO_NAME(ab_attribute) (AB_SAVE, attr_bits);
      if (attr->target)
	MIO_NAME(ab_attribute) (AB_TARGET, 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->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->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);

      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_DIMENSION:
	      attr->dimension = 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_SAVE:
	      attr->save = 1;
	      break;
	    case AB_TARGET:
	      attr->target = 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_SEQUENCE:
	      attr->sequence = 1;
	      break;
	    case AB_ELEMENTAL:
	      attr->elemental = 1;
	      break;
	    case AB_PURE:
	      attr->pure = 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;
	    }
	}
    }
}


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 ("DERIVED", BT_DERIVED),
    minit ("PROCEDURE", BT_PROCEDURE),
    minit ("UNKNOWN", BT_UNKNOWN),
    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_get_charlen ();
	  mio_expr (&cl->length);

	  *clp = cl;

	  cl->next = gfc_current_ns->cl_list;
	  gfc_current_ns->cl_list = cl;
	}
    }

  mio_rparen ();
}


/* Return a symtree node with a name that is guaranteed to be unique
   within the namespace and corresponds to an illegal fortran name.  */

static gfc_symtree *
get_unique_symtree (gfc_namespace * ns)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  static int serial = 0;

  sprintf (name, "@%d", serial++);
  return gfc_new_symtree (&ns->sym_root, name);
}


/* 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 (ts->type != BT_DERIVED)
    mio_integer (&ts->kind);
  else
    mio_symbol_ref (&ts->derived);

  mio_charlen (&ts->cl);

  mio_rparen ();
}


static const mstring array_spec_types[] = {
    minit ("EXPLICIT", AS_EXPLICIT),
    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)
    {
      if (*asp == NULL)
	goto done;
      as = *asp;
    }
  else
    {
      if (peek_atom () == ATOM_RPAREN)
	{
	  *asp = NULL;
	  goto done;
	}

      *asp = as = gfc_get_array_spec ();
    }

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

  for (i = 0; i < as->rank; 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");
    }

  for (i = 0; i < ar->dimen; i++)
    mio_integer ((int *) &ar->dimen_type[i]);

  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));
      write_atom (ATOM_INTEGER, &p->integer);
    }
  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, gfc_symbol * sym)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_component *q;
  pointer_info *p;

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

  if (iomode == IO_OUTPUT)
    mio_pool_string (&(*cp)->name);
  else
    {
      mio_internal_string (name);

      /* It can happen that a component reference can be read before the
	 associated derived type symbol has been loaded. Return now and
	 wait for a later iteration of load_needed.  */
      if (sym == NULL)
	return;

      if (sym->components != NULL && p->u.pointer == NULL)
	{
	  /* Symbol already loaded, so search by name.  */
	  for (q = sym->components; q; q = q->next)
	    if (strcmp (q->name, name) == 0)
	      break;

	  if (q == NULL)
	    gfc_internal_error ("mio_component_ref(): Component not found");

	  associate_integer_pointer (p, q);
	}

      /* Make sure this symbol will eventually be loaded.  */
      p = find_pointer2 (sym);
      if (p->u.rsym.state == UNUSED)
	p->u.rsym.state = NEEDED;
    }
}


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

  mio_lparen ();

  if (iomode == IO_OUTPUT)
    {
      p = get_pointer (c);
      mio_integer (&p->integer);
    }
  else
    {
      mio_integer (&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);

  mio_integer (&c->dimension);
  mio_integer (&c->pointer);

  mio_expr (&c->initializer);
  mio_rparen ();
}


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

  mio_lparen ();

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

      *cp = NULL;
      tail = NULL;

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

	  c = gfc_get_component ();
	  mio_component (c);

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

	  tail = c;
	}
    }

  mio_rparen ();
}


static void
mio_actual_arg (gfc_actual_arglist * a)
{