/* Handle modules, which amounts to loading and saving symbols and
their attendant structures.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Andy Vaught
#define MODULE_EXTENSION ".mod"
+/* Don't put any single quote (') in MOD_VERSION,
+ if yout want it to be recognized. */
+#define MOD_VERSION "0"
+
/* Structure that describes a position within a module file. */
/* 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);
{
gfc_symbol *sym;
char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
- enum
- { UNUSED, NEEDED, USED }
- state;
+ enum gfc_rsym_state state;
int ns, referenced, renamed;
module_locus where;
fixup_t *stfixup;
struct
{
gfc_symbol *sym;
- enum
- { UNREFERENCED = 0, NEEDS_WRITE, WRITTEN }
- state;
+ enum gfc_wsym_state state;
}
wsym;
}
#define gfc_get_pointer_info() XCNEW (pointer_info)
-/* Lists of rename info for the USE statement. */
-
-typedef struct gfc_use_rename
-{
- char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1];
- struct gfc_use_rename *next;
- int found;
- gfc_intrinsic_op op;
- locus where;
-}
-gfc_use_rename;
-
-#define gfc_get_use_rename() XCNEW (gfc_use_rename);
-
/* Local variables */
/* The FILE for the module we're reading or writing. */
/* Tells mio_expr_ref to make symbols for unused equivalence members. */
static bool in_load_equiv;
+static locus use_locus;
+
/*****************************************************************/
}
}
+ use_locus = gfc_current_locus;
+
m = gfc_match_name (module_name);
if (m != MATCH_YES)
return m;
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
- AB_EXTENSION
+ AB_EXTENSION, AB_PROCEDURE, AB_PROC_POINTER
}
ab_attribute;
minit ("PROTECTED", AB_PROTECTED),
minit ("ABSTRACT", AB_ABSTRACT),
minit ("EXTENSION", AB_EXTENSION),
+ minit ("PROCEDURE", AB_PROCEDURE),
+ minit ("PROC_POINTER", AB_PROC_POINTER),
+ 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)
};
MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
if (attr->extension)
MIO_NAME (ab_attribute) (AB_EXTENSION, 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);
mio_rparen ();
case AB_EXTENSION:
attr->extension = 1;
break;
+ case AB_PROCEDURE:
+ attr->procedure = 1;
+ break;
+ case AB_PROC_POINTER:
+ attr->proc_pointer = 1;
+ break;
}
}
}
for (i = 0; i < ar->dimen; i++)
{
require_atom (ATOM_INTEGER);
- ar->dimen_type[i] = atom_int;
+ ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
}
}
minit ("STRUCTURE", EXPR_STRUCTURE),
minit ("ARRAY", EXPR_ARRAY),
minit ("NULL", EXPR_NULL),
+ minit ("COMPCALL", EXPR_COMPCALL),
minit (NULL, -1)
};
case EXPR_NULL:
break;
+
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ gcc_unreachable ();
+ break;
}
mio_rparen ();
/* Save/restore the f2k_derived namespace of a derived-type symbol. */
+static gfc_namespace* current_f2k_derived;
+
+static void
+mio_typebound_proc (gfc_typebound_proc** proc)
+{
+ int flag;
+ int overriding_flag;
+
+ if (iomode == IO_INPUT)
+ {
+ *proc = gfc_get_typebound_proc ();
+ (*proc)->where = gfc_current_locus;
+ }
+ gcc_assert (*proc);
+
+ mio_lparen ();
+
+ (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
+
+ /* IO the NON_OVERRIDABLE/DEFERRED combination. */
+ gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
+ overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
+ overriding_flag = mio_name (overriding_flag, binding_overriding);
+ (*proc)->deferred = ((overriding_flag & 2) != 0);
+ (*proc)->non_overridable = ((overriding_flag & 1) != 0);
+ gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
+
+ (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
+ (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
+
+ if (iomode == IO_INPUT)
+ (*proc)->pass_arg = NULL;
+
+ flag = (int) (*proc)->pass_arg_num;
+ mio_integer (&flag);
+ (*proc)->pass_arg_num = (unsigned) flag;
+
+ if ((*proc)->is_generic)
+ {
+ gfc_tbp_generic* g;
+
+ mio_lparen ();
+
+ if (iomode == IO_OUTPUT)
+ for (g = (*proc)->u.generic; g; g = g->next)
+ mio_allocated_string (g->specific_st->name);
+ else
+ {
+ (*proc)->u.generic = NULL;
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ gfc_symtree** sym_root;
+
+ g = gfc_get_tbp_generic ();
+ g->specific = NULL;
+
+ require_atom (ATOM_STRING);
+ sym_root = ¤t_f2k_derived->tb_sym_root;
+ g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
+ gfc_free (atom_string);
+
+ g->next = (*proc)->u.generic;
+ (*proc)->u.generic = g;
+ }
+ }
+
+ mio_rparen ();
+ }
+ else
+ mio_symtree_ref (&(*proc)->u.specific);
+
+ mio_rparen ();
+}
+
+static void
+mio_typebound_symtree (gfc_symtree* st)
+{
+ if (iomode == IO_OUTPUT && !st->n.tb)
+ return;
+
+ if (iomode == IO_OUTPUT)
+ {
+ mio_lparen ();
+ mio_allocated_string (st->name);
+ }
+ /* For IO_INPUT, the above is done in mio_f2k_derived. */
+
+ mio_typebound_proc (&st->n.tb);
+ mio_rparen ();
+}
+
static void
mio_finalizer (gfc_finalizer **f)
{
static void
mio_f2k_derived (gfc_namespace *f2k)
{
+ current_f2k_derived = f2k;
+
/* Handle the list of finalizer procedures. */
mio_lparen ();
if (iomode == IO_OUTPUT)
f2k->finalizers = NULL;
while (peek_atom () != ATOM_RPAREN)
{
- gfc_finalizer *cur;
+ gfc_finalizer *cur = NULL;
mio_finalizer (&cur);
cur->next = f2k->finalizers;
f2k->finalizers = cur;
}
}
mio_rparen ();
+
+ /* Handle type-bound procedures. */
+ mio_lparen ();
+ if (iomode == IO_OUTPUT)
+ gfc_traverse_symtree (f2k->tb_sym_root, &mio_typebound_symtree);
+ else
+ {
+ while (peek_atom () == ATOM_LPAREN)
+ {
+ gfc_symtree* st;
+
+ mio_lparen ();
+
+ require_atom (ATOM_STRING);
+ st = gfc_get_tbp_symtree (&f2k->tb_sym_root, atom_string);
+ gfc_free (atom_string);
+
+ mio_typebound_symtree (st);
+ }
+ }
+ mio_rparen ();
}
static void
else
{
mio_integer (&intmod);
- sym->from_intmod = intmod;
+ sym->from_intmod = (intmod_id) intmod;
}
mio_integer (&(sym->intmod_sym_id));
mio_expr (&tail->expr);
}
- /* Unused equivalence members have a unique name. */
+ /* Unused equivalence members have a unique name. In addition, it
+ must be checked that the symbols are from the same module. */
unused = true;
for (eq = head; eq; eq = eq->eq)
{
- if (!check_unique_name (eq->expr->symtree->name))
+ if (eq->expr->symtree->n.sym->module
+ && head->expr->symtree->n.sym->module
+ && strcmp (head->expr->symtree->n.sym->module,
+ eq->expr->symtree->n.sym->module) == 0
+ && !check_unique_name (eq->expr->symtree->name))
{
unused = false;
break;
}
+/* It is not quite enough to check for ambiguity in the symbols by
+ the loaded symbol and the new symbol not being identical. */
+static bool
+check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
+{
+ gfc_symbol *rsym;
+ module_locus locus;
+ symbol_attribute attr;
+
+ rsym = info->u.rsym.sym;
+ if (st_sym == rsym)
+ return false;
+
+ /* If the existing symbol is generic from a different module and
+ the new symbol is generic there can be no ambiguity. */
+ if (st_sym->attr.generic
+ && st_sym->module
+ && strcmp (st_sym->module, module_name))
+ {
+ /* The new symbol's attributes have not yet been read. Since
+ we need attr.generic, read it directly. */
+ get_module_locus (&locus);
+ set_module_locus (&info->u.rsym.where);
+ mio_lparen ();
+ attr.generic = 0;
+ mio_symbol_attribute (&attr);
+ set_module_locus (&locus);
+ if (attr.generic)
+ return false;
+ }
+
+ return true;
+}
+
+
/* Read a module file. */
static void
module_locus operator_interfaces, user_operators;
const char *p;
char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_intrinsic_op i;
+ int i;
int ambiguous, j, nuse, symbol;
pointer_info *info, *q;
gfc_use_rename *u;
if (st != NULL)
{
/* Check for ambiguous symbols. */
- if (st->n.sym != info->u.rsym.sym)
+ if (check_for_ambiguous (st->n.sym, info))
st->ambiguous = 1;
info->u.rsym.symtree = st;
}
st = gfc_find_symtree (gfc_current_ns->sym_root, name);
/* Delete the symtree if the symbol has been added by a USE
- statement without an ONLY(11.3.2). Remember that the rsym
+ statement without an ONLY(11.3.2). Remember that the rsym
will be the same as the symbol found in the symtree, for
- this case.*/
+ this case. */
if (st && (only_flag || info->u.rsym.renamed)
&& !st->n.sym->attr.use_only
&& !st->n.sym->attr.use_rename
if (strcmp (name, p) != 0)
sym->attr.use_rename = 1;
+ /* We need to set the only_flag here so that symbols from the
+ same USE...ONLY but earlier are not deleted from the tree in
+ the gfc_delete_symtree above. */
+ sym->attr.use_only = only_flag;
+
/* Store the symtree pointing to this symbol. */
info->u.rsym.symtree = st;
if (only_flag)
{
- u = find_use_operator (i);
+ u = find_use_operator ((gfc_intrinsic_op) i);
if (u == NULL)
{
/* Write a common block to the module -- recursive helper function. */
static void
-write_common_0 (gfc_symtree *st)
+write_common_0 (gfc_symtree *st, bool this_module)
{
gfc_common_head *p;
const char * name;
if (st == NULL)
return;
- write_common_0 (st->left);
+ write_common_0 (st->left, this_module);
/* We will write out the binding label, or the name if no label given. */
name = st->n.common->name;
w = (c < 0) ? w->left : w->right;
}
+ if (this_module && p->use_assoc)
+ write_me = false;
+
if (write_me)
{
/* Write the common to the module. */
gfc_insert_bbt (&written_commons, w, compare_written_commons);
}
- write_common_0 (st->right);
+ write_common_0 (st->right, this_module);
}
write_common (gfc_symtree *st)
{
written_commons = NULL;
- write_common_0 (st);
+ write_common_0 (st, true);
+ write_common_0 (st, false);
free_written_common (written_commons);
written_commons = NULL;
}
pointer_info *p;
sym = st->n.sym;
+
+ /* A symbol in an interface body must not be visible in the
+ module file. */
+ if (sym->ns != gfc_current_ns
+ && sym->ns->proc_name
+ && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
+ return;
+
if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
|| (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
&& !sym->attr.subroutine && !sym->attr.function))
static void
write_module (void)
{
- gfc_intrinsic_op i;
+ int i;
/* Write the operator interfaces. */
mio_lparen ();
if ((file = fopen (filename, "r")) == NULL)
return -1;
- /* Read two lines. */
- if (fgets (buf, sizeof (buf) - 1, file) == NULL
- || fgets (buf, sizeof (buf) - 1, file) == NULL)
+ /* Read the first line. */
+ if (fgets (buf, sizeof (buf) - 1, file) == NULL)
+ {
+ fclose (file);
+ return -1;
+ }
+
+ /* The file also needs to be overwritten if the version number changed. */
+ n = strlen ("GFORTRAN module version '" MOD_VERSION "' created");
+ if (strncmp (buf, "GFORTRAN module version '" MOD_VERSION "' created", n) != 0)
+ {
+ fclose (file);
+ return -1;
+ }
+
+ /* Read a second line. */
+ if (fgets (buf, sizeof (buf) - 1, file) == NULL)
{
fclose (file);
return -1;
*strchr (p, '\n') = '\0';
- fprintf (module_fp, "GFORTRAN module created from %s on %s\nMD5:",
- gfc_source_file, p);
+ fprintf (module_fp, "GFORTRAN module version '%s' created from %s on %s\n"
+ "MD5:", MOD_VERSION, gfc_source_file, p);
fgetpos (module_fp, &md5_pos);
fputs ("00000000000000000000000000000000 -- "
"If you edit this, you'll get what you deserve.\n\n", module_fp);
|| memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
{
/* Module file have changed, replace the old one. */
- unlink (filename);
- rename (filename_tmp, filename);
+ if (unlink (filename) && errno != ENOENT)
+ gfc_fatal_error ("Can't delete module file '%s': %s", filename,
+ strerror (errno));
+ if (rename (filename_tmp, filename))
+ gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
+ filename_tmp, filename, strerror (errno));
}
else
- unlink (filename_tmp);
+ {
+ if (unlink (filename_tmp))
+ gfc_fatal_error ("Can't delete temporary module file '%s': %s",
+ filename_tmp, strerror (errno));
+ }
}
continue;
}
- generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i,
+ u->local_name);
}
}
else
break;
}
}
- generate_isocbinding_symbol (iso_c_module_name, i, local_name);
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i,
+ local_name);
}
for (u = gfc_rename_list; u; u = u->next)
gfc_state_data *p;
int c, line, start;
gfc_symtree *mod_symtree;
+ gfc_use_list *use_stmt;
filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
+ 1);
c = module_char ();
if (c == EOF)
bad_module ("Unexpected end of module");
- if (start++ < 2)
+ if (start++ < 3)
parse_name (c);
if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
|| (start == 2 && strcmp (atom_name, " module") != 0))
gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
"file", filename);
+ if (start == 3)
+ {
+ if (strcmp (atom_name, " version") != 0
+ || module_char () != ' '
+ || parse_atom () != ATOM_STRING)
+ gfc_fatal_error ("Parse error when checking module version"
+ " for file '%s' opened at %C", filename);
+
+ if (strcmp (atom_string, MOD_VERSION))
+ {
+ gfc_fatal_error ("Wrong module version '%s' (expected '"
+ MOD_VERSION "') for file '%s' opened"
+ " at %C", atom_string, filename);
+ }
+ }
if (c == '\n')
line++;
pi_root = NULL;
fclose (module_fp);
+
+ use_stmt = gfc_get_use_list ();
+ use_stmt->module_name = gfc_get_string (module_name);
+ use_stmt->only_flag = only_flag;
+ use_stmt->rename = gfc_rename_list;
+ use_stmt->where = use_locus;
+ gfc_rename_list = NULL;
+ use_stmt->next = gfc_current_ns->use_stmts;
+ gfc_current_ns->use_stmts = use_stmt;
+}
+
+
+void
+gfc_free_use_stmts (gfc_use_list *use_stmts)
+{
+ gfc_use_list *next;
+ for (; use_stmts; use_stmts = next)
+ {
+ gfc_use_rename *next_rename;
+
+ for (; use_stmts->rename; use_stmts->rename = next_rename)
+ {
+ next_rename = use_stmts->rename->next;
+ gfc_free (use_stmts->rename);
+ }
+ next = use_stmts->next;
+ gfc_free (use_stmts);
+ }
}
OSDN Git Service
