/* Handle modules, which amounts to loading and saving symbols and
their attendant structures.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 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.
/* 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;
+
/*****************************************************************/
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;
typedef enum
{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
- AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT,
- AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON,
- AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
- AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT
+ AB_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 ("RESULT", AB_RESULT),
minit ("DATA", AB_DATA),
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)
};
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->result)
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_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;
}
}
}
{
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. */
mio_integer (&c->dimension);
mio_integer (&c->pointer);
+ mio_integer (&c->allocatable);
mio_expr (&c->initializer);
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;
minit ("LT", INTRINSIC_LT),
minit ("LE", INTRINSIC_LE),
minit ("NOT", INTRINSIC_NOT),
+ minit ("PARENTHESES", INTRINSIC_PARENTHESES),
minit (NULL, -1)
};
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
case INTRINSIC_NOT:
+ case INTRINSIC_PARENTHESES:
mio_expr (&e->value.op.op1);
break;
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.",
+ " association to %s",
sym->name, check_name);
}
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. */
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 ();
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 (&p->saved);
+ 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. */
+/* 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;
+ 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)
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;
- end = 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
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;
const char *p;
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_intrinsic_op i;
- int ambiguous, symbol, j, nuse;
+ int ambiguous, j, nuse, symbol;
pointer_info *info;
gfc_use_rename *u;
gfc_symtree *st;
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;
if (sym == NULL)
{
sym = info->u.rsym.sym =
- gfc_new_symbol (info->u.rsym.true_name
- , gfc_current_ns);
+ gfc_new_symbol (info->u.rsym.true_name,
+ gfc_current_ns);
sym->module = gfc_get_string (info->u.rsym.module);
}
/* Given an access type that is specific to an entity and the default
- access, return nonzero if the entity is publicly accessible. */
+ access, return nonzero if the entity is publicly accessible. If the
+ element is declared as PUBLIC, then it is public; if declared
+ PRIVATE, then private, and otherwise it is public unless the default
+ access in this context has been declared PRIVATE. */
bool
gfc_check_access (gfc_access specific_access, gfc_access default_access)
if (specific_access == ACCESS_PRIVATE)
return FALSE;
- if (gfc_option.flag_module_access_private)
- return default_access == ACCESS_PUBLIC;
- else
- return default_access != ACCESS_PRIVATE;
-
- return FALSE;
+ return default_access != ACCESS_PRIVATE;
}
{
gfc_common_head *p;
const char * name;
+ int flags;
if (st == NULL)
return;
p = st->n.common;
mio_symbol_ref(&p->head);
- mio_integer(&p->saved);
+ flags = p->saved ? 1 : 0;
+ if (p->threadprivate) flags |= 2;
+ mio_integer(&flags);
mio_rparen();
}
write_blank_common (void)
{
const char * name = BLANK_COMMON_NAME;
+ int saved;
if (gfc_current_ns->blank_common.head == NULL)
return;
mio_pool_string(&name);
mio_symbol_ref(&gfc_current_ns->blank_common.head);
- mio_integer(&gfc_current_ns->blank_common.saved);
+ saved = gfc_current_ns->blank_common.saved;
+ mio_integer(&saved);
mio_rparen();
}
if (p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE)
return 0;
- /* FIXME: This shouldn't be necessary, but it works around
- deficiencies in the module loader or/and symbol handling. */
- if (p->u.wsym.sym->module == NULL && p->u.wsym.sym->attr.dummy)
- p->u.wsym.sym->module = gfc_get_string (module_name);
-
p->u.wsym.state = WRITTEN;
write_symbol (p->integer, p->u.wsym.sym);
}
+/* 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
{
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 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
