/* Handle modules, which amounts to loading and saving symbols and
their attendant structures.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010, 2011
+ 2009, 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "md5.h"
#include "constructor.h"
#include "cpp.h"
+#include "tree.h"
#define MODULE_EXTENSION ".mod"
/* Don't put any single quote (') in MOD_VERSION,
if yout want it to be recognized. */
-#define MOD_VERSION "6"
+#define MOD_VERSION "9"
/* Structure that describes a position within a module file. */
struct
{
gfc_symbol *sym;
- char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
+ char *true_name, *module, *binding_label;
+ fixup_t *stfixup;
+ gfc_symtree *symtree;
enum gfc_rsym_state state;
int ns, referenced, renamed;
module_locus where;
- fixup_t *stfixup;
- gfc_symtree *symtree;
- char binding_label[GFC_MAX_SYMBOL_LEN + 1];
}
rsym;
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 const char *module_name;
+static gfc_use_list *module_list;
static int module_line, module_column, only_flag;
+static int prev_module_line, prev_module_column, prev_character;
+
static enum
{ IO_INPUT, IO_OUTPUT }
iomode;
/* Tells mio_expr_ref to make symbols for unused equivalence members. */
static bool in_load_equiv;
-static locus use_locus;
-
/*****************************************************************/
free_pi_tree (p->left);
free_pi_tree (p->right);
- gfc_free (p);
+ if (iomode == IO_INPUT)
+ {
+ XDELETEVEC (p->u.rsym.true_name);
+ XDELETEVEC (p->u.rsym.module);
+ XDELETEVEC (p->u.rsym.binding_label);
+ }
+
+ free (p);
}
}
-/* Recursive function to find a pointer within a tree by brute force. */
-
-static pointer_info *
-fp2 (pointer_info *p, const void *target)
-{
- pointer_info *q;
-
- if (p == NULL)
- return NULL;
-
- if (p->u.pointer == target)
- return p;
-
- q = fp2 (p->left, target);
- if (q != NULL)
- return q;
-
- return fp2 (p->right, target);
-}
-
-
-/* During reading, find a pointer_info node from the pointer value.
- This amounts to a brute-force search. */
-
-static pointer_info *
-find_pointer2 (void *p)
-{
- return fp2 (pi_root, p);
-}
-
-
/* Resolve any fixups using a known pointer. */
static void
{
next = f->next;
*(f->pointer) = gp;
- gfc_free (f);
+ free (f);
}
}
+/* Convert a string such that it starts with a lower-case character. Used
+ to convert the symtree name of a derived-type to the symbol name or to
+ the name of the associated generic function. */
+
+static const char *
+dt_lower_string (const char *name)
+{
+ if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
+ return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
+ &name[1]);
+ return gfc_get_string (name);
+}
+
+
+/* Convert a string such that it starts with an upper-case character. Used to
+ return the symtree-name for a derived type; the symbol name itself and the
+ symtree/symbol name of the associated generic function start with a lower-
+ case character. */
+
+static const char *
+dt_upper_string (const char *name)
+{
+ if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
+ return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
+ &name[1]);
+ return gfc_get_string (name);
+}
+
/* Call here during module reading when we know what pointer to
associate with an integer. Any fixups that exist are resolved at
this time. */
/* Free the rename list left behind by a USE statement. */
static void
-free_rename (void)
+free_rename (gfc_use_rename *list)
{
gfc_use_rename *next;
- for (; gfc_rename_list; gfc_rename_list = next)
+ for (; list; list = next)
{
- next = gfc_rename_list->next;
- gfc_free (gfc_rename_list);
+ next = list->next;
+ free (list);
}
}
interface_type type, type2;
gfc_intrinsic_op op;
match m;
-
- specified_int = false;
- specified_nonint = false;
-
+ gfc_use_list *use_list;
+
+ use_list = gfc_get_use_list ();
+
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;
+ goto cleanup;
if (strcmp (module_nature, "intrinsic") == 0)
- specified_int = true;
+ use_list->intrinsic = true;
else
{
if (strcmp (module_nature, "non_intrinsic") == 0)
- specified_nonint = true;
+ use_list->non_intrinsic = true;
else
{
gfc_error ("Module nature in USE statement at %C shall "
"be either INTRINSIC or NON_INTRINSIC");
- return MATCH_ERROR;
+ goto cleanup;
}
}
}
|| strcmp (module_nature, "non_intrinsic") == 0)
gfc_error ("\"::\" was expected after module nature at %C "
"but was not found");
+ free (use_list);
return m;
}
}
if (m == MATCH_YES &&
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
"\"USE :: module\" at %C") == FAILURE)
- return MATCH_ERROR;
+ goto cleanup;
if (m != MATCH_YES)
{
m = gfc_match ("% ");
if (m != MATCH_YES)
- return m;
+ {
+ free (use_list);
+ return m;
+ }
}
}
- use_locus = gfc_current_locus;
+ use_list->where = gfc_current_locus;
- m = gfc_match_name (module_name);
+ m = gfc_match_name (name);
if (m != MATCH_YES)
- return m;
+ {
+ free (use_list);
+ return m;
+ }
- free_rename ();
- only_flag = 0;
+ use_list->module_name = gfc_get_string (name);
if (gfc_match_eos () == MATCH_YES)
- return MATCH_YES;
+ goto done;
+
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
if (gfc_match (" only :") == MATCH_YES)
- only_flag = 1;
+ use_list->only_flag = true;
if (gfc_match_eos () == MATCH_YES)
- return MATCH_YES;
+ goto done;
for (;;)
{
new_use->where = gfc_current_locus;
new_use->found = 0;
- if (gfc_rename_list == NULL)
- gfc_rename_list = new_use;
+ if (use_list->rename == NULL)
+ use_list->rename = new_use;
else
tail->next = new_use;
tail = new_use;
if (type == INTERFACE_USER_OP)
new_use->op = INTRINSIC_USER;
- if (only_flag)
+ if (use_list->only_flag)
{
if (m != MATCH_YES)
strcpy (new_use->use_name, name);
goto cleanup;
}
- if (strcmp (new_use->use_name, module_name) == 0
- || strcmp (new_use->local_name, module_name) == 0)
+ if (strcmp (new_use->use_name, use_list->module_name) == 0
+ || strcmp (new_use->local_name, use_list->module_name) == 0)
{
gfc_error ("The name '%s' at %C has already been used as "
- "an external module name.", module_name);
+ "an external module name.", use_list->module_name);
goto cleanup;
}
break;
goto syntax;
}
+done:
+ if (module_list)
+ {
+ gfc_use_list *last = module_list;
+ while (last->next)
+ last = last->next;
+ last->next = use_list;
+ }
+ else
+ module_list = use_list;
+
return MATCH_YES;
syntax:
gfc_syntax_error (ST_USE);
cleanup:
- free_rename ();
+ free_rename (use_list->rename);
+ free (use_list);
return MATCH_ERROR;
- }
+}
/* Given a name and a number, inst, return the inst name
find_use_name_n (const char *name, int *inst, bool interface)
{
gfc_use_rename *u;
+ const char *low_name = NULL;
int i;
+ /* For derived types. */
+ if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
+ low_name = dt_lower_string (name);
+
i = 0;
for (u = gfc_rename_list; u; u = u->next)
{
- if (strcmp (u->use_name, name) != 0
+ if ((!low_name && strcmp (u->use_name, name) != 0)
+ || (low_name && strcmp (u->use_name, low_name) != 0)
|| (u->op == INTRINSIC_USER && !interface)
|| (u->op != INTRINSIC_USER && interface))
continue;
u->found = 1;
+ if (low_name)
+ {
+ if (u->local_name[0] == '\0')
+ return name;
+ return dt_upper_string (u->local_name);
+ }
+
return (u->local_name[0] != '\0') ? u->local_name : name;
}
typedef struct true_name
{
BBT_HEADER (true_name);
+ const char *name;
gfc_symbol *sym;
}
true_name;
if (c != 0)
return c;
- return strcmp (t1->sym->name, t2->sym->name);
+ return strcmp (t1->name, t2->name);
}
gfc_symbol sym;
int c;
- sym.name = gfc_get_string (name);
+ t.name = gfc_get_string (name);
if (module != NULL)
sym.module = gfc_get_string (module);
else
t = XCNEW (true_name);
t->sym = sym;
+ if (sym->attr.flavor == FL_DERIVED)
+ t->name = dt_upper_string (sym->name);
+ else
+ t->name = sym->name;
gfc_insert_bbt (&true_name_root, t, compare_true_names);
}
static void
build_tnt (gfc_symtree *st)
{
+ const char *name;
if (st == NULL)
return;
build_tnt (st->left);
build_tnt (st->right);
- if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
+ if (st->n.sym->attr.flavor == FL_DERIVED)
+ name = dt_upper_string (st->n.sym->name);
+ else
+ name = st->n.sym->name;
+
+ if (find_true_name (name, st->n.sym->module) != NULL)
return;
add_true_name (st->n.sym);
free_true_name (t->left);
free_true_name (t->right);
- gfc_free (t);
+ free (t);
}
if (c == EOF)
bad_module ("Unexpected EOF");
+ prev_module_line = module_line;
+ prev_module_column = module_column;
+ prev_character = c;
+
if (c == '\n')
{
module_line++;
return c;
}
+/* Unget a character while remembering the line and column. Works for
+ a single character only. */
+
+static void
+module_unget_char (void)
+{
+ module_line = prev_module_line;
+ module_column = prev_module_column;
+ ungetc (prev_character, module_fp);
+}
/* Parse a string constant. The delimiter is guaranteed to be a
single quote. */
static void
parse_string (void)
{
- module_locus start;
- int len, c;
- char *p;
-
- get_module_locus (&start);
+ int c;
+ size_t cursz = 30;
+ size_t len = 0;
- len = 0;
+ atom_string = XNEWVEC (char, cursz);
- /* See how long the string is. */
for ( ; ; )
{
c = module_char ();
- if (c == EOF)
- bad_module ("Unexpected end of module in string constant");
- if (c != '\'')
+ if (c == '\'')
{
- len++;
- continue;
+ int c2 = module_char ();
+ if (c2 != '\'')
+ {
+ module_unget_char ();
+ break;
+ }
}
- c = module_char ();
- if (c == '\'')
+ if (len >= cursz)
{
- len++;
- continue;
+ cursz *= 2;
+ atom_string = XRESIZEVEC (char, atom_string, cursz);
}
-
- break;
- }
-
- set_module_locus (&start);
-
- atom_string = p = XCNEWVEC (char, len + 1);
-
- for (; len > 0; len--)
- {
- c = module_char ();
- if (c == '\'')
- module_char (); /* Guaranteed to be another \'. */
- *p++ = c;
+ atom_string[len] = c;
+ len++;
}
- module_char (); /* Terminating \'. */
- *p = '\0'; /* C-style string for debug purposes. */
+ atom_string = XRESIZEVEC (char, atom_string, len + 1);
+ atom_string[len] = '\0'; /* C-style string for debug purposes. */
}
static void
parse_integer (int c)
{
- module_locus m;
-
atom_int = c - '0';
for (;;)
{
- get_module_locus (&m);
-
c = module_char ();
if (!ISDIGIT (c))
- break;
+ {
+ module_unget_char ();
+ break;
+ }
atom_int = 10 * atom_int + c - '0';
if (atom_int > 99999999)
bad_module ("Integer overflow");
}
- set_module_locus (&m);
}
static void
parse_name (int c)
{
- module_locus m;
char *p;
int len;
*p++ = c;
len = 1;
- get_module_locus (&m);
-
for (;;)
{
c = module_char ();
if (!ISALNUM (c) && c != '_' && c != '-')
- break;
+ {
+ module_unget_char ();
+ break;
+ }
*p++ = c;
if (++len > GFC_MAX_SYMBOL_LEN)
*p = '\0';
- fseek (module_fp, -1, SEEK_CUR);
- module_column = m.column + len - 1;
-
- if (c == '\n')
- module_line--;
}
static atom_type
peek_atom (void)
{
- module_locus m;
- atom_type a;
+ int c;
+
+ do
+ {
+ c = module_char ();
+ }
+ while (c == ' ' || c == '\r' || c == '\n');
- get_module_locus (&m);
+ switch (c)
+ {
+ case '(':
+ module_unget_char ();
+ return ATOM_LPAREN;
+
+ case ')':
+ module_unget_char ();
+ return ATOM_RPAREN;
+
+ case '\'':
+ module_unget_char ();
+ return ATOM_STRING;
+
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ module_unget_char ();
+ return ATOM_INTEGER;
- a = parse_atom ();
- if (a == ATOM_STRING)
- gfc_free (atom_string);
+ case 'a':
+ case 'b':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
+ case 'h':
+ case 'i':
+ case 'j':
+ case 'k':
+ case 'l':
+ case 'm':
+ case 'n':
+ case 'o':
+ case 'p':
+ case 'q':
+ case 'r':
+ case 's':
+ case 't':
+ case 'u':
+ case 'v':
+ case 'w':
+ case 'x':
+ case 'y':
+ case 'z':
+ case 'A':
+ case 'B':
+ case 'C':
+ case 'D':
+ case 'E':
+ case 'F':
+ case 'G':
+ case 'H':
+ case 'I':
+ case 'J':
+ case 'K':
+ case 'L':
+ case 'M':
+ case 'N':
+ case 'O':
+ case 'P':
+ case 'Q':
+ case 'R':
+ case 'S':
+ case 'T':
+ case 'U':
+ case 'V':
+ case 'W':
+ case 'X':
+ case 'Y':
+ case 'Z':
+ module_unget_char ();
+ return ATOM_NAME;
- set_module_locus (&m);
- return a;
+ default:
+ bad_module ("Bad name");
+ }
}
static void
require_atom (atom_type type)
{
- module_locus m;
atom_type t;
const char *p;
+ int column, line;
- get_module_locus (&m);
+ column = module_column;
+ line = module_line;
t = parse_atom ();
if (t != type)
gfc_internal_error ("require_atom(): bad atom type required");
}
- set_module_locus (&m);
+ module_column = column;
+ module_line = line;
bad_module (p);
}
}
}
+/* Read a string. The caller is responsible for freeing. */
+
+static char*
+read_string (void)
+{
+ char* p;
+ require_atom (ATOM_STRING);
+ p = atom_string;
+ atom_string = NULL;
+ return p;
+}
+
+
/**************** Module output subroutines ***************************/
/* Output a character to a module file. */
{
char *quoted = quote_string (s, length);
write_atom (ATOM_STRING, quoted);
- gfc_free (quoted);
+ free (quoted);
return s;
}
else
require_atom (ATOM_STRING);
unquoted = unquote_string (atom_string);
- gfc_free (atom_string);
+ free (atom_string);
return unquoted;
}
}
{
require_atom (ATOM_STRING);
*stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
- gfc_free (atom_string);
+ free (atom_string);
}
}
{
require_atom (ATOM_STRING);
strcpy (string, atom_string);
- gfc_free (atom_string);
+ free (atom_string);
}
}
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_PROC_POINTER_COMP, AB_PRIVATE_COMP,
- AB_VALUE, AB_VOLATILE, AB_PROTECTED,
+ AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP,
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
minit ("VALUE", AB_VALUE),
minit ("ALLOC_COMP", AB_ALLOC_COMP),
minit ("COARRAY_COMP", AB_COARRAY_COMP),
+ minit ("LOCK_COMP", AB_LOCK_COMP),
minit ("POINTER_COMP", AB_POINTER_COMP),
minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
if (attr->coarray_comp)
MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
+ if (attr->lock_comp)
+ MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
if (attr->zero_comp)
MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
if (attr->is_class)
case AB_COARRAY_COMP:
attr->coarray_comp = 1;
break;
+ case AB_LOCK_COMP:
+ attr->lock_comp = 1;
+ break;
case AB_POINTER_COMP:
attr->pointer_comp = 1;
break;
else
mio_symbol_ref (&ts->u.derived);
+ mio_symbol_ref (&ts->interface);
+
/* Add info for C interop and is_iso_c. */
mio_integer (&ts->is_c_interop);
mio_integer (&ts->is_iso_c);
mio_integer (&as->corank);
as->type = MIO_NAME (array_type) (as->type, array_spec_types);
+ if (iomode == IO_INPUT && as->corank)
+ as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT;
+
for (i = 0; i < as->rank + as->corank; i++)
{
mio_expr (&as->lower[i]);
the namespace and is not loaded again. */
static void
-mio_component_ref (gfc_component **cp, gfc_symbol *sym)
+mio_component_ref (gfc_component **cp)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_component *q;
pointer_info *p;
p = mio_pointer_ref (cp);
if (p->type == P_UNKNOWN)
p->type = P_COMPONENT;
-
- if (iomode == IO_OUTPUT)
- mio_pool_string (&(*cp)->name);
- else
- {
- mio_internal_string (name);
-
- if (sym && sym->attr.is_class)
- sym = sym->components->ts.u.derived;
-
- /* 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. */
- for (q = sym->components; q; q = q->next)
- if (strcmp (q->name, name) == 0)
- break;
-
- if (q == NULL)
- gfc_internal_error ("mio_component_ref(): Component not found");
-
- associate_integer_pointer (p, q);
- }
-
- /* Make sure this symbol will eventually be loaded. */
- p = find_pointer2 (sym);
- if (p->u.rsym.state == UNUSED)
- p->u.rsym.state = NEEDED;
- }
}
mio_array_spec (&c->as);
mio_symbol_attribute (&c->attr);
+ if (c->ts.type == BT_CLASS)
+ c->attr.class_ok = 1;
c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
if (!vtype)
case REF_COMPONENT:
mio_symbol_ref (&r->u.c.sym);
- mio_component_ref (&r->u.c.component, r->u.c.sym);
+ mio_component_ref (&r->u.c.component);
break;
case REF_SUBSTRING:
if (mpz_set_str (*integer, atom_string, 10))
bad_module ("Error converting integer");
- gfc_free (atom_string);
+ free (atom_string);
}
else
{
p = mpz_get_str (NULL, 10, *integer);
write_atom (ATOM_STRING, p);
- gfc_free (p);
+ free (p);
}
}
mpfr_init (*real);
mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
- gfc_free (atom_string);
+ free (atom_string);
}
else
{
if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
{
write_atom (ATOM_STRING, p);
- gfc_free (p);
+ free (p);
return;
}
write_atom (ATOM_STRING, atom_string);
- gfc_free (atom_string);
- gfc_free (p);
+ free (atom_string);
+ free (p);
}
}
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);
+ {
+ const char *name = e->symtree->n.sym->name;
+ if (e->symtree->n.sym->attr.flavor == FL_DERIVED)
+ name = dt_upper_string (name);
+ ns_st = gfc_find_symtree (gfc_current_ns->sym_root, 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. */
sym->attr.flavor = FL_PROCEDURE;
sym->attr.generic = 1;
e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
+ gfc_commit_symbol (sym);
}
}
{
require_atom (ATOM_STRING);
e->value.function.name = gfc_get_string (atom_string);
- gfc_free (atom_string);
+ free (atom_string);
mio_integer (&flag);
if (flag)
{
require_atom (ATOM_STRING);
e->value.function.isym = gfc_find_function (atom_string);
- gfc_free (atom_string);
+ free (atom_string);
}
}
if ((*proc)->is_generic)
{
gfc_tbp_generic* g;
+ int iop;
mio_lparen ();
if (iomode == IO_OUTPUT)
for (g = (*proc)->u.generic; g; g = g->next)
- mio_allocated_string (g->specific_st->name);
+ {
+ iop = (int) g->is_operator;
+ mio_integer (&iop);
+ mio_allocated_string (g->specific_st->name);
+ }
else
{
(*proc)->u.generic = NULL;
g = gfc_get_tbp_generic ();
g->specific = NULL;
+ mio_integer (&iop);
+ g->is_operator = (bool) iop;
+
require_atom (ATOM_STRING);
sym_root = ¤t_f2k_derived->tb_sym_root;
g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
- gfc_free (atom_string);
+ free (atom_string);
g->next = (*proc)->u.generic;
(*proc)->u.generic = g;
require_atom (ATOM_STRING);
st = gfc_get_tbp_symtree (root, atom_string);
- gfc_free (atom_string);
+ free (atom_string);
mio_typebound_symtree (st);
}
/* Unlike most other routines, the address of the symbol node is already
- fixed on input and the name/module has already been filled in. */
+ fixed on input and the name/module has already been filled in.
+ If you update the symbol format here, don't forget to update read_module
+ as well (look for "seek to the symbol's component list"). */
static void
mio_symbol (gfc_symbol *sym)
mio_symbol_attribute (&sym->attr);
mio_typespec (&sym->ts);
+ if (sym->ts.type == BT_CLASS)
+ sym->attr.class_ok = 1;
if (iomode == IO_OUTPUT)
mio_namespace_ref (&sym->formal_ns);
}
-/* Skip a list between balanced left and right parens. */
+/* Skip a list between balanced left and right parens.
+ By setting NEST_LEVEL to a non-zero value one assumes that a number of
+ NEST_LEVEL opening parens have been already parsed by hand, and the remaining
+ of the content is to be skipped here. */
static void
-skip_list (void)
+skip_list (int nest_level)
{
int level;
- level = 0;
+ level = nest_level;
do
{
switch (parse_atom ())
break;
case ATOM_STRING:
- gfc_free (atom_string);
+ free (atom_string);
break;
case ATOM_NAME:
if (!sym)
{
- /* Make the symbol inaccessible if it has been added by a USE
- statement without an ONLY(11.3.2). */
- if (st && only_flag
- && !st->n.sym->attr.use_only
- && !st->n.sym->attr.use_rename
- && strcmp (st->n.sym->module, module_name) == 0)
- {
- sym = st->n.sym;
- gfc_delete_symtree (&gfc_current_ns->sym_root, name);
- st = gfc_get_unique_symtree (gfc_current_ns);
- st->n.sym = sym;
- sym = NULL;
- }
- else if (st)
+ if (st)
{
sym = st->n.sym;
if (strcmp (st->name, p) != 0)
{
gfc_get_symbol (p, NULL, &sym);
sym->name = gfc_get_string (name);
- sym->module = gfc_get_string (module_name);
+ sym->module = module_name;
sym->attr.flavor = FL_PROCEDURE;
sym->attr.generic = 1;
sym->attr.use_assoc = 1;
while (peek_atom () != ATOM_RPAREN)
{
int flags;
+ char* label;
mio_lparen ();
mio_internal_string (name);
/* 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);
+ label = read_string ();
+ if (strlen (label))
+ p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
+ XDELETEVEC (label);
mio_rparen ();
}
{
head = eq->eq;
gfc_free_expr (eq->expr);
- gfc_free (eq);
+ free (eq);
}
}
if (!info || !derived)
{
while (peek_atom () != ATOM_RPAREN)
- skip_list ();
+ skip_list (0);
continue;
}
1, &ns->proc_name);
sym = gfc_new_symbol (p->u.rsym.true_name, ns);
+ sym->name = dt_lower_string (p->u.rsym.true_name);
sym->module = gfc_get_string (p->u.rsym.module);
- strcpy (sym->binding_label, p->u.rsym.binding_label);
+ if (p->u.rsym.binding_label)
+ sym->binding_label = IDENTIFIER_POINTER (get_identifier
+ (p->u.rsym.binding_label));
associate_integer_pointer (p, sym);
}
mio_symbol (sym);
sym->attr.use_assoc = 1;
- if (only_flag)
- sym->attr.use_only = 1;
+
+ /* Mark as only or rename for later diagnosis for explicitly imported
+ but not used warnings; don't mark internal symbols such as __vtab,
+ __def_init etc. Only mark them if they have been explicitly loaded. */
+
+ if (only_flag && sym->name[0] != '_' && sym->name[1] != '_')
+ {
+ gfc_use_rename *u;
+
+ /* Search the use/rename list for the variable; if the variable is
+ found, mark it. */
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (strcmp (u->use_name, sym->name) == 0)
+ {
+ sym->attr.use_only = 1;
+ break;
+ }
+ }
+ }
+
if (p->u.rsym.renamed)
sym->attr.use_rename = 1;
module_locus locus;
symbol_attribute attr;
+ if (st_sym->ns->proc_name && st_sym->name == st_sym->ns->proc_name->name)
+ {
+ gfc_error ("'%s' of module '%s', imported at %C, is also the name of the "
+ "current program unit", st_sym->name, module_name);
+ return true;
+ }
+
rsym = info->u.rsym.sym;
if (st_sym == rsym)
return false;
the new symbol is generic there can be no ambiguity. */
if (st_sym->attr.generic
&& st_sym->module
- && strcmp (st_sym->module, module_name))
+ && st_sym->module != module_name)
{
/* The new symbol's attributes have not yet been read. Since
we need attr.generic, read it directly. */
int i;
int ambiguous, j, nuse, symbol;
pointer_info *info, *q;
- gfc_use_rename *u;
+ gfc_use_rename *u = NULL;
gfc_symtree *st;
gfc_symbol *sym;
get_module_locus (&operator_interfaces); /* Skip these for now. */
- skip_list ();
+ skip_list (0);
get_module_locus (&user_operators);
- skip_list ();
- skip_list ();
+ skip_list (0);
+ skip_list (0);
/* Skip commons, equivalences and derived type extensions for now. */
- skip_list ();
- skip_list ();
+ skip_list (0);
+ skip_list (0);
get_module_locus (&extensions);
- skip_list ();
+ skip_list (0);
mio_lparen ();
while (peek_atom () != ATOM_RPAREN)
{
+ char* bind_label;
require_atom (ATOM_INTEGER);
info = get_integer (atom_int);
info->type = P_SYMBOL;
info->u.rsym.state = UNUSED;
- mio_internal_string (info->u.rsym.true_name);
- mio_internal_string (info->u.rsym.module);
- mio_internal_string (info->u.rsym.binding_label);
-
+ info->u.rsym.true_name = read_string ();
+ info->u.rsym.module = read_string ();
+ bind_label = read_string ();
+ if (strlen (bind_label))
+ info->u.rsym.binding_label = bind_label;
+ else
+ XDELETEVEC (bind_label);
require_atom (ATOM_INTEGER);
info->u.rsym.ns = atom_int;
get_module_locus (&info->u.rsym.where);
- 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
if (sym == NULL
|| (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
- continue;
+ {
+ skip_list (0);
+ continue;
+ }
info->u.rsym.state = USED;
info->u.rsym.sym = sym;
+ /* The current symbol has already been loaded, so we can avoid loading
+ it again. However, if it is a derived type, some of its components
+ can be used in expressions in the module. To avoid the module loading
+ failing, we need to associate the module's component pointer indexes
+ with the existing symbol's component pointers. */
+ if (sym->attr.flavor == FL_DERIVED)
+ {
+ gfc_component *c;
+
+ /* First seek to the symbol's component list. */
+ mio_lparen (); /* symbol opening. */
+ skip_list (0); /* skip symbol attribute. */
+ skip_list (0); /* typespec. */
+ require_atom (ATOM_INTEGER); /* namespace ref. */
+ require_atom (ATOM_INTEGER); /* common ref. */
+ skip_list (0); /* formal args. */
+ /* no value. */
+ skip_list (0); /* array_spec. */
+ require_atom (ATOM_INTEGER); /* result. */
+ /* not a cray pointer. */
+
+ mio_lparen (); /* component list opening. */
+ for (c = sym->components; c; c = c->next)
+ {
+ pointer_info *p;
+ const char *comp_name;
+ int n;
+
+ mio_lparen (); /* component opening. */
+ mio_integer (&n);
+ p = get_integer (n);
+ if (p->u.pointer == NULL)
+ associate_integer_pointer (p, c);
+ mio_pool_string (&comp_name);
+ gcc_assert (comp_name == c->name);
+ skip_list (1); /* component end. */
+ }
+ mio_rparen (); /* component list closing. */
+
+ skip_list (1); /* symbol end. */
+ }
+ else
+ skip_list (0);
/* Some symbols do not have a namespace (eg. formal arguments),
so the automatic "unique symtree" mechanism must be suppressed
p = name;
/* Exception: Always import vtabs & vtypes. */
- if (p == NULL && (strncmp (name, "__vtab_", 5) == 0
- || strncmp (name, "__vtype_", 6) == 0))
+ if (p == NULL && name[0] == '_'
+ && (strncmp (name, "__vtab_", 5) == 0
+ || strncmp (name, "__vtype_", 6) == 0))
p = name;
/* Skip symtree nodes not in an ONLY clause, unless there
if (p == NULL)
{
st = gfc_find_symtree (gfc_current_ns->sym_root, name);
- if (st != NULL)
- info->u.rsym.symtree = st;
+ if (st != NULL
+ && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
+ && st->n.sym->module != NULL
+ && strcmp (st->n.sym->module, info->u.rsym.module) == 0)
+ {
+ info->u.rsym.symtree = st;
+ info->u.rsym.sym = st->n.sym;
+ }
continue;
}
/* Check for ambiguous symbols. */
if (check_for_ambiguous (st->n.sym, info))
st->ambiguous = 1;
- info->u.rsym.symtree = st;
+ else
+ info->u.rsym.symtree = st;
}
else
{
st = gfc_find_symtree (gfc_current_ns->sym_root, name);
- /* Delete the symtree if the symbol has been added by a USE
- statement without an ONLY(11.3.2). Remember that the rsym
- will be the same as the symbol found in the symtree, for
- this case. */
- if (st && (only_flag || info->u.rsym.renamed)
- && !st->n.sym->attr.use_only
- && !st->n.sym->attr.use_rename
- && info->u.rsym.sym == st->n.sym)
- gfc_delete_symtree (&gfc_current_ns->sym_root, name);
-
/* Create a symtree node in the current namespace for this
symbol. */
st = check_unique_name (p)
{
info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
gfc_current_ns);
+ info->u.rsym.sym->name = dt_lower_string (info->u.rsym.true_name);
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);
+ if (info->u.rsym.binding_label)
+ sym->binding_label =
+ IDENTIFIER_POINTER (get_identifier
+ (info->u.rsym.binding_label));
}
st->n.sym = sym;
if (strcmp (name, p) != 0)
sym->attr.use_rename = 1;
- /* We need to set the only_flag here so that symbols from the
- same USE...ONLY but earlier are not deleted from the tree in
- the gfc_delete_symtree above. */
- sym->attr.use_only = only_flag;
+ if (name[0] != '_'
+ || (strncmp (name, "__vtab_", 5) != 0
+ && strncmp (name, "__vtype_", 6) != 0))
+ sym->attr.use_only = only_flag;
/* Store the symtree pointing to this symbol. */
info->u.rsym.symtree = st;
if (u == NULL)
{
- skip_list ();
+ skip_list (0);
continue;
}
}
mio_interface (&gfc_current_ns->op[i]);
+ if (u && !gfc_current_ns->op[i])
+ u->found = 0;
}
mio_rparen ();
if (w->right)
free_written_common (w->right);
- gfc_free (w);
+ free (w);
}
/* Write a common block to the module -- recursive helper function. */
write_common_0 (st->left, this_module);
- /* We will write out the binding label, or the name if no label given. */
+ /* We will write out the binding label, or "" if no label given. */
name = st->n.common->name;
p = st->n.common;
- label = p->is_bind_c ? p->binding_label : p->name;
+ label = (p->is_bind_c && p->binding_label) ? p->binding_label : "";
/* Check if we've already output this common. */
w = written_commons;
/* 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);
+ /* Write out an empty binding label. */
+ write_atom (ATOM_STRING, "");
mio_rparen ();
}
{
if (!gfc_check_symbol_access (st->n.sym))
return;
+ if (!(st->n.sym->ns && st->n.sym->ns->proc_name
+ && st->n.sym->ns->proc_name->attr.flavor == FL_MODULE))
+ return;
mio_lparen ();
- mio_pool_string (&st->n.sym->name);
+ mio_pool_string (&st->name);
if (st->n.sym->module != NULL)
mio_pool_string (&st->n.sym->module);
else
- mio_internal_string (module_name);
+ {
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ if (iomode == IO_OUTPUT)
+ strcpy (name, module_name);
+ mio_internal_string (name);
+ if (iomode == IO_INPUT)
+ module_name = gfc_get_string (name);
+ }
mio_rparen ();
}
gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
mio_integer (&n);
- mio_pool_string (&sym->name);
+
+ if (sym->attr.flavor == FL_DERIVED)
+ {
+ const char *name;
+ name = dt_upper_string (sym->name);
+ mio_pool_string (&name);
+ }
+ else
+ mio_pool_string (&sym->name);
mio_pool_string (&sym->module);
- if (sym->attr.is_bind_c || sym->attr.is_iso_c)
+ if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label)
{
label = sym->binding_label;
mio_pool_string (&label);
}
else
- mio_pool_string (&sym->name);
+ write_atom (ATOM_STRING, "");
mio_pointer_ref (&sym->ns);
sym = st->n.sym;
if (sym->module == NULL)
- sym->module = gfc_get_string (module_name);
+ sym->module = module_name;
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
&& !sym->attr.subroutine && !sym->attr.function)
return;
if (sym->module == NULL)
- sym->module = gfc_get_string (module_name);
+ sym->module = module_name;
mio_symbol_interface (&st->name, &sym->module, &sym->generic);
}
gfc_dump_module (const char *name, int dump_flag)
{
int n;
- char *filename, *filename_tmp, *p;
- time_t now;
+ char *filename, *filename_tmp;
fpos_t md5_pos;
unsigned char md5_new[16], md5_old[16];
filename_tmp, xstrerror (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 version '%s' created from %s on %s\n"
- "MD5:", MOD_VERSION, gfc_source_file, p);
+ fprintf (module_fp, "GFORTRAN module version '%s' created from %s\n"
+ "MD5:", MOD_VERSION, gfc_source_file);
fgetpos (module_fp, &md5_pos);
fputs ("00000000000000000000000000000000 -- "
"If you edit this, you'll get what you deserve.\n\n", module_fp);
/* Write the module itself. */
iomode = IO_OUTPUT;
- strcpy (module_name, name);
+ module_name = gfc_get_string (name);
init_pi_tree ();
for (u = gfc_rename_list; u; u = u->next)
if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
{
+ bool not_in_std;
+ const char *name;
u->found = 1;
found = true;
+
+ switch (i)
+ {
+#define NAMED_FUNCTION(a,b,c,d) \
+ case a: \
+ not_in_std = (gfc_option.allow_std & d) == 0; \
+ name = b; \
+ break;
+#include "iso-c-binding.def"
+#undef NAMED_FUNCTION
+#define NAMED_INTCST(a,b,c,d) \
+ case a: \
+ not_in_std = (gfc_option.allow_std & d) == 0; \
+ name = b; \
+ break;
+#include "iso-c-binding.def"
+#undef NAMED_INTCST
+#define NAMED_REALCST(a,b,c,d) \
+ case a: \
+ not_in_std = (gfc_option.allow_std & d) == 0; \
+ name = b; \
+ break;
+#include "iso-c-binding.def"
+#undef NAMED_REALCST
+#define NAMED_CMPXCST(a,b,c,d) \
+ case a: \
+ not_in_std = (gfc_option.allow_std & d) == 0; \
+ name = b; \
+ break;
+#include "iso-c-binding.def"
+#undef NAMED_CMPXCST
+ default:
+ not_in_std = false;
+ name = "";
+ }
+
+ if (not_in_std)
+ {
+ gfc_error ("The symbol '%s', referenced at %L, is not "
+ "in the selected standard", name, &u->where);
+ continue;
+ }
+
switch (i)
{
#define NAMED_FUNCTION(a,b,c,d) \
}
if (!found && !only_flag)
- switch (i)
- {
+ {
+ /* Skip, if the symbol is not in the enabled standard. */
+ switch (i)
+ {
+#define NAMED_FUNCTION(a,b,c,d) \
+ case a: \
+ if ((gfc_option.allow_std & d) == 0) \
+ continue; \
+ break;
+#include "iso-c-binding.def"
+#undef NAMED_FUNCTION
+
+#define NAMED_INTCST(a,b,c,d) \
+ case a: \
+ if ((gfc_option.allow_std & d) == 0) \
+ continue; \
+ break;
+#include "iso-c-binding.def"
+#undef NAMED_INTCST
+#define NAMED_REALCST(a,b,c,d) \
+ case a: \
+ if ((gfc_option.allow_std & d) == 0) \
+ continue; \
+ break;
+#include "iso-c-binding.def"
+#undef NAMED_REALCST
+#define NAMED_CMPXCST(a,b,c,d) \
+ case a: \
+ if ((gfc_option.allow_std & d) == 0) \
+ continue; \
+ break;
+#include "iso-c-binding.def"
+#undef NAMED_CMPXCST
+ default:
+ ; /* Not GFC_STD_* versioned. */
+ }
+
+ switch (i)
+ {
#define NAMED_FUNCTION(a,b,c,d) \
- case a: \
- if ((gfc_option.allow_std & d) == 0) \
- continue; \
- create_intrinsic_function (b, (gfc_isym_id) c, \
- iso_c_module_name, \
- INTMOD_ISO_C_BINDING); \
+ case a: \
+ create_intrinsic_function (b, (gfc_isym_id) c, \
+ iso_c_module_name, \
+ INTMOD_ISO_C_BINDING); \
break;
#include "iso-c-binding.def"
#undef NAMED_FUNCTION
- default:
- generate_isocbinding_symbol (iso_c_module_name,
- (iso_c_binding_symbol) i, NULL);
- }
+ default:
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i, NULL);
+ }
+ }
}
for (u = gfc_rename_list; u; u = u->next)
}
+/* Add an derived type for a given module. */
+
+static void
+create_derived_type (const char *name, const char *modname,
+ intmod_id module, int id)
+{
+ gfc_symtree *tmp_symtree;
+ gfc_symbol *sym, *dt_sym;
+ gfc_interface *intr, *head;
+
+ 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, false);
+ sym = tmp_symtree->n.sym;
+ sym->module = gfc_get_string (modname);
+ sym->from_intmod = module;
+ sym->intmod_sym_id = id;
+ sym->attr.flavor = FL_PROCEDURE;
+ sym->attr.function = 1;
+ sym->attr.generic = 1;
+
+ gfc_get_sym_tree (dt_upper_string (sym->name),
+ gfc_current_ns, &tmp_symtree, false);
+ dt_sym = tmp_symtree->n.sym;
+ dt_sym->name = gfc_get_string (sym->name);
+ dt_sym->attr.flavor = FL_DERIVED;
+ dt_sym->attr.private_comp = 1;
+ dt_sym->attr.zero_comp = 1;
+ dt_sym->attr.use_assoc = 1;
+ dt_sym->module = gfc_get_string (modname);
+ dt_sym->from_intmod = module;
+ dt_sym->intmod_sym_id = id;
+
+ head = sym->generic;
+ intr = gfc_get_interface ();
+ intr->sym = dt_sym;
+ intr->where = gfc_current_locus;
+ intr->next = head;
+ sym->generic = intr;
+ sym->attr.if_source = IFSRC_DECL;
+}
+
/* USE the ISO_FORTRAN_ENV intrinsic module. */
#define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
#include "iso-fortran-env.def"
#undef NAMED_KINDARRAY
+#define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
+#include "iso-fortran-env.def"
+#undef NAMED_DERIVED_TYPE
#define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
#include "iso-fortran-env.def"
#undef NAMED_FUNCTION
u->found = 1;
if (gfc_notify_std (symbol[i].standard, "The symbol '%s', "
- "referrenced at %C, is not in the selected "
- "standard", symbol[i].name) == FAILURE)
+ "referenced at %L, is not in the selected "
+ "standard", symbol[i].name,
+ &u->where) == FAILURE)
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 %C is incompatible with "
- "option %s",
+ "ISO_FORTRAN_ENV at %L is incompatible with "
+ "option %s", &u->where,
gfc_option.flag_default_integer
? "-fdefault-integer-8"
: "-fdefault-real-8");
#include "iso-fortran-env.def"
#undef NAMED_KINDARRAY
+#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
+ case a:
+#include "iso-fortran-env.def"
+ create_derived_type (u->local_name[0] ? u->local_name
+ : u->use_name,
+ mod, INTMOD_ISO_FORTRAN_ENV,
+ symbol[i].id);
+ break;
+#undef NAMED_DERIVED_TYPE
+
#define NAMED_FUNCTION(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
#include "iso-fortran-env.def"
#undef NAMED_KINDARRAY
+#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
+ case a:
+#include "iso-fortran-env.def"
+ create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
+ symbol[i].id);
+ break;
+#undef NAMED_DERIVED_TYPE
+
#define NAMED_FUNCTION(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
/* Process a USE directive. */
-void
-gfc_use_module (void)
+static void
+gfc_use_module (gfc_use_list *module)
{
char *filename;
gfc_state_data *p;
int c, line, start;
gfc_symtree *mod_symtree;
gfc_use_list *use_stmt;
+ locus old_locus = gfc_current_locus;
- filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
- + 1);
+ gfc_current_locus = module->where;
+ module_name = module->module_name;
+ gfc_rename_list = module->rename;
+ only_flag = module->only_flag;
+
+ filename = XALLOCAVEC (char, strlen (module_name) + strlen (MODULE_EXTENSION)
+ + 1);
strcpy (filename, module_name);
strcat (filename, MODULE_EXTENSION);
/* First, try to find an non-intrinsic module, unless the USE statement
specified that the module is intrinsic. */
module_fp = NULL;
- if (!specified_int)
+ if (!module->intrinsic)
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 (module_fp == NULL && !module->non_intrinsic)
{
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 ();
+ gfc_current_locus = old_locus;
+ module->intrinsic = true;
return;
}
"ISO_C_BINDING module at %C") != FAILURE)
{
import_iso_c_binding_module();
+ gfc_current_locus = old_locus;
+ module->intrinsic = true;
return;
}
module_fp = gfc_open_intrinsic_module (filename);
- if (module_fp == NULL && specified_int)
+ if (module_fp == NULL && module->intrinsic)
gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
module_name);
}
MOD_VERSION, filename);
}
- gfc_free (atom_string);
+ free (atom_string);
}
if (c == '\n')
fclose (module_fp);
use_stmt = gfc_get_use_list ();
- use_stmt->module_name = gfc_get_string (module_name);
- use_stmt->only_flag = only_flag;
- use_stmt->rename = gfc_rename_list;
- use_stmt->where = use_locus;
- gfc_rename_list = NULL;
+ *use_stmt = *module;
use_stmt->next = gfc_current_ns->use_stmts;
gfc_current_ns->use_stmts = use_stmt;
+
+ gfc_current_locus = old_locus;
+}
+
+
+/* Remove duplicated intrinsic operators from the rename list. */
+
+static void
+rename_list_remove_duplicate (gfc_use_rename *list)
+{
+ gfc_use_rename *seek, *last;
+
+ for (; list; list = list->next)
+ if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE)
+ {
+ last = list;
+ for (seek = list->next; seek; seek = last->next)
+ {
+ if (list->op == seek->op)
+ {
+ last->next = seek->next;
+ free (seek);
+ }
+ else
+ last = seek;
+ }
+ }
+}
+
+
+/* Process all USE directives. */
+
+void
+gfc_use_modules (void)
+{
+ gfc_use_list *next, *seek, *last;
+
+ for (next = module_list; next; next = next->next)
+ {
+ bool non_intrinsic = next->non_intrinsic;
+ bool intrinsic = next->intrinsic;
+ bool neither = !non_intrinsic && !intrinsic;
+
+ for (seek = next->next; seek; seek = seek->next)
+ {
+ if (next->module_name != seek->module_name)
+ continue;
+
+ if (seek->non_intrinsic)
+ non_intrinsic = true;
+ else if (seek->intrinsic)
+ intrinsic = true;
+ else
+ neither = true;
+ }
+
+ if (intrinsic && neither && !non_intrinsic)
+ {
+ char *filename;
+ FILE *fp;
+
+ filename = XALLOCAVEC (char,
+ strlen (next->module_name)
+ + strlen (MODULE_EXTENSION) + 1);
+ strcpy (filename, next->module_name);
+ strcat (filename, MODULE_EXTENSION);
+ fp = gfc_open_included_file (filename, true, true);
+ if (fp != NULL)
+ {
+ non_intrinsic = true;
+ fclose (fp);
+ }
+ }
+
+ last = next;
+ for (seek = next->next; seek; seek = last->next)
+ {
+ if (next->module_name != seek->module_name)
+ {
+ last = seek;
+ continue;
+ }
+
+ if ((!next->intrinsic && !seek->intrinsic)
+ || (next->intrinsic && seek->intrinsic)
+ || !non_intrinsic)
+ {
+ if (!seek->only_flag)
+ next->only_flag = false;
+ if (seek->rename)
+ {
+ gfc_use_rename *r = seek->rename;
+ while (r->next)
+ r = r->next;
+ r->next = next->rename;
+ next->rename = seek->rename;
+ }
+ last->next = seek->next;
+ free (seek);
+ }
+ else
+ last = seek;
+ }
+ }
+
+ for (; module_list; module_list = next)
+ {
+ next = module_list->next;
+ rename_list_remove_duplicate (module_list->rename);
+ gfc_use_module (module_list);
+ if (module_list->intrinsic)
+ free_rename (module_list->rename);
+ free (module_list);
+ }
+ gfc_rename_list = NULL;
}
for (; use_stmts->rename; use_stmts->rename = next_rename)
{
next_rename = use_stmts->rename->next;
- gfc_free (use_stmts->rename);
+ free (use_stmts->rename);
}
next = use_stmts->next;
- gfc_free (use_stmts);
+ free (use_stmts);
}
}
gfc_module_init_2 (void)
{
last_atom = ATOM_LPAREN;
+ gfc_rename_list = NULL;
+ module_list = NULL;
}
void
gfc_module_done_2 (void)
{
- free_rename ();
+ free_rename (gfc_rename_list);
+ gfc_rename_list = NULL;
}
OSDN Git Service
