/* 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
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
/* Don't put any single quote (') in MOD_VERSION,
if yout want it to be recognized. */
-#define MOD_VERSION "6"
+#define MOD_VERSION "7"
/* Structure that describes a position within a module file. */
free_pi_tree (p->left);
free_pi_tree (p->right);
- gfc_free (p);
+ free (p);
}
{
next = f->next;
*(f->pointer) = gp;
- gfc_free (f);
+ free (f);
}
}
for (; gfc_rename_list; gfc_rename_list = next)
{
next = gfc_rename_list->next;
- gfc_free (gfc_rename_list);
+ free (gfc_rename_list);
}
}
free_true_name (t->left);
free_true_name (t->right);
- gfc_free (t);
+ free (t);
}
a = parse_atom ();
if (a == ATOM_STRING)
- gfc_free (atom_string);
+ free (atom_string);
set_module_locus (&m);
return a;
{
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_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_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_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
+ AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
+ AB_IMPLICIT_PURE
}
ab_attribute;
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),
minit ("ZERO_COMP", AB_ZERO_COMP),
minit ("PROTECTED", AB_PROTECTED),
minit ("VTYPE", AB_VTYPE),
minit ("VTAB", AB_VTAB),
minit ("CLASS_POINTER", AB_CLASS_POINTER),
+ minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
minit (NULL, -1)
};
MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
if (attr->pure)
MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
+ if (attr->implicit_pure)
+ MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
if (attr->recursive)
MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
if (attr->always_explicit)
MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
if (attr->pointer_comp)
MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
+ if (attr->proc_pointer_comp)
+ MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits);
if (attr->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_PURE:
attr->pure = 1;
break;
+ case AB_IMPLICIT_PURE:
+ attr->implicit_pure = 1;
+ break;
case AB_RECURSIVE:
attr->recursive = 1;
break;
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;
+ case AB_PROC_POINTER_COMP:
+ attr->proc_pointer_comp = 1;
+ break;
case AB_PRIVATE_COMP:
attr->private_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);
else
mio_charlen (&ts->u.cl);
+ /* So as not to disturb the existing API, use an ATOM_NAME to
+ transmit deferred characteristic for characters (F2003). */
+ if (iomode == IO_OUTPUT)
+ {
+ if (ts->type == BT_CHARACTER && ts->deferred)
+ write_atom (ATOM_NAME, "DEFERRED_CL");
+ }
+ else if (peek_atom () != ATOM_RPAREN)
+ {
+ if (parse_atom () != ATOM_NAME)
+ bad_module ("Expected string");
+ ts->deferred = 1;
+ }
+
mio_rparen ();
}
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]);
{
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->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;
+ q = gfc_find_component (sym, name, true, true);
- if (q == NULL)
- gfc_internal_error ("mio_component_ref(): Component not found");
-
- associate_integer_pointer (p, q);
+ if (q)
+ associate_integer_pointer (p, q);
}
/* Make sure this symbol will eventually be loaded. */
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)
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);
}
}
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);
}
}
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);
}
break;
case ATOM_STRING:
- gfc_free (atom_string);
+ free (atom_string);
break;
case ATOM_NAME:
{
head = eq->eq;
gfc_free_expr (eq->expr);
- gfc_free (eq);
+ free (eq);
}
}
if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
{
+ gfc_namespace *ns;
/* Add hidden symbols to the symtree. */
q = get_integer (p->u.rsym.ns);
- st = gfc_get_unique_symtree ((gfc_namespace *) q->u.pointer);
+ ns = (gfc_namespace *) q->u.pointer;
+
+ if (!p->u.rsym.sym->attr.vtype
+ && !p->u.rsym.sym->attr.vtab)
+ st = gfc_get_unique_symtree (ns);
+ else
+ {
+ /* There is no reason to use 'unique_symtrees' for vtabs or
+ vtypes - their name is fine for a symtree and reduces the
+ namespace pollution. */
+ st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name);
+ if (!st)
+ st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name);
+ }
st->n.sym = p->u.rsym.sym;
st->n.sym->refs++;
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;
p = name;
/* Exception: Always import vtabs & vtypes. */
- if (p == NULL && (strcmp (xstrndup (name,5), "vtab$") == 0
- || strcmp (xstrndup (name,6), "vtype$") == 0))
+ if (p == NULL && (strncmp (name, "__vtab_", 5) == 0
+ || strncmp (name, "__vtype_", 6) == 0))
p = name;
/* Skip symtree nodes not in an ONLY clause, unless there
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)
+static bool
+check_access (gfc_access specific_access, gfc_access default_access)
{
if (specific_access == ACCESS_PUBLIC)
return TRUE;
}
+bool
+gfc_check_symbol_access (gfc_symbol *sym)
+{
+ if (sym->attr.vtab || sym->attr.vtype)
+ return true;
+ else
+ return check_access (sym->attr.access, sym->ns->default_access);
+}
+
+
/* A structure to remember which commons we've already written. */
struct written_common
if (w->right)
free_written_common (w->right);
- gfc_free (w);
+ free (w);
}
/* Write a common block to the module -- recursive helper function. */
static void
write_dt_extensions (gfc_symtree *st)
{
- if (!gfc_check_access (st->n.sym->attr.access,
- st->n.sym->ns->default_access))
+ 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 ();
&& !sym->attr.subroutine && !sym->attr.function)
dont_write = true;
- if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
+ if (!gfc_check_symbol_access (sym))
dont_write = true;
if (!dont_write)
static char nullstring[] = "";
const char *p = nullstring;
- if (uop->op == NULL
- || !gfc_check_access (uop->access, uop->ns->default_access))
+ if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
return;
mio_symbol_interface (&uop->name, &p, &uop->op);
if (!sym || check_unique_name (st->name))
return;
- if (sym->generic == NULL
- || !gfc_check_access (sym->attr.access, sym->ns->default_access))
+ if (sym->generic == NULL || !gfc_check_symbol_access (sym))
return;
if (sym->module == NULL)
&& sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
return;
- if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
+ if (!gfc_check_symbol_access (sym)
|| (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
&& !sym->attr.subroutine && !sym->attr.function))
return;
if (i == INTRINSIC_USER)
continue;
- mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
- gfc_current_ns->default_access)
+ mio_interface (check_access (gfc_current_ns->operator_access[i],
+ gfc_current_ns->default_access)
? &gfc_current_ns->op[i] : NULL);
}
}
+static void
+create_intrinsic_function (const char *name, gfc_isym_id id,
+ const char *modname, intmod_id module)
+{
+ gfc_intrinsic_sym *isym;
+ gfc_symtree *tmp_symtree;
+ gfc_symbol *sym;
+
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (tmp_symtree)
+ {
+ if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+ return;
+ gfc_error ("Symbol '%s' already declared", name);
+ }
+
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+ sym = tmp_symtree->n.sym;
+
+ isym = gfc_intrinsic_function_by_id (id);
+ gcc_assert (isym);
+
+ sym->attr.flavor = FL_PROCEDURE;
+ sym->attr.intrinsic = 1;
+
+ sym->module = gfc_get_string (modname);
+ sym->attr.use_assoc = 1;
+ sym->from_intmod = module;
+ sym->intmod_sym_id = id;
+}
+
+
/* 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
{
u->found = 1;
found = true;
- generate_isocbinding_symbol (iso_c_module_name,
- (iso_c_binding_symbol) i,
- u->local_name);
+ switch (i)
+ {
+#define NAMED_FUNCTION(a,b,c,d) \
+ case a: \
+ create_intrinsic_function (u->local_name[0] ? u->local_name \
+ : u->use_name, \
+ (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,
+ u->local_name[0] ? u->local_name
+ : u->use_name);
+ }
}
if (!found && !only_flag)
- generate_isocbinding_symbol (iso_c_module_name,
- (iso_c_binding_symbol) i, NULL);
+ 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); \
+ break;
+#include "iso-c-binding.def"
+#undef NAMED_FUNCTION
+
+ 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;
+
+ 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_DERIVED;
+ sym->attr.private_comp = 1;
+ sym->attr.zero_comp = 1;
+ sym->attr.use_assoc = 1;
+}
+
+
/* 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
{ ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
i = 0;
#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"
+#undef NAMED_FUNCTION
+ create_intrinsic_function (u->local_name[0] ? u->local_name
+ : u->use_name,
+ (gfc_isym_id) symbol[i].value, mod,
+ INTMOD_ISO_FORTRAN_ENV);
+ break;
+
default:
gcc_unreachable ();
}
#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"
+#undef NAMED_FUNCTION
+ create_intrinsic_function (symbol[i].name,
+ (gfc_isym_id) symbol[i].value, mod,
+ INTMOD_ISO_FORTRAN_ENV);
+ break;
+
default:
gcc_unreachable ();
}
"for file '%s' opened at %C", atom_string,
MOD_VERSION, filename);
}
+
+ free (atom_string);
}
if (c == '\n')
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);
}
}
projects / gcc.git / blobdiff