/* Handle modules, which amounts to loading and saving symbols and
their attendant structures.
- Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free
+ Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
-/* The syntax of g95 modules resembles that of lisp lists, ie a
+/* The syntax of gfortran modules resembles that of lisp lists, ie a
sequence of atoms, which can be left or right parenthesis, names,
integers or strings. Parenthesis are always matched which allows
us to skip over sections at high speed without having to know
( ( <name of generic interface> <module of generic interface> <i/f1> ... )
...
)
+ ( ( <common name> <symbol> <saved flag>)
+ ...
+ )
+
+ ( equivalence list )
+
( <Symbol Number (in no particular order)>
<True name of symbol>
<Module name of symbol>
particular order. */
#include "config.h"
-#include <string.h>
-#include <stdio.h>
-#include <errno.h>
-#include <unistd.h>
-#include <time.h>
-
+#include "system.h"
#include "gfortran.h"
+#include "arith.h"
#include "match.h"
#include "parse.h" /* FIXME */
#define MODULE_EXTENSION ".mod"
-/* Structure that descibes a position within a module file */
+/* Structure that describes a position within a module file. */
typedef struct
{
fixup_t;
-/* Structure for holding extra info needed for pointers being read */
+/* Structure for holding extra info needed for pointers being read. */
typedef struct pointer_info
{
pointer_t type;
/* The first component of each member of the union is the pointer
- being stored */
+ being stored. */
fixup_t *fixup;
union
{
- void *pointer; /* Member for doing pointer searches */
+ void *pointer; /* Member for doing pointer searches. */
struct
{
#define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
-/* Lists of rename info for the USE statement */
+/* Lists of rename info for the USE statement. */
typedef struct gfc_use_rename
{
/* 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. */
+static bool in_load_equiv;
+
/*****************************************************************/
static void
free_pi_tree (pointer_info * p)
{
-
if (p == NULL)
return;
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;
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;
{
/* Get a new rename struct and add it to the rename list. */
new = gfc_get_use_rename ();
- new->where = *gfc_current_locus ();
+ new->where = gfc_current_locus;
new->found = 0;
if (gfc_rename_list == NULL)
tail->next = new;
tail = new;
- /* See what kind of interface we're dealing with. Asusume it is
+ /* See what kind of interface we're dealing with. Assume it is
not an operator. */
new->operator = INTRINSIC_NONE;
if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
cleanup:
free_rename ();
return MATCH_ERROR;
-}
+ }
-/* Given a name, return the name under which to load this symbol.
- Returns NULL if this symbol shouldn't be loaded. */
+/* Given a name and a number, inst, return the inst name
+ under which to load this symbol. Returns NULL if this
+ symbol shouldn't be loaded. If inst is zero, returns
+ the number of instances of this name. */
static const char *
-find_use_name (const char *name)
+find_use_name_n (const char *name, int *inst)
{
gfc_use_rename *u;
+ int i;
+ i = 0;
for (u = gfc_rename_list; u; u = u->next)
- if (strcmp (u->use_name, name) == 0)
- break;
+ {
+ if (strcmp (u->use_name, name) != 0)
+ continue;
+ if (++i == *inst)
+ break;
+ }
+
+ if (!*inst)
+ {
+ *inst = i;
+ return NULL;
+ }
if (u == NULL)
return only_flag ? NULL : name;
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. */
+
+static const char *
+find_use_name (const char *name)
+{
+ int i = 1;
+ return find_use_name_n (name, &i);
+}
+
+/* Given a real name, return the number of use names associated
+ with it. */
+
+static int
+number_use_names (const char *name)
+{
+ int i = 0;
+ const char *c;
+ c = find_use_name_n (name, &i);
+ return i;
+}
+
/* Try to find the operator in the current list. */
t1 = (true_name *) _t1;
t2 = (true_name *) _t2;
- c = strcmp (t1->sym->module, t2->sym->module);
+ c = ((t1->sym->module > t2->sym->module)
+ - (t1->sym->module < t2->sym->module));
if (c != 0)
return c;
gfc_symbol sym;
int c;
- strcpy (sym.name, name);
- strcpy (sym.module, module);
+ sym.name = gfc_get_string (name);
+ if (module != NULL)
+ sym.module = gfc_get_string (module);
+ else
+ sym.module = NULL;
t.sym = &sym;
p = true_name_root;
static void bad_module (const char *) ATTRIBUTE_NORETURN;
static void
-bad_module (const char *message)
+bad_module (const char *msgid)
{
- const char *p;
+ fclose (module_fp);
switch (iomode)
{
case IO_INPUT:
- p = "Reading";
+ gfc_fatal_error ("Reading module %s at line %d column %d: %s",
+ module_name, module_line, module_column, msgid);
break;
case IO_OUTPUT:
- p = "Writing";
+ gfc_fatal_error ("Writing module %s at line %d column %d: %s",
+ module_name, module_line, module_column, msgid);
break;
default:
- p = "???";
+ gfc_fatal_error ("Module %s at line %d column %d: %s",
+ module_name, module_line, module_column, msgid);
break;
}
-
- fclose (module_fp);
-
- gfc_fatal_error ("%s module %s at line %d column %d: %s", p,
- module_name, module_line, module_column, message);
}
switch (type)
{
case ATOM_NAME:
- p = "Expected name";
+ p = _("Expected name");
break;
case ATOM_LPAREN:
- p = "Expected left parenthesis";
+ p = _("Expected left parenthesis");
break;
case ATOM_RPAREN:
- p = "Expected right parenthesis";
+ p = _("Expected right parenthesis");
break;
case ATOM_INTEGER:
- p = "Expected integer";
+ p = _("Expected integer");
break;
case ATOM_STRING:
- p = "Expected string";
+ p = _("Expected string");
break;
default:
gfc_internal_error ("require_atom(): bad atom type required");
return t;
}
-/* Specialisation of mio_name. */
+/* Specialization of mio_name. */
#define DECL_MIO_NAME(TYPE) \
static inline TYPE \
/* Read or write a character pointer that points to a string on the
heap. */
+static const char *
+mio_allocated_string (const char *s)
+{
+ if (iomode == IO_OUTPUT)
+ {
+ write_atom (ATOM_STRING, s);
+ return s;
+ }
+ else
+ {
+ require_atom (ATOM_STRING);
+ return atom_string;
+ }
+}
+
+
+/* Read or write a string that is in static memory. */
+
static void
-mio_allocated_string (char **sp)
+mio_pool_string (const char **stringp)
{
+ /* TODO: one could write the string only once, and refer to it via a
+ fixup pointer. */
+ /* As a special case we have to deal with a NULL string. This
+ happens for the 'module' member of 'gfc_symbol's that are not in a
+ module. We read / write these as the empty string. */
if (iomode == IO_OUTPUT)
- write_atom (ATOM_STRING, *sp);
+ {
+ const char *p = *stringp == NULL ? "" : *stringp;
+ write_atom (ATOM_STRING, p);
+ }
else
{
require_atom (ATOM_STRING);
- *sp = atom_string;
+ *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
+ gfc_free (atom_string);
}
}
-/* Read or write a string that is in static memory or inside of some
- already-allocated structure. */
+/* Read or write a string that is inside of some already-allocated
+ structure. */
static void
mio_internal_string (char *string)
typedef enum
{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
- AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_COMMON, AB_RESULT,
- AB_ENTRY, AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, AB_SAVED_COMMON,
- AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
- AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT
+ 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_ALLOC_COMP,
+ AB_VALUE, AB_VOLATILE
}
ab_attribute;
minit ("OPTIONAL", AB_OPTIONAL),
minit ("POINTER", AB_POINTER),
minit ("SAVE", AB_SAVE),
+ minit ("VALUE", AB_VALUE),
+ minit ("VOLATILE", AB_VOLATILE),
minit ("TARGET", AB_TARGET),
+ minit ("THREADPRIVATE", AB_THREADPRIVATE),
minit ("DUMMY", AB_DUMMY),
- minit ("COMMON", AB_COMMON),
minit ("RESULT", AB_RESULT),
- minit ("ENTRY", AB_ENTRY),
minit ("DATA", AB_DATA),
minit ("IN_NAMELIST", AB_IN_NAMELIST),
minit ("IN_COMMON", AB_IN_COMMON),
- minit ("SAVED_COMMON", AB_SAVED_COMMON),
minit ("FUNCTION", AB_FUNCTION),
minit ("SUBROUTINE", AB_SUBROUTINE),
minit ("SEQUENCE", AB_SEQUENCE),
minit ("RECURSIVE", AB_RECURSIVE),
minit ("GENERIC", AB_GENERIC),
minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
+ minit ("CRAY_POINTER", AB_CRAY_POINTER),
+ minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
+ minit ("ALLOC_COMP", AB_ALLOC_COMP),
minit (NULL, -1)
};
-/* Specialisation of mio_name. */
+/* Specialization of mio_name. */
DECL_MIO_NAME(ab_attribute)
DECL_MIO_NAME(ar_type)
DECL_MIO_NAME(array_type)
MIO_NAME(ab_attribute) (AB_POINTER, attr_bits);
if (attr->save)
MIO_NAME(ab_attribute) (AB_SAVE, 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);
+ if (attr->threadprivate)
+ MIO_NAME(ab_attribute) (AB_THREADPRIVATE, attr_bits);
if (attr->dummy)
MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits);
- if (attr->common)
- MIO_NAME(ab_attribute) (AB_COMMON, attr_bits);
if (attr->result)
MIO_NAME(ab_attribute) (AB_RESULT, attr_bits);
- if (attr->entry)
- MIO_NAME(ab_attribute) (AB_ENTRY, 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_IN_NAMELIST, attr_bits);
if (attr->in_common)
MIO_NAME(ab_attribute) (AB_IN_COMMON, attr_bits);
- if (attr->saved_common)
- MIO_NAME(ab_attribute) (AB_SAVED_COMMON, attr_bits);
if (attr->function)
MIO_NAME(ab_attribute) (AB_FUNCTION, attr_bits);
MIO_NAME(ab_attribute) (AB_RECURSIVE, attr_bits);
if (attr->always_explicit)
MIO_NAME(ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
+ if (attr->cray_pointer)
+ MIO_NAME(ab_attribute) (AB_CRAY_POINTER, attr_bits);
+ if (attr->cray_pointee)
+ MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
+ if (attr->alloc_comp)
+ MIO_NAME(ab_attribute) (AB_ALLOC_COMP, attr_bits);
mio_rparen ();
case AB_SAVE:
attr->save = 1;
break;
+ case AB_VALUE:
+ attr->value = 1;
+ break;
+ case AB_VOLATILE:
+ attr->volatile_ = 1;
+ break;
case AB_TARGET:
attr->target = 1;
break;
+ case AB_THREADPRIVATE:
+ attr->threadprivate = 1;
+ break;
case AB_DUMMY:
attr->dummy = 1;
break;
- case AB_COMMON:
- attr->common = 1;
- break;
case AB_RESULT:
attr->result = 1;
break;
- case AB_ENTRY:
- attr->entry = 1;
- break;
case AB_DATA:
attr->data = 1;
break;
case AB_IN_COMMON:
attr->in_common = 1;
break;
- case AB_SAVED_COMMON:
- attr->saved_common = 1;
- break;
case AB_FUNCTION:
attr->function = 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_ALLOC_COMP:
+ attr->alloc_comp = 1;
+ break;
}
}
}
gfc_ref structure), find the corresponding array specification
structure. Storing the pointer in the ref structure doesn't quite
work when loading from a module. Generating code for an array
- reference also needs more infomation than just the array spec. */
+ reference also needs more information than just the array spec. */
static const mstring array_ref_types[] = {
minit ("FULL", AR_FULL),
if (iomode == IO_INPUT)
{
- ar->where = *gfc_current_locus ();
+ ar->where = gfc_current_locus;
for (i = 0; i < ar->dimen; i++)
- ar->c_where[i] = *gfc_current_locus ();
+ ar->c_where[i] = gfc_current_locus;
}
mio_rparen ();
p->type = P_COMPONENT;
if (iomode == IO_OUTPUT)
- mio_internal_string ((*cp)->name);
+ mio_pool_string (&(*cp)->name);
else
{
mio_internal_string (name);
+ /* It can happen that a component reference can be read before the
+ associated derived type symbol has been loaded. Return now and
+ wait for a later iteration of load_needed. */
+ if (sym == NULL)
+ return;
+
if (sym->components != NULL && p->u.pointer == NULL)
{
/* Symbol already loaded, so search by name. */
if (p->type == P_UNKNOWN)
p->type = P_COMPONENT;
- mio_internal_string (c->name);
+ mio_pool_string (&c->name);
mio_typespec (&c->ts);
mio_array_spec (&c->as);
mio_integer (&c->dimension);
mio_integer (&c->pointer);
+ mio_integer (&c->allocatable);
mio_expr (&c->initializer);
mio_rparen ();
{
mio_lparen ();
- mio_internal_string (a->name);
+ mio_pool_string (&a->name);
mio_expr (&a->expr);
mio_rparen ();
}
{
pointer_info *p;
fixup_t *f;
+ gfc_symtree * ns_st = NULL;
if (iomode == IO_OUTPUT)
{
- mio_symbol_ref (&(*stp)->n.sym);
+ /* 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);
}
else
{
require_atom (ATOM_INTEGER);
p = get_integer (atom_int);
+
+ /* An unused equivalence member; bail out. */
+ if (in_load_equiv && p->u.rsym.symtree == NULL)
+ return;
+
if (p->type == P_UNKNOWN)
p->type = P_SYMBOL;
static void
-mio_gmp_real (mpf_t * real)
+mio_gmp_real (mpfr_t * real)
{
mp_exp_t exponent;
char *p;
if (parse_atom () != ATOM_STRING)
bad_module ("Expected real string");
- mpf_init (*real);
- mpf_set_str (*real, atom_string, -16);
+ mpfr_init (*real);
+ mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
gfc_free (atom_string);
}
else
{
- p = mpf_get_str (NULL, &exponent, 16, 0, *real);
+ p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
atom_string = gfc_getmem (strlen (p) + 20);
sprintf (atom_string, "0.%s@%ld", p, exponent);
+
+ /* Fix negative numbers. */
+ if (atom_string[2] == '-')
+ {
+ atom_string[0] = '-';
+ atom_string[1] = '0';
+ atom_string[2] = '.';
+ }
+
write_atom (ATOM_STRING, atom_string);
gfc_free (atom_string);
/* INTRINSIC_ASSIGN is missing because it is used as an index for
generic operators, not in expressions. INTRINSIC_USER is also
- replaced by the correct function name by the time we see it. */
+ replaced by the correct function name by the time we see it. */
static const mstring intrinsics[] =
{
minit ("LT", INTRINSIC_LT),
minit ("LE", INTRINSIC_LE),
minit ("NOT", INTRINSIC_NOT),
+ minit ("PARENTHESES", INTRINSIC_PARENTHESES),
minit (NULL, -1)
};
bad_module ("Expected expression type");
e = *ep = gfc_get_expr ();
- e->where = *gfc_current_locus ();
+ e->where = gfc_current_locus;
e->expr_type = (expr_t) find_enum (expr_types);
}
switch (e->expr_type)
{
case EXPR_OP:
- e->operator = MIO_NAME(gfc_intrinsic_op) (e->operator, intrinsics);
+ e->value.op.operator
+ = MIO_NAME(gfc_intrinsic_op) (e->value.op.operator, intrinsics);
- switch (e->operator)
+ switch (e->value.op.operator)
{
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
case INTRINSIC_NOT:
- mio_expr (&e->op1);
+ case INTRINSIC_PARENTHESES:
+ mio_expr (&e->value.op.op1);
break;
case INTRINSIC_PLUS:
case INTRINSIC_GE:
case INTRINSIC_LT:
case INTRINSIC_LE:
- mio_expr (&e->op1);
- mio_expr (&e->op2);
+ mio_expr (&e->value.op.op1);
+ mio_expr (&e->value.op.op2);
break;
default:
if (iomode == IO_OUTPUT)
{
- mio_allocated_string (&e->value.function.name);
+ e->value.function.name
+ = mio_allocated_string (e->value.function.name);
flag = e->value.function.esym != NULL;
mio_integer (&flag);
if (flag)
break;
case EXPR_SUBSTRING:
- mio_allocated_string (&e->value.character.string);
- mio_expr (&e->op1);
- mio_expr (&e->op2);
+ e->value.character.string = (char *)
+ mio_allocated_string (e->value.character.string);
+ mio_ref_list (&e->ref);
break;
case EXPR_STRUCTURE:
break;
case BT_REAL:
+ gfc_set_model_kind (e->ts.kind);
mio_gmp_real (&e->value.real);
break;
case BT_COMPLEX:
+ 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);
- 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 */
+
+static void
+mio_namelist (gfc_symbol * sym)
+{
+ gfc_namelist *n, *m;
+ const char *check_name;
+
+ mio_lparen ();
+
+ if (iomode == IO_OUTPUT)
+ {
+ for (n = sym->namelist; n; n = n->next)
+ mio_symbol_ref (&n->sym);
+ }
+ else
+ {
+ /* This departure from the standard is flagged as an error.
+ It does, in fact, work correctly. TODO: Allow it
+ conditionally? */
+ if (sym->attr.flavor == FL_NAMELIST)
+ {
+ 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);
+ }
+
+ m = NULL;
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ n = gfc_get_namelist ();
+ mio_symbol_ref (&n->sym);
+
+ if (sym->namelist == NULL)
+ sym->namelist = n;
+ else
+ m->next = n;
+
+ m = n;
+ }
+ sym->namelist_tail = m;
+ }
+
+ mio_rparen ();
+}
+
+
/* Save/restore lists of gfc_interface stuctures. When loading an
interface, we are really appending to the existing list of
interfaces. Checking for duplicate and ambiguous interfaces has to
break;
p = gfc_get_interface ();
+ p->where = gfc_current_locus;
mio_symbol_ref (&p->sym);
if (tail == NULL)
/* Save/restore a named operator interface. */
static void
-mio_symbol_interface (char *name, char *module,
+mio_symbol_interface (const char **name, const char **module,
gfc_interface ** ip)
{
mio_lparen ();
- mio_internal_string (name);
- mio_internal_string (module);
+ mio_pool_string (name);
+ mio_pool_string (module);
mio_interface_rest (ip);
}
if (p->type == P_UNKNOWN)
p->type = P_NAMESPACE;
- if (iomode == IO_INPUT && p->integer != 0 && p->u.pointer == NULL)
+ if (iomode == IO_INPUT && p->integer != 0)
{
- ns = gfc_get_namespace (NULL);
- associate_integer_pointer (p, ns);
+ ns = (gfc_namespace *)p->u.pointer;
+ if (ns == NULL)
+ {
+ ns = gfc_get_namespace (NULL, 0);
+ associate_integer_pointer (p, ns);
+ }
+ else
+ ns->refs++;
}
}
}
/* Save/restore common block links */
- mio_symbol_ref (&sym->common_head);
mio_symbol_ref (&sym->common_next);
mio_formal_arglist (sym);
- mio_expr (&sym->value);
+ if (sym->attr.flavor == FL_PARAMETER)
+ mio_expr (&sym->value);
+
mio_array_spec (&sym->as);
mio_symbol_ref (&sym->result);
+ if (sym->attr.cray_pointee)
+ mio_symbol_ref (&sym->cp_pointer);
+
/* Note that components are always saved, even if they are supposed
to be private. Component access is checked during searching. */
sym->component_access =
MIO_NAME(gfc_access) (sym->component_access, access_types);
- mio_symbol_ref (&sym->common_head);
- mio_symbol_ref (&sym->common_next);
-
+ mio_namelist (sym);
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;
+ }
+ 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)
+{
+ char name[GFC_MAX_SYMBOL_LEN+1];
+ gfc_common_head *p;
+
+ mio_lparen ();
+
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ int flags;
+ mio_lparen ();
+ mio_internal_string (name);
+
+ p = gfc_get_common (name, 1);
+
+ mio_symbol_ref (&p->head);
+ mio_integer (&flags);
+ if (flags & 1)
+ p->saved = 1;
+ if (flags & 2)
+ p->threadprivate = 1;
+ p->use_assoc = 1;
+
+ 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.*/
+
+static void
+load_equiv(void)
+{
+ gfc_equiv *head, *tail, *end, *eq;
+ bool unused;
+
+ mio_lparen();
+ in_load_equiv = true;
+
+ end = gfc_current_ns->equiv;
+ while(end != NULL && end->next != NULL)
+ end = end->next;
+
+ while(peek_atom() != ATOM_RPAREN) {
+ mio_lparen();
+ head = tail = NULL;
+
+ while(peek_atom() != ATOM_RPAREN)
+ {
+ if (head == NULL)
+ head = tail = gfc_get_equiv();
+ else
+ {
+ tail->eq = gfc_get_equiv();
+ tail = tail->eq;
+ }
+
+ mio_pool_string(&tail->module);
+ mio_expr(&tail->expr);
+ }
+
+ /* Unused variables have no symtree. */
+ unused = false;
+ for (eq = head; eq; eq = eq->eq)
+ {
+ if (!eq->expr->symtree)
+ {
+ unused = true;
+ break;
+ }
+ }
+
+ if (unused)
+ {
+ for (eq = head; eq; eq = head)
+ {
+ head = eq->eq;
+ gfc_free_expr (eq->expr);
+ gfc_free (eq);
+ }
+ }
+
+ if (end == NULL)
+ gfc_current_ns->equiv = head;
+ else
+ end->next = head;
+
+ if (head != NULL)
+ end = head;
+
+ 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. */
gfc_namespace *ns;
pointer_info *q;
gfc_symbol *sym;
+ int rv;
+ rv = 0;
if (p == NULL)
- return 0;
- if (load_needed (p->left))
- return 1;
- if (load_needed (p->right))
- return 1;
+ return rv;
+
+ rv |= load_needed (p->left);
+ rv |= load_needed (p->right);
if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
- return 0;
+ return rv;
p->u.rsym.state = USED;
the namespaces that hold the formal parameters of module
procedures. */
- ns = gfc_get_namespace (NULL);
+ ns = gfc_get_namespace (NULL, 0);
associate_integer_pointer (q, ns);
}
sym = gfc_new_symbol (p->u.rsym.true_name, ns);
- strcpy (sym->module, p->u.rsym.module);
+ sym->module = gfc_get_string (p->u.rsym.module);
associate_integer_pointer (p, sym);
}
const char *p;
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_intrinsic_op i;
- int ambiguous, symbol;
+ int ambiguous, j, nuse, symbol;
pointer_info *info;
gfc_use_rename *u;
gfc_symtree *st;
skip_list ();
skip_list ();
+ /* Skip commons and equivalences for now. */
+ skip_list ();
+ skip_list ();
+
mio_lparen ();
/* Create the fixup nodes for all the symbols. */
skip_list ();
/* See if the symbol has already been loaded by a previous module.
- If so, we reference the existing symbol and prevent it from
- being loaded again. */
+ If so, we reference the existing symbol and prevent it from
+ being loaded again. This should not happen if the symbol being
+ read is an index for an assumed shape dummy array (ns != 1). */
sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
- if (sym == NULL)
+
+ if (sym == NULL
+ || (sym->attr.flavor == FL_VARIABLE
+ && info->u.rsym.ns !=1))
continue;
info->u.rsym.state = USED;
info = get_integer (symbol);
- /* Get the local name for this symbol. */
- p = find_use_name (name);
-
- /* Skip symtree nodes not in an ONLY caluse. */
- if (p == NULL)
- continue;
-
- /* Check for ambiguous symbols. */
- st = gfc_find_symtree (gfc_current_ns->sym_root, p);
+ /* See how many use names there are. If none, go through the start
+ of the loop at least once. */
+ nuse = number_use_names (name);
+ if (nuse == 0)
+ nuse = 1;
- if (st != NULL)
+ for (j = 1; j <= nuse; j++)
{
- 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);
+ /* Get the jth local name for this symbol. */
+ p = find_use_name_n (name, &j);
- st->ambiguous = ambiguous;
+ /* Skip symtree nodes not in an ONLY clause. */
+ if (p == NULL)
+ continue;
- sym = info->u.rsym.sym;
+ /* Check for ambiguous symbols. */
+ st = gfc_find_symtree (gfc_current_ns->sym_root, p);
- /* Create a symbol node if it doesn't already exist. */
- if (sym == NULL)
+ if (st != NULL)
{
- sym = info->u.rsym.sym =
- gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns);
-
- strcpy (sym->module, info->u.rsym.module);
+ 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);
+
+ st->ambiguous = ambiguous;
+
+ sym = info->u.rsym.sym;
+
+ /* 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);
+
+ sym->module = gfc_get_string (info->u.rsym.module);
+ }
- st->n.sym = sym;
- st->n.sym->refs++;
+ st->n.sym = sym;
+ st->n.sym->refs++;
- /* Store the symtree pointing to this symbol. */
- info->u.rsym.symtree = st;
+ /* Store the symtree pointing to this symbol. */
+ info->u.rsym.symtree = st;
- if (info->u.rsym.state == UNUSED)
- info->u.rsym.state = NEEDED;
- info->u.rsym.referenced = 1;
+ if (info->u.rsym.state == UNUSED)
+ info->u.rsym.state = NEEDED;
+ info->u.rsym.referenced = 1;
+ }
}
}
load_operator_interfaces ();
load_generic_interfaces ();
+ load_commons ();
+ 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
marked as NEEDED if its previous state was UNUSED. */
/* Given an access type that is specific to an entity and the default
- access, return nonzero if we should write the entity. */
+ 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. */
-static int
-check_access (gfc_access specific_access, gfc_access default_access)
+bool
+gfc_check_access (gfc_access specific_access, gfc_access default_access)
{
if (specific_access == ACCESS_PUBLIC)
- return 1;
+ return TRUE;
if (specific_access == ACCESS_PRIVATE)
- return 0;
+ return FALSE;
- if (gfc_option.flag_module_access_private)
- {
- if (default_access == ACCESS_PUBLIC)
- return 1;
- }
- else
- {
- if (default_access != ACCESS_PRIVATE)
- return 1;
- }
+ return default_access != ACCESS_PRIVATE;
+}
- return 0;
+
+/* Write a common block to the module */
+
+static void
+write_common (gfc_symtree *st)
+{
+ gfc_common_head *p;
+ const char * name;
+ int flags;
+
+ if (st == NULL)
+ return;
+
+ write_common(st->left);
+ write_common(st->right);
+
+ mio_lparen();
+
+ /* Write the unmangled name. */
+ name = st->n.common->name;
+
+ mio_pool_string(&name);
+
+ p = st->n.common;
+ mio_symbol_ref(&p->head);
+ flags = p->saved ? 1 : 0;
+ if (p->threadprivate) flags |= 2;
+ mio_integer(&flags);
+
+ mio_rparen();
}
+/* Write the blank common block to the module */
+
+static void
+write_blank_common (void)
+{
+ const char * name = BLANK_COMMON_NAME;
+ int saved;
+
+ if (gfc_current_ns->blank_common.head == NULL)
+ return;
+
+ mio_lparen();
+
+ mio_pool_string(&name);
+
+ mio_symbol_ref(&gfc_current_ns->blank_common.head);
+ saved = gfc_current_ns->blank_common.saved;
+ mio_integer(&saved);
+
+ mio_rparen();
+}
+
+/* Write equivalences to the module. */
+
+static void
+write_equiv(void)
+{
+ gfc_equiv *eq, *e;
+ int num;
+
+ num = 0;
+ for(eq=gfc_current_ns->equiv; eq; eq=eq->next)
+ {
+ mio_lparen();
+
+ 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);
+ }
+
+ num++;
+ mio_rparen();
+ }
+}
/* Write a symbol to the module. */
gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
mio_integer (&n);
- mio_internal_string (sym->name);
-
- if (sym->module[0] == '\0')
- strcpy (sym->module, module_name);
+ mio_pool_string (&sym->name);
- mio_internal_string (sym->module);
+ mio_pool_string (&sym->module);
mio_pointer_ref (&sym->ns);
mio_symbol (sym);
write_symbol0 (st->right);
sym = st->n.sym;
+ if (sym->module == NULL)
+ sym->module = gfc_get_string (module_name);
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
&& !sym->attr.subroutine && !sym->attr.function)
return;
- if (!check_access (sym->attr.access, sym->ns->default_access))
+ if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
return;
p = get_pointer (sym);
write_operator (gfc_user_op * uop)
{
static char nullstring[] = "";
+ const char *p = nullstring;
if (uop->operator == NULL
- || !check_access (uop->access, uop->ns->default_access))
+ || !gfc_check_access (uop->access, uop->ns->default_access))
return;
- mio_symbol_interface (uop->name, nullstring, &uop->operator);
+ mio_symbol_interface (&uop->name, &p, &uop->operator);
}
{
if (sym->generic == NULL
- || !check_access (sym->attr.access, sym->ns->default_access))
+ || !gfc_check_access (sym->attr.access, sym->ns->default_access))
return;
- mio_symbol_interface (sym->name, sym->module, &sym->generic);
+ mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
}
pointer_info *p;
sym = st->n.sym;
- if (!check_access (sym->attr.access, sym->ns->default_access)
+ 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))
return;
if (p == NULL)
gfc_internal_error ("write_symtree(): Symbol not written");
- mio_internal_string (st->name);
+ mio_pool_string (&st->name);
mio_integer (&st->ambiguous);
mio_integer (&p->integer);
}
if (i == INTRINSIC_USER)
continue;
- mio_interface (check_access (gfc_current_ns->operator_access[i],
- gfc_current_ns->default_access)
+ mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
+ gfc_current_ns->default_access)
? &gfc_current_ns->operator[i] : NULL);
}
write_char ('\n');
write_char ('\n');
+ mio_lparen ();
+ write_blank_common ();
+ write_common (gfc_current_ns->common_root);
+ 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.
Sometimes writing one symbol will cause another to need to be
write_char ('\n');
mio_lparen ();
- gfc_traverse_symtree (gfc_current_ns, write_symtree);
+ gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
mio_rparen ();
}
void
gfc_dump_module (const char *name, int dump_flag)
{
- char filename[PATH_MAX], *p;
+ int n;
+ char *filename, *p;
time_t now;
- filename[0] = '\0';
+ n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
if (gfc_option.module_dir != NULL)
- strcpy (filename, gfc_option.module_dir);
-
- strcat (filename, name);
+ {
+ filename = (char *) alloca (n + strlen (gfc_option.module_dir));
+ strcpy (filename, gfc_option.module_dir);
+ strcat (filename, name);
+ }
+ else
+ {
+ filename = (char *) alloca (n);
+ strcpy (filename, name);
+ }
strcat (filename, MODULE_EXTENSION);
if (!dump_flag)
module_fp = fopen (filename, "w");
if (module_fp == NULL)
- gfc_fatal_error ("Can't open module file '%s' for writing: %s",
+ gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
filename, strerror (errno));
now = time (NULL);
}
+/* Add an integer named constant from a given module. */
+static void
+create_int_parameter (const char *name, int value, const char *modname)
+{
+ 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;
+}
+
+/* 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;
+
+ mstring symbol[] = {
+#define NAMED_INTCST(a,b,c) minit(b,0),
+#include "iso-fortran-env.def"
+#undef NAMED_INTCST
+ minit (NULL, -1234) };
+
+ i = 0;
+#define NAMED_INTCST(a,b,c) symbol[i++].tag = 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);
+ }
+ 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].string; i++)
+ if (strcmp (symbol[i].string, u->use_name) == 0)
+ break;
+
+ if (symbol[i].string == 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)
+ && strcmp (symbol[i].string, "numeric_storage_size") == 0)
+ 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].string,
+ symbol[i].tag, mod);
+ }
+ else
+ {
+ for (i = 0; symbol[i].string; i++)
+ {
+ local_name = NULL;
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (strcmp (symbol[i].string, u->use_name) == 0)
+ {
+ local_name = u->local_name;
+ u->found = 1;
+ break;
+ }
+ }
+
+ if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
+ && strcmp (symbol[i].string, "numeric_storage_size") == 0)
+ 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].string,
+ symbol[i].tag, mod);
+ }
+
+ 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);
+ }
+ }
+}
+
/* Process a USE directive. */
void
gfc_use_module (void)
{
- char filename[GFC_MAX_SYMBOL_LEN + 5];
+ 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);
strcpy (filename, module_name);
strcat (filename, MODULE_EXTENSION);
- module_fp = gfc_open_included_file (filename);
+ /* 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;
+ }
+
+ 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: %s",
+ 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++;
}
OSDN Git Service
