module.c

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

/* 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);
  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->sym->name, t2->sym->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;

  sym.name = gfc_get_string (name);
  if (module != NULL)
    sym.module = gfc_get_string (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 = gfc_getmem (sizeof (true_name));
  t->sym = sym;

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

  if (st == NULL)
    return;

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

  if (find_true_name (st->n.sym->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);

  gfc_free (t);
}


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

/* Module reading and writing.  */

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

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 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)
{
  fclose (module_fp);

  switch (iomode)
    {
    case IO_INPUT:
      gfc_fatal_error ("Reading module %s at line %d column %d: %s",
	  	       module_name, module_line, module_column, msgid);
      break;
    case IO_OUTPUT:
      gfc_fatal_error ("Writing module %s at line %d column %d: %s",
	  	       module_name, module_line, module_column, msgid);
      break;
    default:
      gfc_fatal_error ("Module %s 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;
  fsetpos (module_fp, &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;
  fgetpos (module_fp, &m->pos);
}


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

static int
module_char (void)
{
  int c;

  c = fgetc (module_fp);

  if (c == EOF)
    bad_module ("Unexpected EOF");

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

  module_column++;
  return c;
}


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

static void
parse_string (void)
{
  module_locus start;
  int len, c;
  char *p;

  get_module_locus (&start);

  len = 0;

  /* See how long the string is */
  for ( ; ; )
    {
      c = module_char ();
      if (c == EOF)
	bad_module ("Unexpected end of module in string constant");

      if (c != '\'')
        {
	  len++;
	  continue;
	}

      c = module_char ();
      if (c == '\'')
        {
	  len++;
	  continue;
	}

      break;
    }

  set_module_locus (&start);

  atom_string = p = gfc_getmem (len + 1);

  for (; len > 0; len--)
    {
      c = module_char ();
      if (c == '\'')
	module_char ();		/* Guaranteed to be another \' */
      *p++ = c;
    }

  module_char ();		/* Terminating \' */
  *p = '\0';			/* C-style string for debug purposes */
}


/* Parse a small integer.  */

static void
parse_integer (int c)
{
  module_locus m;

  atom_int = c - '0';

  for (;;)
    {
      get_module_locus (&m);

      c = module_char ();
      if (!ISDIGIT (c))
	break;

      atom_int = 10 * atom_int + c - '0';
      if (atom_int > 99999999)
	bad_module ("Integer overflow");
    }

  set_module_locus (&m);
}


/* Parse a name.  */

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

  p = atom_name;

  *p++ = c;
  len = 1;

  get_module_locus (&m);

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

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

  *p = '\0';

  fseek (module_fp, -1, SEEK_CUR);
  module_column = m.column + len - 1;

  if (c == '\n')
    module_line--;
}


/* 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 == '\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)
{
  module_locus m;
  atom_type a;

  get_module_locus (&m);

  a = parse_atom ();
  if (a == ATOM_STRING)
    gfc_free (atom_string);

  set_module_locus (&m);
  return a;
}


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

static void
require_atom (atom_type type)
{
  module_locus m;
  atom_type t;
  const char *p;

  get_module_locus (&m);

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

      set_module_locus (&m);
      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 */
}


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

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

static void
write_char (char out)
{

  if (fputc (out, module_fp) == EOF)
    gfc_fatal_error ("Error writing modules file: %s", strerror (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[20];
  int i, len;
  const char *p;

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

    case ATOM_LPAREN:
      p = "(";
      break;

    case ATOM_RPAREN:
      p = ")";
      break;

    case ATOM_INTEGER:
      i = *((const int *) v);
      if (i < 0)
	gfc_internal_error ("write_atom(): Writing negative integer");

      sprintf (buffer, "%d", i);
      p = buffer;
      break;

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

    }

  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)
    {
      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 **);
static void mio_symbol_ref (gfc_symbol **);
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