/* 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 "5"
+#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_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 ("PROC_POINTER", AB_PROC_POINTER),
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_OPTIONAL, attr_bits);
if (attr->pointer)
MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
+ if (attr->class_pointer)
+ MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
if (attr->is_protected)
MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
if (attr->value)
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_POINTER:
attr->pointer = 1;
break;
+ case AB_CLASS_POINTER:
+ attr->class_pointer = 1;
+ break;
case AB_PROTECTED:
attr->is_protected = 1;
break;
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;
-
- if (q == NULL)
- gfc_internal_error ("mio_component_ref(): Component not found");
+ q = gfc_find_component (sym, name, true, true);
- associate_integer_pointer (p, q);
+ if (q)
+ associate_integer_pointer (p, q);
}
/* Make sure this symbol will eventually be loaded. */
static void mio_typebound_proc (gfc_typebound_proc** proc);
static void
-mio_component (gfc_component *c)
+mio_component (gfc_component *c, int vtype)
{
pointer_info *p;
int n;
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);
- mio_expr (&c->initializer);
+ if (!vtype)
+ mio_expr (&c->initializer);
if (c->attr.proc_pointer)
{
static void
-mio_component_list (gfc_component **cp)
+mio_component_list (gfc_component **cp, int vtype)
{
gfc_component *c, *tail;
if (iomode == IO_OUTPUT)
{
for (c = *cp; c; c = c->next)
- mio_component (c);
+ mio_component (c, vtype);
}
else
{
break;
c = gfc_get_component ();
- mio_component (c);
+ mio_component (c, vtype);
if (tail == NULL)
*cp = c;
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);
}
/* Note that components are always saved, even if they are supposed
to be private. Component access is checked during searching. */
- mio_component_list (&sym->components);
+ mio_component_list (&sym->components, sym->attr.vtype);
if (sym->components != NULL)
sym->component_access
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;
if (p == NULL && strcmp (name, module_name) == 0)
p = name;
+ /* Exception: Always import vtabs & vtypes. */
+ 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
is an existing symtree loaded from another USE statement. */
if (p == NULL)
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
-sort_iso_c_rename_list (void)
+create_intrinsic_function (const char *name, gfc_isym_id id,
+ const char *modname, intmod_id module)
{
- gfc_use_rename *tmp_list = NULL;
- gfc_use_rename *curr;
- gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
- int c_kind;
- int i;
+ gfc_intrinsic_sym *isym;
+ gfc_symtree *tmp_symtree;
+ gfc_symbol *sym;
- for (curr = gfc_rename_list; curr; curr = curr->next)
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (tmp_symtree)
{
- c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
- if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
- {
- gfc_error ("Symbol '%s' referenced at %L does not exist in "
- "intrinsic module ISO_C_BINDING.", curr->use_name,
- &curr->where);
- }
- else
- /* Put it in the list. */
- kinds_used[c_kind] = curr;
+ if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+ return;
+ gfc_error ("Symbol '%s' already declared", name);
}
- /* Make a new (sorted) rename list. */
- i = 0;
- while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
- i++;
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+ sym = tmp_symtree->n.sym;
- if (i < ISOCBINDING_NUMBER)
- {
- tmp_list = kinds_used[i];
+ isym = gfc_intrinsic_function_by_id (id);
+ gcc_assert (isym);
- i++;
- curr = tmp_list;
- for (; i < ISOCBINDING_NUMBER; i++)
- if (kinds_used[i] != NULL)
- {
- curr->next = kinds_used[i];
- curr = curr->next;
- curr->next = NULL;
- }
- }
+ sym->attr.flavor = FL_PROCEDURE;
+ sym->attr.intrinsic = 1;
- gfc_rename_list = tmp_list;
+ sym->module = gfc_get_string (modname);
+ sym->attr.use_assoc = 1;
+ sym->from_intmod = module;
+ sym->intmod_sym_id = id;
}
const char *iso_c_module_name = "__iso_c_binding";
gfc_use_rename *u;
int i;
- char *local_name;
/* Look only in the current namespace. */
mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
/* Generate the symbols for the named constants representing
the kinds for intrinsic data types. */
- if (only_flag)
+ for (i = 0; i < ISOCBINDING_NUMBER; i++)
{
- /* Sort the rename list because there are dependencies between types
- and procedures (e.g., c_loc needs c_ptr). */
- sort_iso_c_rename_list ();
-
+ bool found = false;
for (u = gfc_rename_list; u; u = u->next)
- {
- i = get_c_kind (u->use_name, c_interop_kinds_table);
+ if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
+ {
+ u->found = 1;
+ found = true;
+ 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 (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
- {
- gfc_error ("Symbol '%s' referenced at %L does not exist in "
- "intrinsic module ISO_C_BINDING.", u->use_name,
- &u->where);
- continue;
- }
-
- generate_isocbinding_symbol (iso_c_module_name,
- (iso_c_binding_symbol) i,
- u->local_name);
- }
- }
- else
- {
- for (i = 0; i < ISOCBINDING_NUMBER; i++)
- {
- local_name = NULL;
- for (u = gfc_rename_list; u; u = u->next)
- {
- if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
- {
- local_name = u->local_name;
- u->found = 1;
+ if (!found && !only_flag)
+ 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;
- }
- }
- generate_isocbinding_symbol (iso_c_module_name,
- (iso_c_binding_symbol) i,
- local_name);
- }
+#include "iso-c-binding.def"
+#undef NAMED_FUNCTION
- for (u = gfc_rename_list; u; u = u->next)
- {
- if (u->found)
- continue;
+ default:
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i, NULL);
+ }
+ }
- gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
- "module ISO_C_BINDING", u->use_name, &u->where);
- }
- }
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (u->found)
+ continue;
+
+ gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
+ "module ISO_C_BINDING", u->use_name, &u->where);
+ }
}
}
+/* Value is already contained by the array constructor, but not
+ yet the shape. */
+
+static void
+create_int_parameter_array (const char *name, int size, gfc_expr *value,
+ const char *modname, intmod_id module, int id)
+{
+ gfc_symtree *tmp_symtree;
+ gfc_symbol *sym;
+
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (tmp_symtree != NULL)
+ {
+ if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+ return;
+ else
+ gfc_error ("Symbol '%s' already declared", name);
+ }
+
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+ 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->attr.use_assoc = 1;
+ sym->from_intmod = module;
+ sym->intmod_sym_id = id;
+ sym->attr.dimension = 1;
+ sym->as = gfc_get_array_spec ();
+ sym->as->rank = 1;
+ sym->as->type = AS_EXPLICIT;
+ sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+ sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size);
+
+ sym->value = value;
+ sym->value->shape = gfc_get_shape (1);
+ mpz_init_set_ui (sym->value->shape[0], size);
+}
+
+
+/* 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. */
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;
+ gfc_expr *expr;
+ int i, j;
intmod_sym symbol[] = {
#define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
#include "iso-fortran-env.def"
#undef NAMED_INTCST
+#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;
"non-intrinsic module name used previously", mod);
/* Generate the symbols for the module integer named constants. */
- if (only_flag)
- for (u = gfc_rename_list; u; u = u->next)
- {
- for (i = 0; symbol[i].name; i++)
- if (strcmp (symbol[i].name, u->use_name) == 0)
- break;
-
- if (symbol[i].name == NULL)
- {
- gfc_error ("Symbol '%s' referenced at %L does not exist in "
- "intrinsic module ISO_FORTRAN_ENV", u->use_name,
- &u->where);
- continue;
- }
- if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
- && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
- gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
- "from intrinsic module ISO_FORTRAN_ENV at %L is "
- "incompatible with option %s", &u->where,
- gfc_option.flag_default_integer
- ? "-fdefault-integer-8" : "-fdefault-real-8");
-
- if (gfc_notify_std (symbol[i].standard, "The symbol '%s', referrenced "
- "at %C, is not in the selected standard",
- symbol[i].name) == FAILURE)
- continue;
-
- create_int_parameter (u->local_name[0] ? u->local_name
- : symbol[i].name,
- symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
- symbol[i].id);
- }
- else
+ for (i = 0; symbol[i].name; i++)
{
- for (i = 0; symbol[i].name; i++)
+ bool found = false;
+ for (u = gfc_rename_list; u; u = u->next)
{
- local_name = NULL;
-
- for (u = gfc_rename_list; u; u = u->next)
+ if (strcmp (symbol[i].name, u->use_name) == 0)
{
- if (strcmp (symbol[i].name, u->use_name) == 0)
+ found = true;
+ 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)
+ 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",
+ gfc_option.flag_default_integer
+ ? "-fdefault-integer-8"
+ : "-fdefault-real-8");
+ switch (symbol[i].id)
{
- local_name = u->local_name;
- u->found = 1;
+#define NAMED_INTCST(a,b,c,d) \
+ case a:
+#include "iso-fortran-env.def"
+#undef NAMED_INTCST
+ create_int_parameter (u->local_name[0] ? u->local_name
+ : u->use_name,
+ symbol[i].value, mod,
+ INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
break;
+
+#define NAMED_KINDARRAY(a,b,KINDS,d) \
+ case a:\
+ expr = gfc_get_array_expr (BT_INTEGER, \
+ gfc_default_integer_kind,\
+ NULL); \
+ for (j = 0; KINDS[j].kind != 0; j++) \
+ gfc_constructor_append_expr (&expr->value.constructor, \
+ gfc_get_int_expr (gfc_default_integer_kind, NULL, \
+ KINDS[j].kind), NULL); \
+ create_int_parameter_array (u->local_name[0] ? u->local_name \
+ : u->use_name, \
+ j, expr, mod, \
+ INTMOD_ISO_FORTRAN_ENV, \
+ symbol[i].id); \
+ break;
+#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 ();
}
}
+ }
- if (u && gfc_notify_std (symbol[i].standard, "The symbol '%s', "
- "referrenced at %C, is not in the selected "
- "standard", symbol[i].name) == FAILURE)
- continue;
- else if ((gfc_option.allow_std & symbol[i].standard) == 0)
+ if (!found && !only_flag)
+ {
+ if ((gfc_option.allow_std & symbol[i].standard) == 0)
continue;
if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
gfc_option.flag_default_integer
? "-fdefault-integer-8" : "-fdefault-real-8");
- create_int_parameter (local_name ? local_name : symbol[i].name,
- symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
- symbol[i].id);
+ switch (symbol[i].id)
+ {
+#define NAMED_INTCST(a,b,c,d) \
+ case a:
+#include "iso-fortran-env.def"
+#undef NAMED_INTCST
+ create_int_parameter (symbol[i].name, symbol[i].value, mod,
+ INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
+ break;
+
+#define NAMED_KINDARRAY(a,b,KINDS,d) \
+ case a:\
+ expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
+ NULL); \
+ for (j = 0; KINDS[j].kind != 0; j++) \
+ gfc_constructor_append_expr (&expr->value.constructor, \
+ gfc_get_int_expr (gfc_default_integer_kind, NULL, \
+ KINDS[j].kind), NULL); \
+ create_int_parameter_array (symbol[i].name, j, expr, mod, \
+ INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
+ break;
+#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 (u = gfc_rename_list; u; u = u->next)
- {
- if (u->found)
- continue;
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (u->found)
+ continue;
- gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
+ gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
"module ISO_FORTRAN_ENV", u->use_name, &u->where);
- }
}
}
"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);
}
}