/* Handle modules, which amounts to loading and saving symbols and
their attendant structures.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free
- Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "arith.h"
#include "match.h"
#include "parse.h" /* FIXME */
+#include "md5.h"
#define MODULE_EXTENSION ".mod"
}
module_locus;
+/* Structure for list of symbols of intrinsic modules. */
+typedef struct
+{
+ int id;
+ const char *name;
+ int value;
+}
+intmod_sym;
+
typedef enum
{
module_locus where;
fixup_t *stfixup;
gfc_symtree *symtree;
+ char binding_label[GFC_MAX_SYMBOL_LEN + 1];
}
rsym;
/* The FILE for the module we're reading or writing. */
static FILE *module_fp;
+/* MD5 context structure. */
+static struct md5_ctx ctx;
+
/* The name of the module we're reading (USE'ing) or writing. */
static char module_name[GFC_MAX_SYMBOL_LEN + 1];
+/* The way the module we're reading was specified. */
+static bool specified_nonint, specified_int;
+
static int module_line, module_column, only_flag;
static enum
{ IO_INPUT, IO_OUTPUT }
static pointer_info *pi_root;
static int symbol_number; /* Counter for assigning symbol numbers */
-/* Tells mio_expr_ref not to load unused equivalence members. */
+/* Tells mio_expr_ref to make symbols for unused equivalence members. */
static bool in_load_equiv;
/* Recursively free the tree of pointer structures. */
static void
-free_pi_tree (pointer_info * p)
+free_pi_tree (pointer_info *p)
{
if (p == NULL)
return;
module. */
static int
-compare_pointers (void * _sn1, void * _sn2)
+compare_pointers (void *_sn1, void *_sn2)
{
pointer_info *sn1, *sn2;
module. */
static int
-compare_integers (void * _sn1, void * _sn2)
+compare_integers (void *_sn1, void *_sn2)
{
pointer_info *sn1, *sn2;
/* Recursive function to find a pointer within a tree by brute force. */
static pointer_info *
-fp2 (pointer_info * p, const void *target)
+fp2 (pointer_info *p, const void *target)
{
pointer_info *q;
static pointer_info *
find_pointer2 (void *p)
{
-
return fp2 (pi_root, p);
}
/* Resolve any fixups using a known pointer. */
+
static void
-resolve_fixups (fixup_t *f, void * gp)
+resolve_fixups (fixup_t *f, void *gp)
{
fixup_t *next;
}
}
+
/* 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)
+associate_integer_pointer (pointer_info *p, void *gp)
{
if (p->u.pointer != NULL)
gfc_internal_error ("associate_integer_pointer(): Already associated");
match
gfc_match_use (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
gfc_use_rename *tail = NULL, *new;
- interface_type type;
+ interface_type type, type2;
gfc_intrinsic_op operator;
match m;
+ specified_int = false;
+ specified_nonint = false;
+
+ if (gfc_match (" , ") == MATCH_YES)
+ {
+ if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: module "
+ "nature in USE statement at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ if (strcmp (module_nature, "intrinsic") == 0)
+ specified_int = true;
+ else
+ {
+ if (strcmp (module_nature, "non_intrinsic") == 0)
+ specified_nonint = true;
+ else
+ {
+ gfc_error ("Module nature in USE statement at %C shall "
+ "be either INTRINSIC or NON_INTRINSIC");
+ return MATCH_ERROR;
+ }
+ }
+ }
+ 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");
+ return m;
+ }
+ }
+ else
+ {
+ m = gfc_match (" ::");
+ if (m == MATCH_YES &&
+ gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
+ "\"USE :: module\" at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ if (m != MATCH_YES)
+ {
+ m = gfc_match ("% ");
+ if (m != MATCH_YES)
+ return m;
+ }
+ }
+
m = gfc_match_name (module_name);
if (m != MATCH_YES)
return m;
tail = new;
/* See what kind of interface we're dealing with. Assume it is
- not an operator. */
+ not an operator. */
new->operator = INTRINSIC_NONE;
if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
goto cleanup;
gfc_error ("Missing generic specification in USE statement at %C");
goto cleanup;
+ case INTERFACE_USER_OP:
case INTERFACE_GENERIC:
m = gfc_match (" =>");
+ if (type == INTERFACE_USER_OP && m == MATCH_YES
+ && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Renaming "
+ "operators in USE statements at %C")
+ == FAILURE))
+ goto cleanup;
+
if (only_flag)
{
if (m != MATCH_YES)
else
{
strcpy (new->local_name, name);
-
- m = gfc_match_name (new->use_name);
+ m = gfc_match_generic_spec (&type2, new->use_name, &operator);
+ if (type != type2)
+ goto syntax;
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto syntax;
strcpy (new->local_name, name);
- m = gfc_match_name (new->use_name);
+ m = gfc_match_generic_spec (&type2, new->use_name, &operator);
+ if (type != type2)
+ goto syntax;
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
}
+ if (strcmp (new->use_name, module_name) == 0
+ || strcmp (new->local_name, module_name) == 0)
+ {
+ gfc_error ("The name '%s' at %C has already been used as "
+ "an external module name.", module_name);
+ goto cleanup;
+ }
break;
- case INTERFACE_USER_OP:
- strcpy (new->use_name, name);
- /* Fall through */
-
case INTERFACE_INTRINSIC_OP:
new->operator = operator;
break;
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. */
return find_use_name_n (name, &i);
}
-/* Given a real name, return the number of use names associated
- with it. */
+
+/* Given a real name, return the number of use names associated with it. */
static int
number_use_names (const char *name)
/* Compare two true_name structures. */
static int
-compare_true_names (void * _t1, void * _t2)
+compare_true_names (void *_t1, void *_t2)
{
true_name *t1, *t2;
int c;
p = true_name_root;
while (p != NULL)
{
- c = compare_true_names ((void *)(&t), (void *) p);
+ c = compare_true_names ((void *) (&t), (void *) p);
if (c == 0)
return p->sym;
}
-/* Given a gfc_symbol pointer that is not in the true name tree, add
- it. */
+/* Given a gfc_symbol pointer that is not in the true name tree, add it. */
static void
-add_true_name (gfc_symbol * sym)
+add_true_name (gfc_symbol *sym)
{
true_name *t;
recursively traversing the current namespace. */
static void
-build_tnt (gfc_symtree * st)
+build_tnt (gfc_symtree *st)
{
-
if (st == NULL)
return;
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)
+free_true_name (true_name *t)
{
-
if (t == NULL)
return;
free_true_name (t->left);
/* Set the module's input pointer. */
static void
-set_module_locus (module_locus * m)
+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)
+get_module_locus (module_locus *m)
{
-
m->column = module_column;
m->line = module_line;
fgetpos (module_fp, &m->pos);
{
int c;
- c = fgetc (module_fp);
+ c = getc (module_fp);
if (c == EOF)
bad_module ("Unexpected EOF");
len = 0;
- /* See how long the string is */
+ /* See how long the string is. */
for ( ; ; )
{
c = module_char ();
bad_module ("Unexpected end of module in string constant");
if (c != '\'')
- {
+ {
len++;
continue;
}
c = module_char ();
if (c == '\'')
- {
+ {
len++;
continue;
}
{
c = module_char ();
if (c == '\'')
- module_char (); /* Guaranteed to be another \' */
+ module_char (); /* Guaranteed to be another \'. */
*p++ = c;
}
- module_char (); /* Terminating \' */
- *p = '\0'; /* C-style string for debug purposes */
+ module_char (); /* Terminating \'. */
+ *p = '\0'; /* C-style string for debug purposes. */
}
bad_module ("Bad name");
}
- /* Not reached */
+ /* Not reached. */
}
be one of the strings in the array. We return the enum value. */
static int
-find_enum (const mstring * m)
+find_enum (const mstring *m)
{
int i;
bad_module ("find_enum(): Enum not found");
- /* Not reached */
+ /* Not reached. */
}
static void
write_char (char out)
{
-
- if (fputc (out, module_fp) == EOF)
+ if (putc (out, module_fp) == EOF)
gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
+ /* Add this to our MD5. */
+ md5_process_bytes (&out, sizeof (out), &ctx);
+
if (out != '\n')
module_column++;
else
}
+ if(p == NULL || *p == '\0')
+ len = 0;
+ else
len = strlen (p);
if (atom != ATOM_RPAREN)
if (atom == ATOM_STRING)
write_char ('\'');
- while (*p)
+ while (p != NULL && *p)
{
if (atom == ATOM_STRING && *p == '\'')
write_char ('\'');
pointer because enums are sometimes inside bitfields. */
static int
-mio_name (int t, const mstring * m)
+mio_name (int t, const mstring *m)
{
-
if (iomode == IO_OUTPUT)
write_atom (ATOM_NAME, gfc_code2string (m, t));
else
#define DECL_MIO_NAME(TYPE) \
static inline TYPE \
- MIO_NAME(TYPE) (TYPE t, const mstring * m) \
+ MIO_NAME(TYPE) (TYPE t, const mstring *m) \
{ \
- return (TYPE)mio_name ((int)t, 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
static void
mio_rparen (void)
{
-
if (iomode == IO_OUTPUT)
write_atom (ATOM_RPAREN, NULL);
else
static void
mio_integer (int *ip)
{
-
if (iomode == IO_OUTPUT)
write_atom (ATOM_INTEGER, ip);
else
}
-/* Read or write a character pointer that points to a string on the
- heap. */
+/* Read or write a character pointer that points to a string on the heap. */
static const char *
mio_allocated_string (const char *s)
static void
mio_internal_string (char *string)
{
-
if (iomode == IO_OUTPUT)
write_atom (ATOM_STRING, string);
else
}
-
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_THREADPRIVATE
+ 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_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
+ AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C
}
ab_attribute;
minit ("INTRINSIC", AB_INTRINSIC),
minit ("OPTIONAL", AB_OPTIONAL),
minit ("POINTER", AB_POINTER),
- minit ("SAVE", AB_SAVE),
+ minit ("VOLATILE", AB_VOLATILE),
minit ("TARGET", AB_TARGET),
minit ("THREADPRIVATE", AB_THREADPRIVATE),
minit ("DUMMY", AB_DUMMY),
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 ("POINTER_COMP", AB_POINTER_COMP),
+ minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
+ minit ("PROTECTED", AB_PROTECTED),
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)
+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)
#undef DECL_MIO_NAME
/* Symbol attributes are stored in list with the first three elements
written. */
static void
-mio_symbol_attribute (symbol_attribute * attr)
+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);
+ 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);
if (iomode == IO_OUTPUT)
{
if (attr->allocatable)
- MIO_NAME(ab_attribute) (AB_ALLOCATABLE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
if (attr->dimension)
- MIO_NAME(ab_attribute) (AB_DIMENSION, attr_bits);
+ MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
if (attr->external)
- MIO_NAME(ab_attribute) (AB_EXTERNAL, attr_bits);
+ MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
if (attr->intrinsic)
- MIO_NAME(ab_attribute) (AB_INTRINSIC, attr_bits);
+ MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
if (attr->optional)
- MIO_NAME(ab_attribute) (AB_OPTIONAL, attr_bits);
+ 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);
+ MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
+ if (attr->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);
+ MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
if (attr->threadprivate)
- MIO_NAME(ab_attribute) (AB_THREADPRIVATE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
if (attr->dummy)
- MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits);
+ MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
if (attr->result)
- MIO_NAME(ab_attribute) (AB_RESULT, attr_bits);
+ 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);
+ MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
if (attr->in_namelist)
- MIO_NAME(ab_attribute) (AB_IN_NAMELIST, attr_bits);
+ MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
if (attr->in_common)
- MIO_NAME(ab_attribute) (AB_IN_COMMON, attr_bits);
+ MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
if (attr->function)
- MIO_NAME(ab_attribute) (AB_FUNCTION, attr_bits);
+ MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
if (attr->subroutine)
- MIO_NAME(ab_attribute) (AB_SUBROUTINE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
if (attr->generic)
- MIO_NAME(ab_attribute) (AB_GENERIC, attr_bits);
+ MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
if (attr->sequence)
- MIO_NAME(ab_attribute) (AB_SEQUENCE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
if (attr->elemental)
- MIO_NAME(ab_attribute) (AB_ELEMENTAL, attr_bits);
+ MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
if (attr->pure)
- MIO_NAME(ab_attribute) (AB_PURE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
if (attr->recursive)
- MIO_NAME(ab_attribute) (AB_RECURSIVE, attr_bits);
+ MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
if (attr->always_explicit)
- MIO_NAME(ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
+ MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
if (attr->cray_pointer)
- MIO_NAME(ab_attribute) (AB_CRAY_POINTER, attr_bits);
+ MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
if (attr->cray_pointee)
- MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
+ 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->private_comp)
+ MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
mio_rparen ();
}
else
{
-
for (;;)
{
t = parse_atom ();
case AB_POINTER:
attr->pointer = 1;
break;
- case AB_SAVE:
- attr->save = 1;
+ case AB_PROTECTED:
+ attr->protected = 1;
+ break;
+ case AB_VALUE:
+ attr->value = 1;
+ break;
+ case AB_VOLATILE:
+ attr->volatile_ = 1;
break;
case AB_TARGET:
attr->target = 1;
case AB_RECURSIVE:
attr->recursive = 1;
break;
- case AB_ALWAYS_EXPLICIT:
- attr->always_explicit = 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_POINTER_COMP:
+ attr->pointer_comp = 1;
+ break;
+ case AB_PRIVATE_COMP:
+ attr->private_comp = 1;
+ break;
}
}
}
minit ("DERIVED", BT_DERIVED),
minit ("PROCEDURE", BT_PROCEDURE),
minit ("UNKNOWN", BT_UNKNOWN),
+ minit ("VOID", BT_VOID),
minit (NULL, -1)
};
static void
-mio_charlen (gfc_charlen ** clp)
+mio_charlen (gfc_charlen **clp)
{
gfc_charlen *cl;
}
else
{
-
if (peek_atom () != ATOM_RPAREN)
{
cl = gfc_get_charlen ();
within the namespace and corresponds to an illegal fortran name. */
static gfc_symtree *
-get_unique_symtree (gfc_namespace * ns)
+get_unique_symtree (gfc_namespace *ns)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
static int serial = 0;
static int
check_unique_name (const char *name)
{
-
return *name == '@';
}
static void
-mio_typespec (gfc_typespec * ts)
+mio_typespec (gfc_typespec *ts)
{
-
mio_lparen ();
- ts->type = MIO_NAME(bt) (ts->type, bt_types);
+ 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);
+ /* 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->cl is only valid for BT_CHARACTER. */
+ mio_lparen ();
+ mio_rparen ();
+ }
+ else
+ mio_charlen (&ts->cl);
mio_rparen ();
}
static void
-mio_array_spec (gfc_array_spec ** asp)
+mio_array_spec (gfc_array_spec **asp)
{
gfc_array_spec *as;
int i;
}
mio_integer (&as->rank);
- as->type = MIO_NAME(array_type) (as->type, array_spec_types);
+ as->type = MIO_NAME (array_type) (as->type, array_spec_types);
for (i = 0; i < as->rank; i++)
{
minit (NULL, -1)
};
+
static void
-mio_array_ref (gfc_array_ref * ar)
+mio_array_ref (gfc_array_ref *ar)
{
int i;
mio_lparen ();
- ar->type = MIO_NAME(ar_type) (ar->type, array_ref_types);
+ ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
mio_integer (&ar->dimen);
switch (ar->type)
gfc_internal_error ("mio_array_ref(): Unknown array ref");
}
- for (i = 0; i < ar->dimen; i++)
- mio_integer ((int *) &ar->dimen_type[i]);
+ /* 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++)
+ {
+ int tmp = (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] = atom_int;
+ }
+ }
if (iomode == IO_INPUT)
{
the namespace and is not loaded again. */
static void
-mio_component_ref (gfc_component ** cp, gfc_symbol * sym)
+mio_component_ref (gfc_component **cp, gfc_symbol *sym)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_component *q;
static void
-mio_component (gfc_component * c)
+mio_component (gfc_component *c)
{
pointer_info *p;
int n;
mio_integer (&c->dimension);
mio_integer (&c->pointer);
+ mio_integer (&c->allocatable);
+ c->access = MIO_NAME (gfc_access) (c->access, access_types);
mio_expr (&c->initializer);
mio_rparen ();
static void
-mio_component_list (gfc_component ** cp)
+mio_component_list (gfc_component **cp)
{
gfc_component *c, *tail;
}
else
{
-
*cp = NULL;
tail = NULL;
static void
-mio_actual_arg (gfc_actual_arglist * a)
+mio_actual_arg (gfc_actual_arglist *a)
{
-
mio_lparen ();
mio_pool_string (&a->name);
mio_expr (&a->expr);
static void
-mio_actual_arglist (gfc_actual_arglist ** ap)
+mio_actual_arglist (gfc_actual_arglist **ap)
{
gfc_actual_arglist *a, *tail;
/* Read and write formal argument lists. */
static void
-mio_formal_arglist (gfc_symbol * sym)
+mio_formal_arglist (gfc_symbol *sym)
{
gfc_formal_arglist *f, *tail;
{
for (f = sym->formal; f; f = f->next)
mio_symbol_ref (&f->sym);
-
}
else
{
/* Save or restore a reference to a symbol node. */
void
-mio_symbol_ref (gfc_symbol ** symp)
+mio_symbol_ref (gfc_symbol **symp)
{
pointer_info *p;
/* Save or restore a reference to a symtree node. */
static void
-mio_symtree_ref (gfc_symtree ** stp)
+mio_symtree_ref (gfc_symtree **stp)
{
pointer_info *p;
fixup_t *f;
- gfc_symtree * ns_st = NULL;
if (iomode == IO_OUTPUT)
- {
- /* If this is a symtree for a symbol that came from a contained module
- namespace, it has a unique name and we should look in the current
- namespace to see if the required, non-contained symbol is available
- yet. If so, the latter should be written. */
- if ((*stp)->n.sym && check_unique_name((*stp)->name))
- ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
- (*stp)->n.sym->name);
-
- /* On the other hand, if the existing symbol is the module name or the
- new symbol is a dummy argument, do not do the promotion. */
- if (ns_st && ns_st->n.sym
- && ns_st->n.sym->attr.flavor != FL_MODULE
- && !(*stp)->n.sym->attr.dummy)
- mio_symbol_ref (&ns_st->n.sym);
- else
- mio_symbol_ref (&(*stp)->n.sym);
- }
+ mio_symbol_ref (&(*stp)->n.sym);
else
{
require_atom (ATOM_INTEGER);
p = get_integer (atom_int);
- /* An unused equivalence member; bail out. */
+ /* An unused equivalence member; make a symbol and a symtree
+ for it. */
if (in_load_equiv && p->u.rsym.symtree == NULL)
- return;
+ {
+ /* Since this is not used, it must have a unique name. */
+ p->u.rsym.symtree = 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 (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 (p->type == P_UNKNOWN)
- p->type = P_SYMBOL;
+ 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;
- }
+ {
+ *stp = p->u.rsym.symtree;
+ }
else
- {
- f = gfc_getmem (sizeof (fixup_t));
+ {
+ f = gfc_getmem (sizeof (fixup_t));
- f->next = p->u.rsym.stfixup;
- p->u.rsym.stfixup = f;
+ f->next = p->u.rsym.stfixup;
+ p->u.rsym.stfixup = f;
- f->pointer = (void **)stp;
- }
+ f->pointer = (void **) stp;
+ }
}
}
+
static void
-mio_iterator (gfc_iterator ** ip)
+mio_iterator (gfc_iterator **ip)
{
gfc_iterator *iter;
}
-
static void
-mio_constructor (gfc_constructor ** cp)
+mio_constructor (gfc_constructor **cp)
{
gfc_constructor *c, *tail;
}
else
{
-
*cp = NULL;
tail = NULL;
}
-
static const mstring ref_types[] = {
minit ("ARRAY", REF_ARRAY),
minit ("COMPONENT", REF_COMPONENT),
static void
-mio_ref (gfc_ref ** rp)
+mio_ref (gfc_ref **rp)
{
gfc_ref *r;
mio_lparen ();
r = *rp;
- r->type = MIO_NAME(ref_type) (r->type, ref_types);
+ r->type = MIO_NAME (ref_type) (r->type, ref_types);
switch (r->type)
{
static void
-mio_ref_list (gfc_ref ** rp)
+mio_ref_list (gfc_ref **rp)
{
gfc_ref *ref, *head, *tail;
/* Read and write an integer value. */
static void
-mio_gmp_integer (mpz_t * integer)
+mio_gmp_integer (mpz_t *integer)
{
char *p;
bad_module ("Error converting integer");
gfc_free (atom_string);
-
}
else
{
static void
-mio_gmp_real (mpfr_t * real)
+mio_gmp_real (mpfr_t *real)
{
mp_exp_t exponent;
char *p;
mpfr_init (*real);
mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
gfc_free (atom_string);
-
}
else
{
/* Save and restore the shape of an array constructor. */
static void
-mio_shape (mpz_t ** pshape, int rank)
+mio_shape (mpz_t **pshape, int rank)
{
mpz_t *shape;
atom_type t;
minit ("OR", INTRINSIC_OR),
minit ("EQV", INTRINSIC_EQV),
minit ("NEQV", INTRINSIC_NEQV),
- minit ("EQ", INTRINSIC_EQ),
- minit ("NE", INTRINSIC_NE),
- minit ("GT", INTRINSIC_GT),
- minit ("GE", INTRINSIC_GE),
- minit ("LT", INTRINSIC_LT),
- minit ("LE", INTRINSIC_LE),
+ minit ("==", INTRINSIC_EQ),
+ minit ("EQ", INTRINSIC_EQ_OS),
+ minit ("/=", INTRINSIC_NE),
+ minit ("NE", INTRINSIC_NE_OS),
+ minit (">", INTRINSIC_GT),
+ minit ("GT", INTRINSIC_GT_OS),
+ minit (">=", INTRINSIC_GE),
+ minit ("GE", INTRINSIC_GE_OS),
+ minit ("<", INTRINSIC_LT),
+ minit ("LT", INTRINSIC_LT_OS),
+ minit ("<=", INTRINSIC_LE),
+ minit ("LE", INTRINSIC_LE_OS),
minit ("NOT", INTRINSIC_NOT),
minit ("PARENTHESES", INTRINSIC_PARENTHESES),
minit (NULL, -1)
};
+
+/* Remedy a couple of situations where the gfc_expr's can be defective. */
+
+static void
+fix_mio_expr (gfc_expr *e)
+{
+ gfc_symtree *ns_st = NULL;
+ const char *fname;
+
+ if (iomode != IO_OUTPUT)
+ return;
+
+ if (e->symtree)
+ {
+ /* If this is a symtree for a symbol that came from a contained module
+ namespace, it has a unique name and we should look in the current
+ namespace to see if the required, non-contained symbol is available
+ yet. If so, the latter should be written. */
+ if (e->symtree->n.sym && check_unique_name (e->symtree->name))
+ ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
+ e->symtree->n.sym->name);
+
+ /* On the other hand, if the existing symbol is the module name or the
+ new symbol is a dummy argument, do not do the promotion. */
+ if (ns_st && ns_st->n.sym
+ && ns_st->n.sym->attr.flavor != FL_MODULE
+ && !e->symtree->n.sym->attr.dummy)
+ e->symtree = ns_st;
+ }
+ else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
+ {
+ /* 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
+ expression in another module. */
+ 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);
+ }
+}
+
+
/* Read and write expressions. The form "()" is allowed to indicate a
NULL expression. */
static void
-mio_expr (gfc_expr ** ep)
+mio_expr (gfc_expr **ep)
{
gfc_expr *e;
atom_type t;
}
e = *ep;
- MIO_NAME(expr_t) (e->expr_type, expr_types);
-
+ MIO_NAME (expr_t) (e->expr_type, expr_types);
}
else
{
mio_typespec (&e->ts);
mio_integer (&e->rank);
+ fix_mio_expr (e);
+
switch (e->expr_type)
{
case EXPR_OP:
e->value.op.operator
- = MIO_NAME(gfc_intrinsic_op) (e->value.op.operator, intrinsics);
+ = MIO_NAME (gfc_intrinsic_op) (e->value.op.operator, intrinsics);
switch (e->value.op.operator)
{
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
case INTRINSIC_EQ:
+ case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
+ case INTRINSIC_NE_OS:
case INTRINSIC_GT:
+ case INTRINSIC_GT_OS:
case INTRINSIC_GE:
+ case INTRINSIC_GE_OS:
case INTRINSIC_LT:
+ case INTRINSIC_LT_OS:
case INTRINSIC_LE:
+ case INTRINSIC_LE_OS:
mio_expr (&e->value.op.op1);
mio_expr (&e->value.op.op2);
break;
mio_symbol_ref (&e->value.function.esym);
else
write_atom (ATOM_STRING, e->value.function.isym->name);
-
}
else
{
break;
case EXPR_SUBSTRING:
- e->value.character.string = (char *)
- mio_allocated_string (e->value.character.string);
+ e->value.character.string
+ = (char *) mio_allocated_string (e->value.character.string);
mio_ref_list (&e->ref);
break;
break;
case BT_REAL:
- gfc_set_model_kind (e->ts.kind);
+ gfc_set_model_kind (e->ts.kind);
mio_gmp_real (&e->value.real);
break;
case BT_COMPLEX:
- gfc_set_model_kind (e->ts.kind);
+ gfc_set_model_kind (e->ts.kind);
mio_gmp_real (&e->value.complex.r);
mio_gmp_real (&e->value.complex.i);
break;
case BT_CHARACTER:
mio_integer (&e->value.character.length);
- e->value.character.string = (char *)
- mio_allocated_string (e->value.character.string);
+ e->value.character.string
+ = (char *) mio_allocated_string (e->value.character.string);
break;
default:
}
-/* Read and write namelists */
+/* Read and write namelists. */
static void
-mio_namelist (gfc_symbol * sym)
+mio_namelist (gfc_symbol *sym)
{
gfc_namelist *n, *m;
const char *check_name;
{
check_name = find_use_name (sym->name);
if (check_name && strcmp (check_name, sym->name) != 0)
- gfc_error("Namelist %s cannot be renamed by USE"
- " association to %s.",
- sym->name, check_name);
+ gfc_error ("Namelist %s cannot be renamed by USE "
+ "association to %s", sym->name, check_name);
}
m = NULL;
be done later when all symbols have been loaded. */
static void
-mio_interface_rest (gfc_interface ** ip)
+mio_interface_rest (gfc_interface **ip)
{
gfc_interface *tail, *p;
}
else
{
-
if (*ip == NULL)
tail = NULL;
else
/* Save/restore a nameless operator interface. */
static void
-mio_interface (gfc_interface ** ip)
+mio_interface (gfc_interface **ip)
{
-
mio_lparen ();
mio_interface_rest (ip);
}
static void
mio_symbol_interface (const char **name, const char **module,
- gfc_interface ** ip)
+ gfc_interface **ip)
{
-
mio_lparen ();
-
mio_pool_string (name);
mio_pool_string (module);
-
mio_interface_rest (ip);
}
static void
-mio_namespace_ref (gfc_namespace ** nsp)
+mio_namespace_ref (gfc_namespace **nsp)
{
gfc_namespace *ns;
pointer_info *p;
if (iomode == IO_INPUT && p->integer != 0)
{
- ns = (gfc_namespace *)p->u.pointer;
+ ns = (gfc_namespace *) p->u.pointer;
if (ns == NULL)
{
ns = gfc_get_namespace (NULL, 0);
}
-/* Unlike most other routines, the address of the symbol node is
- already fixed on input and the name/module has already been filled
- in. */
+/* Unlike most other routines, the address of the symbol node is already
+ fixed on input and the name/module has already been filled in. */
static void
-mio_symbol (gfc_symbol * sym)
+mio_symbol (gfc_symbol *sym)
{
+ int intmod = INTMOD_NONE;
+
gfc_formal_arglist *formal;
mio_lparen ();
}
}
- /* Save/restore common block links */
+ /* Save/restore common block links. */
mio_symbol_ref (&sym->common_next);
mio_formal_arglist (sym);
mio_component_list (&sym->components);
if (sym->components != NULL)
- sym->component_access =
- MIO_NAME(gfc_access) (sym->component_access, access_types);
+ sym->component_access
+ = MIO_NAME (gfc_access) (sym->component_access, access_types);
mio_namelist (sym);
+
+ /* Add the fields that say whether this is from an intrinsic module,
+ and if so, what symbol it is within the module. */
+/* mio_integer (&(sym->from_intmod)); */
+ if (iomode == IO_OUTPUT)
+ {
+ intmod = sym->from_intmod;
+ mio_integer (&intmod);
+ }
+ else
+ {
+ mio_integer (&intmod);
+ sym->from_intmod = intmod;
+ }
+
+ mio_integer (&(sym->intmod_sym_id));
+
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;
+ int n, i;
mio_lparen ();
mio_internal_string (name);
mio_internal_string (module);
- /* Decide if we need to load this one or not. */
- p = find_use_name (name);
+ n = number_use_names (name);
+ n = n ? n : 1;
- if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
+ for (i = 1; i <= n; i++)
{
- while (parse_atom () != ATOM_RPAREN);
- continue;
- }
+ /* Decide if we need to load this one or not. */
+ p = find_use_name_n (name, &i);
- if (sym == NULL)
- {
- gfc_get_symbol (p, NULL, &sym);
+ if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
+ {
+ while (parse_atom () != ATOM_RPAREN);
+ continue;
+ }
- sym->attr.flavor = FL_PROCEDURE;
- sym->attr.generic = 1;
- sym->attr.use_assoc = 1;
- }
+ if (sym == NULL)
+ {
+ gfc_get_symbol (p, NULL, &sym);
- mio_interface_rest (&sym->generic);
+ sym->attr.flavor = FL_PROCEDURE;
+ sym->attr.generic = 1;
+ sym->attr.use_assoc = 1;
+ }
+ else
+ {
+ /* Unless sym is a generic interface, this reference
+ is ambiguous. */
+ gfc_symtree *st;
+ p = p ? p : name;
+ st = gfc_find_symtree (gfc_current_ns->sym_root, p);
+ if (!sym->attr.generic
+ && sym->module != NULL
+ && strcmp(module, sym->module) != 0)
+ st->ambiguous = 1;
+ }
+ if (i == 1)
+ {
+ mio_interface_rest (&sym->generic);
+ generic = sym->generic;
+ }
+ else
+ {
+ sym->generic = generic;
+ sym->attr.generic_copy = 1;
+ }
+ }
}
mio_rparen ();
/* Load common blocks. */
static void
-load_commons(void)
+load_commons (void)
{
- char name[GFC_MAX_SYMBOL_LEN+1];
+ char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_common_head *p;
mio_lparen ();
p->threadprivate = 1;
p->use_assoc = 1;
- mio_rparen();
+ /* Get whether this was a bind(c) common or not. */
+ mio_integer (&p->is_bind_c);
+ /* Get the binding label. */
+ mio_internal_string (p->binding_label);
+
+ mio_rparen ();
}
- mio_rparen();
+ mio_rparen ();
}
-/* load_equiv()-- Load equivalences. The flag in_load_equiv informs
- mio_expr_ref of this so that unused variables are not loaded and
- so that the expression can be safely freed.*/
+
+/* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
+ so that unused variables are not loaded and so that the expression can
+ be safely freed. */
static void
-load_equiv(void)
+load_equiv (void)
{
gfc_equiv *head, *tail, *end, *eq;
bool unused;
- mio_lparen();
+ mio_lparen ();
in_load_equiv = true;
end = gfc_current_ns->equiv;
- while(end != NULL && end->next != NULL)
+ while (end != NULL && end->next != NULL)
end = end->next;
- while(peek_atom() != ATOM_RPAREN) {
- mio_lparen();
+ while (peek_atom () != ATOM_RPAREN) {
+ mio_lparen ();
head = tail = NULL;
- while(peek_atom() != ATOM_RPAREN)
+ while(peek_atom () != ATOM_RPAREN)
{
if (head == NULL)
- head = tail = gfc_get_equiv();
+ head = tail = gfc_get_equiv ();
else
{
- tail->eq = gfc_get_equiv();
+ tail->eq = gfc_get_equiv ();
tail = tail->eq;
}
- mio_pool_string(&tail->module);
- mio_expr(&tail->expr);
+ mio_pool_string (&tail->module);
+ mio_expr (&tail->expr);
}
- /* Unused variables have no symtree. */
- unused = false;
+ /* Unused equivalence members have a unique name. */
+ unused = true;
for (eq = head; eq; eq = eq->eq)
{
- if (!eq->expr->symtree)
+ if (!check_unique_name (eq->expr->symtree->name))
{
- unused = true;
+ unused = false;
break;
}
}
if (head != NULL)
end = head;
- mio_rparen();
+ mio_rparen ();
}
- mio_rparen();
+ mio_rparen ();
in_load_equiv = false;
}
+
/* 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. */
static int
-load_needed (pointer_info * p)
+load_needed (pointer_info *p)
{
gfc_namespace *ns;
pointer_info *q;
mio_symbol (sym);
sym->attr.use_assoc = 1;
+ if (only_flag)
+ sym->attr.use_only = 1;
return 1;
}
-/* Recursive function for cleaning up things after a module has been
- read. */
+/* Recursive function for cleaning up things after a module has been read. */
static void
-read_cleanup (pointer_info * p)
+read_cleanup (pointer_info *p)
{
gfc_symtree *st;
pointer_info *q;
}
+/* Given a root symtree node and a symbol, try to find a symtree that
+ references the symbol that is not a unique name. */
+
+static gfc_symtree *
+find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
+{
+ gfc_symtree *s = NULL;
+
+ if (st == NULL)
+ return s;
+
+ s = find_symtree_for_symbol (st->right, sym);
+ if (s != NULL)
+ return s;
+ s = find_symtree_for_symbol (st->left, sym);
+ if (s != NULL)
+ return s;
+
+ if (st->n.sym == sym && !check_unique_name (st->name))
+ return st;
+
+ return s;
+}
+
+
/* Read a module file. */
static void
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_intrinsic_op i;
int ambiguous, j, nuse, symbol;
- pointer_info *info;
+ pointer_info *info, *q;
gfc_use_rename *u;
gfc_symtree *st;
gfc_symbol *sym;
- get_module_locus (&operator_interfaces); /* Skip these for now */
+ get_module_locus (&operator_interfaces); /* Skip these for now. */
skip_list ();
get_module_locus (&user_operators);
mio_internal_string (info->u.rsym.true_name);
mio_internal_string (info->u.rsym.module);
+ mio_internal_string (info->u.rsym.binding_label);
+
require_atom (ATOM_INTEGER);
info->u.rsym.ns = atom_int;
sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
if (sym == NULL
- || (sym->attr.flavor == FL_VARIABLE
- && info->u.rsym.ns !=1))
+ || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
continue;
info->u.rsym.state = USED;
- info->u.rsym.referenced = 1;
info->u.rsym.sym = sym;
+
+ /* Some symbols do not have a namespace (eg. formal arguments),
+ so the automatic "unique symtree" mechanism must be suppressed
+ by marking them as referenced. */
+ q = get_integer (info->u.rsym.ns);
+ if (q->u.pointer == NULL)
+ {
+ info->u.rsym.referenced = 1;
+ continue;
+ }
+
+ /* If possible recycle the symtree that references the symbol.
+ If a symtree is not found and the module does not import one,
+ a unique-name symtree is found by read_cleanup. */
+ st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
+ if (st != NULL)
+ {
+ info->u.rsym.symtree = st;
+ info->u.rsym.referenced = 1;
+ }
}
mio_rparen ();
/* Get the jth local name for this symbol. */
p = find_use_name_n (name, &j);
- /* Skip symtree nodes not in an ONLY clause. */
+ if (p == NULL && strcmp (name, module_name) == 0)
+ p = name;
+
+ /* Skip symtree nodes not in an ONLY clause, unless there
+ is an existing symtree loaded from another USE statement. */
if (p == NULL)
- continue;
+ {
+ st = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (st != NULL)
+ info->u.rsym.symtree = st;
+ continue;
+ }
- /* Check for ambiguous symbols. */
st = gfc_find_symtree (gfc_current_ns->sym_root, p);
if (st != NULL)
{
+ /* Check for ambiguous symbols. */
if (st->n.sym != info->u.rsym.sym)
st->ambiguous = 1;
info->u.rsym.symtree = st;
}
else
{
- /* Create a symtree node in the current namespace for this symbol. */
- st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) :
- gfc_new_symtree (&gfc_current_ns->sym_root, p);
+ /* Create a symtree node in the current namespace for this
+ symbol. */
+ st = check_unique_name (p)
+ ? get_unique_symtree (gfc_current_ns)
+ : gfc_new_symtree (&gfc_current_ns->sym_root, p);
st->ambiguous = ambiguous;
/* Create a symbol node if it doesn't already exist. */
if (sym == NULL)
{
- sym = info->u.rsym.sym =
- gfc_new_symbol (info->u.rsym.true_name,
- gfc_current_ns);
-
+ info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
+ gfc_current_ns);
+ sym = info->u.rsym.sym;
sym->module = gfc_get_string (info->u.rsym.module);
+
+ /* TODO: hmm, can we test this? Do we know it will be
+ initialized to zeros? */
+ if (info->u.rsym.binding_label[0] != '\0')
+ strcpy (sym->binding_label, info->u.rsym.binding_label);
}
st->n.sym = sym;
info->u.rsym.symtree = st;
if (info->u.rsym.state == UNUSED)
- info->u.rsym.state = NEEDED;
+ info->u.rsym.state = NEEDED;
info->u.rsym.referenced = 1;
}
}
load_generic_interfaces ();
load_commons ();
- load_equiv();
+ load_equiv ();
/* At this point, we read those symbols that are needed but haven't
been loaded yet. If one symbol requires another, the other gets
while (load_needed (pi_root));
- /* Make sure all elements of the rename-list were found in the
- module. */
+ /* Make sure all elements of the rename-list were found in the module. */
for (u = gfc_rename_list; u; u = u->next)
{
if (u->operator == INTRINSIC_USER)
{
- gfc_error
- ("User operator '%s' referenced at %L not found in module '%s'",
- u->use_name, &u->where, module_name);
+ gfc_error ("User operator '%s' referenced at %L not found "
+ "in module '%s'", u->use_name, &u->where, module_name);
continue;
}
- gfc_error
- ("Intrinsic operator '%s' referenced at %L not found in module "
- "'%s'", gfc_op2string (u->operator), &u->where, module_name);
+ gfc_error ("Intrinsic operator '%s' referenced at %L not found "
+ "in module '%s'", gfc_op2string (u->operator), &u->where,
+ module_name);
}
gfc_check_interfaces (gfc_current_ns);
/* Given an access type that is specific to an entity and the default
- access, return nonzero if the entity is publicly accessible. */
+ access, return nonzero if the entity is publicly accessible. If the
+ element is declared as PUBLIC, then it is public; if declared
+ PRIVATE, then private, and otherwise it is public unless the default
+ access in this context has been declared PRIVATE. */
bool
gfc_check_access (gfc_access specific_access, gfc_access default_access)
{
-
if (specific_access == ACCESS_PUBLIC)
return TRUE;
if (specific_access == ACCESS_PRIVATE)
return FALSE;
- if (gfc_option.flag_module_access_private)
- return default_access == ACCESS_PUBLIC;
- else
- return default_access != ACCESS_PRIVATE;
-
- return FALSE;
+ return default_access != ACCESS_PRIVATE;
}
-/* Write a common block to the module */
+/* Write a common block to the module. */
static void
write_common (gfc_symtree *st)
gfc_common_head *p;
const char * name;
int flags;
-
+ const char *label;
+
if (st == NULL)
return;
- write_common(st->left);
- write_common(st->right);
+ write_common (st->left);
+ write_common (st->right);
- mio_lparen();
+ mio_lparen ();
/* Write the unmangled name. */
name = st->n.common->name;
- mio_pool_string(&name);
+ mio_pool_string (&name);
p = st->n.common;
- mio_symbol_ref(&p->head);
+ mio_symbol_ref (&p->head);
flags = p->saved ? 1 : 0;
if (p->threadprivate) flags |= 2;
- mio_integer(&flags);
+ mio_integer (&flags);
+
+ /* Write out whether the common block is bind(c) or not. */
+ mio_integer (&(p->is_bind_c));
- mio_rparen();
+ /* Write out the binding label, or the com name if no label given. */
+ if (p->is_bind_c)
+ {
+ label = p->binding_label;
+ mio_pool_string (&label);
+ }
+ else
+ {
+ label = p->name;
+ mio_pool_string (&label);
+ }
+
+ mio_rparen ();
}
-/* Write the blank common block to the module */
+
+/* Write the blank common block to the module. */
static void
write_blank_common (void)
{
const char * name = BLANK_COMMON_NAME;
int saved;
+ /* TODO: Blank commons are not bind(c). The F2003 standard probably says
+ this, but it hasn't been checked. Just making it so for now. */
+ int is_bind_c = 0;
if (gfc_current_ns->blank_common.head == NULL)
return;
- mio_lparen();
+ mio_lparen ();
- mio_pool_string(&name);
+ mio_pool_string (&name);
- mio_symbol_ref(&gfc_current_ns->blank_common.head);
+ mio_symbol_ref (&gfc_current_ns->blank_common.head);
saved = gfc_current_ns->blank_common.saved;
- mio_integer(&saved);
+ mio_integer (&saved);
+
+ /* Write out whether the common block is bind(c) or not. */
+ mio_integer (&is_bind_c);
+
+ /* Write out the binding label, which is BLANK_COMMON_NAME, though
+ it doesn't matter because the label isn't used. */
+ mio_pool_string (&name);
- mio_rparen();
+ mio_rparen ();
}
+
/* Write equivalences to the module. */
static void
-write_equiv(void)
+write_equiv (void)
{
gfc_equiv *eq, *e;
int num;
num = 0;
- for(eq=gfc_current_ns->equiv; eq; eq=eq->next)
+ for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
{
- mio_lparen();
+ mio_lparen ();
- for(e=eq; e; e=e->eq)
+ for (e = eq; e; e = e->eq)
{
if (e->module == NULL)
- e->module = gfc_get_string("%s.eq.%d", module_name, num);
- mio_allocated_string(e->module);
- mio_expr(&e->expr);
+ e->module = gfc_get_string ("%s.eq.%d", module_name, num);
+ mio_allocated_string (e->module);
+ mio_expr (&e->expr);
}
num++;
- mio_rparen();
+ mio_rparen ();
}
}
+
/* Write a symbol to the module. */
static void
-write_symbol (int n, gfc_symbol * sym)
+write_symbol (int n, gfc_symbol *sym)
{
+ const char *label;
if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
mio_pool_string (&sym->name);
mio_pool_string (&sym->module);
+ if (sym->attr.is_bind_c || sym->attr.is_iso_c)
+ {
+ label = sym->binding_label;
+ mio_pool_string (&label);
+ }
+ else
+ mio_pool_string (&sym->name);
+
mio_pointer_ref (&sym->ns);
mio_symbol (sym);
according to the access specification. */
static void
-write_symbol0 (gfc_symtree * st)
+write_symbol0 (gfc_symtree *st)
{
gfc_symbol *sym;
pointer_info *p;
write_symbol (p->integer, sym);
p->u.wsym.state = WRITTEN;
-
- return;
}
symbol was written and pass that information upwards. */
static int
-write_symbol1 (pointer_info * p)
+write_symbol1 (pointer_info *p)
{
if (p == NULL)
/* Write operator interfaces associated with a symbol. */
static void
-write_operator (gfc_user_op * uop)
+write_operator (gfc_user_op *uop)
{
static char nullstring[] = "";
const char *p = nullstring;
/* Write generic interfaces associated with a symbol. */
static void
-write_generic (gfc_symbol * sym)
+write_generic (gfc_symbol *sym)
{
+ const char *p;
+ int nuse, j;
if (sym->generic == NULL
|| !gfc_check_access (sym->attr.access, sym->ns->default_access))
return;
- mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
+ if (sym->module == NULL)
+ sym->module = gfc_get_string (module_name);
+
+ /* See how many use names there are. If none, use the symbol name. */
+ nuse = number_use_names (sym->name);
+ if (nuse == 0)
+ {
+ mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
+ return;
+ }
+
+ for (j = 1; j <= nuse; j++)
+ {
+ /* Get the jth local name for this symbol. */
+ p = find_use_name_n (sym->name, &j);
+
+ mio_symbol_interface (&p, &sym->module, &sym->generic);
+ }
}
static void
-write_symtree (gfc_symtree * st)
+write_symtree (gfc_symtree *st)
{
gfc_symbol *sym;
pointer_info *p;
write_char ('\n');
write_char ('\n');
- mio_lparen();
- write_equiv();
- mio_rparen();
- write_char('\n'); write_char('\n');
+ mio_lparen ();
+ write_equiv ();
+ 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.
}
+/* Read a MD5 sum from the header of a module file. If the file cannot
+ be opened, or we have any other error, we return -1. */
+
+static int
+read_md5_from_module_file (const char * filename, unsigned char md5[16])
+{
+ FILE *file;
+ char buf[1024];
+ int n;
+
+ /* Open the file. */
+ 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)
+ {
+ fclose (file);
+ return -1;
+ }
+
+ /* Close the file. */
+ fclose (file);
+
+ /* If the header is not what we expect, or is too short, bail out. */
+ if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
+ return -1;
+
+ /* Now, we have a real MD5, read it into the array. */
+ for (n = 0; n < 16; n++)
+ {
+ unsigned int x;
+
+ if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
+ return -1;
+
+ md5[n] = x;
+ }
+
+ return 0;
+}
+
+
/* Given module, dump it to disk. If there was an error while
processing the module, dump_flag will be set to zero and we delete
the module file, even if it was already there. */
gfc_dump_module (const char *name, int dump_flag)
{
int n;
- char *filename, *p;
+ char *filename, *filename_tmp, *p;
time_t now;
+ fpos_t md5_pos;
+ unsigned char md5_new[16], md5_old[16];
n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
if (gfc_option.module_dir != NULL)
{
- filename = (char *) alloca (n + strlen (gfc_option.module_dir));
+ n += strlen (gfc_option.module_dir);
+ filename = (char *) alloca (n);
strcpy (filename, gfc_option.module_dir);
strcat (filename, name);
}
}
strcat (filename, MODULE_EXTENSION);
+ /* Name of the temporary file used to write the module. */
+ filename_tmp = (char *) alloca (n + 1);
+ strcpy (filename_tmp, filename);
+ strcat (filename_tmp, "0");
+
+ /* There was an error while processing the module. We delete the
+ module file, even if it was already there. */
if (!dump_flag)
{
unlink (filename);
return;
}
- module_fp = fopen (filename, "w");
+ /* Write the module to the temporary file. */
+ module_fp = fopen (filename_tmp, "w");
if (module_fp == NULL)
gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
- filename, strerror (errno));
+ filename_tmp, strerror (errno));
+ /* Write the header, including space reserved for the MD5 sum. */
now = time (NULL);
p = ctime (&now);
*strchr (p, '\n') = '\0';
- fprintf (module_fp, "GFORTRAN module created from %s on %s\n",
+ fprintf (module_fp, "GFORTRAN module created from %s on %s\nMD5:",
gfc_source_file, p);
- fputs ("If you edit this, you'll get what you deserve.\n\n", module_fp);
+ fgetpos (module_fp, &md5_pos);
+ fputs ("00000000000000000000000000000000 -- "
+ "If you edit this, you'll get what you deserve.\n\n", module_fp);
+
+ /* Initialize the MD5 context that will be used for output. */
+ md5_init_ctx (&ctx);
+ /* Write the module itself. */
iomode = IO_OUTPUT;
strcpy (module_name, name);
write_char ('\n');
+ /* Write the MD5 sum to the header of the module file. */
+ md5_finish_ctx (&ctx, md5_new);
+ fsetpos (module_fp, &md5_pos);
+ for (n = 0; n < 16; n++)
+ fprintf (module_fp, "%02x", md5_new[n]);
+
if (fclose (module_fp))
gfc_fatal_error ("Error writing module file '%s' for writing: %s",
- filename, strerror (errno));
+ filename_tmp, strerror (errno));
+
+ /* Read the MD5 from the header of the old module file and compare. */
+ if (read_md5_from_module_file (filename, md5_old) != 0
+ || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
+ {
+ /* Module file have changed, replace the old one. */
+ unlink (filename);
+ rename (filename_tmp, filename);
+ }
+ else
+ unlink (filename_tmp);
+}
+
+
+static void
+sort_iso_c_rename_list (void)
+{
+ gfc_use_rename *tmp_list = NULL;
+ gfc_use_rename *curr;
+ gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
+ int c_kind;
+ int i;
+
+ for (curr = gfc_rename_list; curr; curr = curr->next)
+ {
+ c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
+ if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
+ {
+ gfc_error ("Symbol '%s' referenced at %L does not exist in "
+ "intrinsic module ISO_C_BINDING.", curr->use_name,
+ &curr->where);
+ }
+ else
+ /* Put it in the list. */
+ kinds_used[c_kind] = curr;
+ }
+
+ /* Make a new (sorted) rename list. */
+ i = 0;
+ while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
+ i++;
+
+ if (i < ISOCBINDING_NUMBER)
+ {
+ tmp_list = kinds_used[i];
+
+ i++;
+ curr = tmp_list;
+ for (; i < ISOCBINDING_NUMBER; i++)
+ if (kinds_used[i] != NULL)
+ {
+ curr->next = kinds_used[i];
+ curr = curr->next;
+ curr->next = NULL;
+ }
+ }
+
+ gfc_rename_list = tmp_list;
+}
+
+
+/* Import the intrinsic ISO_C_BINDING module, generating symbols in
+ the current namespace for all named constants, pointer types, and
+ procedures in the module unless the only clause was used or a rename
+ list was provided. */
+
+static void
+import_iso_c_binding_module (void)
+{
+ gfc_symbol *mod_sym = NULL;
+ gfc_symtree *mod_symtree = NULL;
+ const char *iso_c_module_name = "__iso_c_binding";
+ gfc_use_rename *u;
+ int i;
+ char *local_name;
+
+ /* Look only in the current namespace. */
+ mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
+
+ 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);
+
+ if (mod_symtree != NULL)
+ mod_sym = mod_symtree->n.sym;
+ else
+ gfc_internal_error ("import_iso_c_binding_module(): Unable to "
+ "create symbol for %s", iso_c_module_name);
+
+ mod_sym->attr.flavor = FL_MODULE;
+ mod_sym->attr.intrinsic = 1;
+ mod_sym->module = gfc_get_string (iso_c_module_name);
+ mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
+ }
+
+ /* Generate the symbols for the named constants representing
+ the kinds for intrinsic data types. */
+ if (only_flag)
+ {
+ /* Sort the rename list because there are dependencies between types
+ and procedures (e.g., c_loc needs c_ptr). */
+ sort_iso_c_rename_list ();
+
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ i = get_c_kind (u->use_name, c_interop_kinds_table);
+
+ if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
+ {
+ gfc_error ("Symbol '%s' referenced at %L does not exist in "
+ "intrinsic module ISO_C_BINDING.", u->use_name,
+ &u->where);
+ continue;
+ }
+
+ generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
+ }
+ }
+ else
+ {
+ for (i = 0; i < ISOCBINDING_NUMBER; i++)
+ {
+ local_name = NULL;
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
+ {
+ local_name = u->local_name;
+ u->found = 1;
+ break;
+ }
+ }
+ generate_isocbinding_symbol (iso_c_module_name, i, local_name);
+ }
+
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (u->found)
+ continue;
+
+ gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
+ "module ISO_C_BINDING", u->use_name, &u->where);
+ }
+ }
+}
+
+
+/* Add an integer named constant from a given module. */
+
+static void
+create_int_parameter (const char *name, int value, const char *modname,
+ intmod_id module, int id)
+{
+ gfc_symtree *tmp_symtree;
+ gfc_symbol *sym;
+
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (tmp_symtree != NULL)
+ {
+ if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+ return;
+ else
+ gfc_error ("Symbol '%s' already declared", name);
+ }
+
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
+ sym = tmp_symtree->n.sym;
+
+ sym->module = gfc_get_string (modname);
+ sym->attr.flavor = FL_PARAMETER;
+ sym->ts.type = BT_INTEGER;
+ sym->ts.kind = gfc_default_integer_kind;
+ sym->value = gfc_int_expr (value);
+ sym->attr.use_assoc = 1;
+ sym->from_intmod = module;
+ sym->intmod_sym_id = id;
+}
+
+
+/* USE the ISO_FORTRAN_ENV intrinsic module. */
+
+static void
+use_iso_fortran_env_module (void)
+{
+ static char mod[] = "iso_fortran_env";
+ const char *local_name;
+ gfc_use_rename *u;
+ gfc_symbol *mod_sym;
+ gfc_symtree *mod_symtree;
+ int i;
+
+ intmod_sym symbol[] = {
+#define NAMED_INTCST(a,b,c) { a, b, 0 },
+#include "iso-fortran-env.def"
+#undef NAMED_INTCST
+ { ISOFORTRANENV_INVALID, NULL, -1234 } };
+
+ i = 0;
+#define NAMED_INTCST(a,b,c) symbol[i++].value = c;
+#include "iso-fortran-env.def"
+#undef NAMED_INTCST
+
+ /* Generate the symbol for the module itself. */
+ 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);
+ gcc_assert (mod_symtree);
+ mod_sym = mod_symtree->n.sym;
+
+ mod_sym->attr.flavor = FL_MODULE;
+ mod_sym->attr.intrinsic = 1;
+ mod_sym->module = gfc_get_string (mod);
+ mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
+ }
+ else
+ if (!mod_symtree->n.sym->attr.intrinsic)
+ gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
+ "non-intrinsic module name used previously", mod);
+
+ /* Generate the symbols for the module integer named constants. */
+ if (only_flag)
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ for (i = 0; symbol[i].name; i++)
+ if (strcmp (symbol[i].name, u->use_name) == 0)
+ break;
+
+ if (symbol[i].name == NULL)
+ {
+ gfc_error ("Symbol '%s' referenced at %L does not exist in "
+ "intrinsic module ISO_FORTRAN_ENV", u->use_name,
+ &u->where);
+ continue;
+ }
+
+ if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
+ && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
+ gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
+ "from intrinsic module ISO_FORTRAN_ENV at %L is "
+ "incompatible with option %s", &u->where,
+ gfc_option.flag_default_integer
+ ? "-fdefault-integer-8" : "-fdefault-real-8");
+
+ create_int_parameter (u->local_name[0] ? u->local_name
+ : symbol[i].name,
+ symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
+ symbol[i].id);
+ }
+ else
+ {
+ for (i = 0; symbol[i].name; i++)
+ {
+ local_name = NULL;
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (strcmp (symbol[i].name, u->use_name) == 0)
+ {
+ local_name = u->local_name;
+ u->found = 1;
+ break;
+ }
+ }
+
+ if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
+ && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
+ gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
+ "from intrinsic module ISO_FORTRAN_ENV at %C is "
+ "incompatible with option %s",
+ gfc_option.flag_default_integer
+ ? "-fdefault-integer-8" : "-fdefault-real-8");
+
+ create_int_parameter (local_name ? local_name : symbol[i].name,
+ symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
+ symbol[i].id);
+ }
+
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (u->found)
+ continue;
+
+ gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
+ "module ISO_FORTRAN_ENV", u->use_name, &u->where);
+ }
+ }
}
{
char *filename;
gfc_state_data *p;
- int c, line;
+ int c, line, start;
+ gfc_symtree *mod_symtree;
- filename = (char *) alloca(strlen(module_name) + strlen(MODULE_EXTENSION)
- + 1);
+ filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
+ + 1);
strcpy (filename, module_name);
strcat (filename, MODULE_EXTENSION);
- module_fp = gfc_open_included_file (filename, true);
+ /* First, try to find an non-intrinsic module, unless the USE statement
+ specified that the module is intrinsic. */
+ module_fp = NULL;
+ if (!specified_int)
+ module_fp = gfc_open_included_file (filename, true, true);
+
+ /* Then, see if it's an intrinsic one, unless the USE statement
+ specified that the module is non-intrinsic. */
+ if (module_fp == NULL && !specified_nonint)
+ {
+ if (strcmp (module_name, "iso_fortran_env") == 0
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
+ "intrinsic module at %C") != FAILURE)
+ {
+ use_iso_fortran_env_module ();
+ return;
+ }
+
+ if (strcmp (module_name, "iso_c_binding") == 0
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
+ "ISO_C_BINDING module at %C") != FAILURE)
+ {
+ import_iso_c_binding_module();
+ return;
+ }
+
+ module_fp = gfc_open_intrinsic_module (filename);
+
+ if (module_fp == NULL && specified_int)
+ gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
+ module_name);
+ }
+
if (module_fp == NULL)
gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
filename, strerror (errno));
+ /* Check that we haven't already USEd an intrinsic module with the
+ same name. */
+
+ mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
+ if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
+ gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
+ "intrinsic module name used previously", module_name);
+
iomode = IO_INPUT;
module_line = 1;
module_column = 1;
+ start = 0;
- /* Skip the first two lines of the module. */
- /* FIXME: Could also check for valid two lines here, instead. */
+ /* Skip the first two lines of the module, after checking that this is
+ a gfortran module file. */
line = 0;
while (line < 2)
{
c = module_char ();
if (c == EOF)
bad_module ("Unexpected end of module");
+ if (start++ < 2)
+ 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 (c == '\n')
line++;
}
void
gfc_module_init_2 (void)
{
-
last_atom = ATOM_LPAREN;
}
void
gfc_module_done_2 (void)
{
-
free_rename ();
}
OSDN Git Service
