/* 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, 2010
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 "4"
+
/* 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;
}
number_use_names (const char *name, bool interface)
{
int i = 0;
- const char *c;
- c = find_use_name_n (name, &i, interface);
+ find_use_name_n (name, &i, interface);
return i;
}
}
+/* 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)
+ {
+ int converted = (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 *
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_PROCEDURE, AB_PROC_POINTER
+ AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS
}
ab_attribute;
static const mstring attr_bits[] =
{
minit ("ALLOCATABLE", AB_ALLOCATABLE),
+ minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
minit ("DIMENSION", AB_DIMENSION),
minit ("EXTERNAL", AB_EXTERNAL),
minit ("INTRINSIC", AB_INTRINSIC),
minit ("ZERO_COMP", AB_ZERO_COMP),
minit ("PROTECTED", AB_PROTECTED),
minit ("ABSTRACT", AB_ABSTRACT),
- minit ("EXTENSION", AB_EXTENSION),
+ minit ("IS_CLASS", AB_IS_CLASS),
minit ("PROCEDURE", AB_PROCEDURE),
minit ("PROC_POINTER", AB_PROC_POINTER),
minit (NULL, -1)
{
minit ("OVERRIDABLE", 0),
minit ("NON_OVERRIDABLE", 1),
+ minit ("DEFERRED", 2),
minit (NULL, -1)
};
static const mstring binding_generic[] =
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)
mio_symbol_attribute (symbol_attribute *attr)
{
atom_type t;
+ unsigned ext_attr,extension_level;
mio_lparen ();
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->asynchronous)
+ MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
if (attr->dimension)
MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
if (attr->external)
MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
if (attr->zero_comp)
MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
- if (attr->extension)
- MIO_NAME (ab_attribute) (AB_EXTENSION, 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)
case AB_ALLOCATABLE:
attr->allocatable = 1;
break;
+ case AB_ASYNCHRONOUS:
+ attr->asynchronous = 1;
+ break;
case AB_DIMENSION:
attr->dimension = 1;
break;
case AB_ZERO_COMP:
attr->zero_comp = 1;
break;
- case AB_EXTENSION:
- attr->extension = 1;
+ case AB_IS_CLASS:
+ attr->is_class = 1;
break;
case AB_PROCEDURE:
attr->procedure = 1;
minit ("LOGICAL", BT_LOGICAL),
minit ("CHARACTER", BT_CHARACTER),
minit ("DERIVED", BT_DERIVED),
+ minit ("CLASS", BT_CLASS),
minit ("PROCEDURE", BT_PROCEDURE),
minit ("UNKNOWN", BT_UNKNOWN),
minit ("VOID", BT_VOID),
{
if (peek_atom () != ATOM_RPAREN)
{
- cl = gfc_get_charlen ();
+ cl = gfc_new_charlen (gfc_current_ns, NULL);
mio_expr (&cl->length);
-
*clp = cl;
-
- cl->next = gfc_current_ns->cl_list;
- gfc_current_ns->cl_list = cl;
}
}
ts->type = MIO_NAME (bt) (ts->type, bt_types);
- if (ts->type != BT_DERIVED)
+ if (ts->type != BT_DERIVED && ts->type != BT_CLASS)
mio_integer (&ts->kind);
else
- mio_symbol_ref (&ts->derived);
+ mio_symbol_ref (&ts->u.derived);
/* Add info for C interop and is_iso_c. */
mio_integer (&ts->is_c_interop);
if (ts->type != BT_CHARACTER)
{
- /* ts->cl is only valid for BT_CHARACTER. */
+ /* ts->u.cl is only valid for BT_CHARACTER. */
mio_lparen ();
mio_rparen ();
}
else
- mio_charlen (&ts->cl);
+ mio_charlen (&ts->u.cl);
mio_rparen ();
}
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;
}
}
}
+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_component (gfc_component *c)
{
pointer_info *p;
int n;
+ gfc_formal_arglist *formal;
mio_lparen ();
c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
mio_expr (&c->initializer);
+
+ if (c->attr.proc_pointer)
+ {
+ if (iomode == IO_OUTPUT)
+ {
+ formal = c->formal;
+ while (formal && !formal->sym)
+ formal = formal->next;
+
+ if (formal)
+ mio_namespace_ref (&formal->sym->ns);
+ else
+ mio_namespace_ref (&c->formal_ns);
+ }
+ else
+ {
+ mio_namespace_ref (&c->formal_ns);
+ /* TODO: if (c->formal_ns)
+ {
+ c->formal_ns->proc_name = c;
+ c->refs++;
+ }*/
+ }
+
+ mio_formal_arglist (&c->formal);
+
+ mio_typebound_proc (&c->tb);
+ }
+
mio_rparen ();
}
/* Read and write formal argument lists. */
static void
-mio_formal_arglist (gfc_symbol *sym)
+mio_formal_arglist (gfc_formal_arglist **formal)
{
gfc_formal_arglist *f, *tail;
if (iomode == IO_OUTPUT)
{
- for (f = sym->formal; f; f = f->next)
+ for (f = *formal; f; f = f->next)
mio_symbol_ref (&f->sym);
}
else
{
- sym->formal = tail = NULL;
+ *formal = tail = NULL;
while (peek_atom () != ATOM_RPAREN)
{
f = gfc_get_formal_arglist ();
mio_symbol_ref (&f->sym);
- if (sym->formal == NULL)
- sym->formal = f;
+ if (*formal == NULL)
+ *formal = f;
else
tail->next = f;
}
else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
{
+ gfc_symbol *sym;
+
/* In some circumstances, a function used in an initialization
expression, in one use associated module, can fail to be
coupled to its symtree when used in a specification
fname = e->value.function.esym ? e->value.function.esym->name
: e->value.function.isym->name;
e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
+
+ if (e->symtree)
+ return;
+
+ /* This is probably a reference to a private procedure from another
+ module. To prevent a segfault, make a generic with no specific
+ instances. If this module is used, without the required
+ specific coming from somewhere, the appropriate error message
+ is issued. */
+ gfc_get_symbol (fname, gfc_current_ns, &sym);
+ sym->attr.flavor = FL_PROCEDURE;
+ sym->attr.generic = 1;
+ e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
}
}
case BT_COMPLEX:
gfc_set_model_kind (e->ts.kind);
- mio_gmp_real (&e->value.complex.r);
- mio_gmp_real (&e->value.complex.i);
+ mio_gmp_real (&mpc_realref (e->value.complex));
+ mio_gmp_real (&mpc_imagref (e->value.complex));
break;
case BT_LOGICAL:
break;
case EXPR_COMPCALL:
+ case EXPR_PPC:
gcc_unreachable ();
break;
}
mio_typebound_proc (gfc_typebound_proc** proc)
{
int flag;
+ int overriding_flag;
if (iomode == IO_INPUT)
{
(*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)->non_overridable = mio_name ((*proc)->non_overridable,
- binding_overriding);
(*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
+ (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
- if (iomode == IO_INPUT)
- (*proc)->pass_arg = NULL;
+ mio_pool_string (&((*proc)->pass_arg));
flag = (int) (*proc)->pass_arg_num;
mio_integer (&flag);
(*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);
- gfc_get_sym_tree (atom_string, current_f2k_derived,
- &g->specific_st);
+ 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;
mio_rparen ();
}
- else
+ else if (!(*proc)->ppc)
mio_symtree_ref (&(*proc)->u.specific);
mio_rparen ();
}
+/* Walker-callback function for this purpose. */
static void
mio_typebound_symtree (gfc_symtree* st)
{
- if (iomode == IO_OUTPUT && !st->typebound)
+ if (iomode == IO_OUTPUT && !st->n.tb)
return;
if (iomode == IO_OUTPUT)
}
/* For IO_INPUT, the above is done in mio_f2k_derived. */
- mio_typebound_proc (&st->typebound);
+ mio_typebound_proc (&st->n.tb);
+ mio_rparen ();
+}
+
+/* IO a full symtree (in all depth). */
+static void
+mio_full_typebound_tree (gfc_symtree** root)
+{
+ mio_lparen ();
+
+ if (iomode == IO_OUTPUT)
+ gfc_traverse_symtree (*root, &mio_typebound_symtree);
+ else
+ {
+ while (peek_atom () == ATOM_LPAREN)
+ {
+ gfc_symtree* st;
+
+ mio_lparen ();
+
+ require_atom (ATOM_STRING);
+ st = gfc_get_tbp_symtree (root, atom_string);
+ gfc_free (atom_string);
+
+ mio_typebound_symtree (st);
+ }
+ }
+
mio_rparen ();
}
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_full_typebound_tree (&f2k->tb_sym_root);
+
+ /* Type-bound user operators. */
+ mio_full_typebound_tree (&f2k->tb_uop_root);
+
+ /* Type-bound intrinsic operators. */
mio_lparen ();
if (iomode == IO_OUTPUT)
- gfc_traverse_symtree (f2k->sym_root, &mio_typebound_symtree);
- else
{
- while (peek_atom () == ATOM_LPAREN)
+ int op;
+ for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
{
- gfc_symtree* st;
+ gfc_intrinsic_op realop;
- mio_lparen ();
-
- require_atom (ATOM_STRING);
- gfc_get_sym_tree (atom_string, f2k, &st);
- gfc_free (atom_string);
+ if (op == INTRINSIC_USER || !f2k->tb_op[op])
+ continue;
- mio_typebound_symtree (st);
+ mio_lparen ();
+ realop = (gfc_intrinsic_op) op;
+ mio_intrinsic_op (&realop);
+ mio_typebound_proc (&f2k->tb_op[op]);
+ mio_rparen ();
}
}
+ else
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC. */
+
+ mio_lparen ();
+ mio_intrinsic_op (&op);
+ mio_typebound_proc (&f2k->tb_op[op]);
+ mio_rparen ();
+ }
mio_rparen ();
}
{
int intmod = INTMOD_NONE;
- gfc_formal_arglist *formal;
-
mio_lparen ();
mio_symbol_attribute (&sym->attr);
mio_typespec (&sym->ts);
- /* Contained procedures don't have formal namespaces. Instead we output the
- procedure namespace. The will contain the formal arguments. */
if (iomode == IO_OUTPUT)
- {
- formal = sym->formal;
- while (formal && !formal->sym)
- formal = formal->next;
-
- if (formal)
- mio_namespace_ref (&formal->sym->ns);
- else
- mio_namespace_ref (&sym->formal_ns);
- }
+ mio_namespace_ref (&sym->formal_ns);
else
{
mio_namespace_ref (&sym->formal_ns);
/* Save/restore common block links. */
mio_symbol_ref (&sym->common_next);
- mio_formal_arglist (sym);
+ mio_formal_arglist (&sym->formal);
if (sym->attr.flavor == FL_PARAMETER)
mio_expr (&sym->value);
else
{
mio_integer (&intmod);
- sym->from_intmod = intmod;
+ sym->from_intmod = (intmod_id) intmod;
}
mio_integer (&(sym->intmod_sym_id));
-
+
+ if (sym->attr.flavor == FL_DERIVED)
+ mio_integer (&(sym->hash_value));
+
mio_rparen ();
}
const char *p;
char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
- gfc_interface *generic = NULL;
+ gfc_interface *generic = NULL, *gen = NULL;
int n, i, renamed;
+ bool ambiguous_set = false;
mio_lparen ();
sym = st->n.sym;
if (st && !sym->attr.generic
+ && !st->ambiguous
&& sym->module
&& strcmp(module, sym->module))
- st->ambiguous = 1;
+ {
+ ambiguous_set = true;
+ st->ambiguous = 1;
+ }
}
sym->attr.use_only = only_flag;
sym->generic = generic;
sym->attr.generic_copy = 1;
}
+
+ /* If a procedure that is not generic has generic interfaces
+ that include itself, it is generic! We need to take care
+ to retain symbols ambiguous that were already so. */
+ if (sym->attr.use_assoc
+ && !sym->attr.generic
+ && sym->attr.flavor == FL_PROCEDURE)
+ {
+ for (gen = generic; gen; gen = gen->next)
+ {
+ if (gen->sym == sym)
+ {
+ sym->attr.generic = 1;
+ if (ambiguous_set)
+ st->ambiguous = 0;
+ break;
+ }
+ }
+ }
+
}
}
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;
}
+/* This function loads the sym_root of f2k_derived with the extensions to
+ the derived type. */
+static void
+load_derived_extensions (void)
+{
+ int symbol, j;
+ gfc_symbol *derived;
+ gfc_symbol *dt;
+ gfc_symtree *st;
+ pointer_info *info;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ char module[GFC_MAX_SYMBOL_LEN + 1];
+ const char *p;
+
+ mio_lparen ();
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ mio_lparen ();
+ mio_integer (&symbol);
+ info = get_integer (symbol);
+ derived = info->u.rsym.sym;
+
+ /* This one is not being loaded. */
+ if (!info || !derived)
+ {
+ while (peek_atom () != ATOM_RPAREN)
+ skip_list ();
+ continue;
+ }
+
+ gcc_assert (derived->attr.flavor == FL_DERIVED);
+ if (derived->f2k_derived == NULL)
+ derived->f2k_derived = gfc_get_namespace (NULL, 0);
+
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ mio_lparen ();
+ mio_internal_string (name);
+ mio_internal_string (module);
+
+ /* Only use one use name to find the symbol. */
+ j = 1;
+ p = find_use_name_n (name, &j, false);
+ if (p)
+ {
+ st = gfc_find_symtree (gfc_current_ns->sym_root, p);
+ dt = st->n.sym;
+ st = gfc_find_symtree (derived->f2k_derived->sym_root, name);
+ if (st == NULL)
+ {
+ /* Only use the real name in f2k_derived to ensure a single
+ symtree. */
+ st = gfc_new_symtree (&derived->f2k_derived->sym_root, name);
+ st->n.sym = dt;
+ st->n.sym->refs++;
+ }
+ }
+ mio_rparen ();
+ }
+ mio_rparen ();
+ }
+ mio_rparen ();
+}
+
+
/* Recursive function to traverse the pointer_info tree and load a
needed symbol. We return nonzero if we load a symbol and stop the
traversal, because the act of loading can alter the tree. */
if (st_sym == rsym)
return false;
- /* Identical derived types are not ambiguous and will be rolled up
- later. */
- if (st_sym->attr.flavor == FL_DERIVED
- && rsym->attr.flavor == FL_DERIVED
- && gfc_compare_derived_types (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
static void
read_module (void)
{
- module_locus operator_interfaces, user_operators;
+ module_locus operator_interfaces, user_operators, extensions;
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;
skip_list ();
skip_list ();
- /* Skip commons and equivalences for now. */
+ /* Skip commons, equivalences and derived type extensions for now. */
skip_list ();
skip_list ();
+ get_module_locus (&extensions);
+ skip_list ();
+
mio_lparen ();
/* Create the fixup nodes for all the symbols. */
if (only_flag)
{
- u = find_use_operator (i);
+ u = find_use_operator ((gfc_intrinsic_op) i);
if (u == NULL)
{
module_name);
}
- gfc_check_interfaces (gfc_current_ns);
+ /* Now we should be in a position to fill f2k_derived with derived type
+ extensions, since everything has been loaded. */
+ set_module_locus (&extensions);
+ load_derived_extensions ();
/* Clean up symbol nodes that were never loaded, create references
to hidden symbols. */
/* 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;
}
}
+/* Write derived type extensions to the module. */
+
+static void
+write_dt_extensions (gfc_symtree *st)
+{
+ if (!gfc_check_access (st->n.sym->attr.access,
+ st->n.sym->ns->default_access))
+ return;
+
+ mio_lparen ();
+ mio_pool_string (&st->n.sym->name);
+ if (st->n.sym->module != NULL)
+ mio_pool_string (&st->n.sym->module);
+ else
+ mio_internal_string (module_name);
+ mio_rparen ();
+}
+
+static void
+write_derived_extensions (gfc_symtree *st)
+{
+ if (!((st->n.sym->attr.flavor == FL_DERIVED)
+ && (st->n.sym->f2k_derived != NULL)
+ && (st->n.sym->f2k_derived->sym_root != NULL)))
+ return;
+
+ mio_lparen ();
+ mio_symbol_ref (&(st->n.sym));
+ gfc_traverse_symtree (st->n.sym->f2k_derived->sym_root,
+ write_dt_extensions);
+ mio_rparen ();
+}
+
+
/* Write a symbol to the module. */
static void
static void
write_module (void)
{
- gfc_intrinsic_op i;
+ int i;
/* Write the operator interfaces. */
mio_lparen ();
write_char ('\n');
write_char ('\n');
+ mio_lparen ();
+ gfc_traverse_symtree (gfc_current_ns->sym_root,
+ write_derived_extensions);
+ mio_rparen ();
+ write_char ('\n');
+ write_char ('\n');
+
/* Write symbol information. First we traverse all symbols in the
primary namespace, writing those that need to be written.
Sometimes writing one symbol will cause another to need to be
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));
+ }
}
if (mod_symtree == NULL)
{
/* symtree doesn't already exist in current namespace. */
- gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree);
+ gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
+ false);
if (mod_symtree != NULL)
mod_sym = mod_symtree->n.sym;
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_error ("Symbol '%s' already declared", name);
}
- gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
sym = tmp_symtree->n.sym;
sym->module = gfc_get_string (modname);
mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
if (mod_symtree == NULL)
{
- gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
+ gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
gcc_assert (mod_symtree);
mod_sym = mod_symtree->n.sym;
gfc_option.flag_default_integer
? "-fdefault-integer-8" : "-fdefault-real-8");
+ if (gfc_notify_std (symbol[i].standard, "The symbol '%s', referrenced "
+ "at %C, is not in the selected standard",
+ symbol[i].name) == FAILURE)
+ continue;
+
create_int_parameter (u->local_name[0] ? u->local_name
: symbol[i].name,
symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
for (i = 0; symbol[i].name; i++)
{
local_name = NULL;
+
+ if ((gfc_option.allow_std & symbol[i].standard) == 0)
+ break;
+
for (u = gfc_rename_list; u; u = u->next)
{
if (strcmp (symbol[i].name, u->use_name) == 0)
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 '%s') "
+ "for file '%s' opened at %C", atom_string,
+ MOD_VERSION, filename);
+ }
+ }
if (c == '\n')
line++;