/* 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.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
/* The syntax of gfortran modules resembles that of lisp lists, ie a
sequence of atoms, which can be left or right parenthesis, names,
( ( <common name> <symbol> <saved flag>)
...
)
+
+ ( equivalence list )
+
( <Symbol Number (in no particular order)>
<True name of symbol>
<Module name of symbol>
/* 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;
cleanup:
free_rename ();
return MATCH_ERROR;
-}
+ }
-/* Given a name, return the name under which to load this symbol.
- Returns NULL if this symbol shouldn't be loaded. */
+/* Given a name and a number, inst, return the inst name
+ under which to load this symbol. Returns NULL if this
+ symbol shouldn't be loaded. If inst is zero, returns
+ the number of instances of this name. */
static const char *
-find_use_name (const char *name)
+find_use_name_n (const char *name, int *inst)
{
gfc_use_rename *u;
+ int i;
+ i = 0;
for (u = gfc_rename_list; u; u = u->next)
- if (strcmp (u->use_name, name) == 0)
- break;
+ {
+ if (strcmp (u->use_name, name) != 0)
+ continue;
+ if (++i == *inst)
+ break;
+ }
+
+ if (!*inst)
+ {
+ *inst = i;
+ return NULL;
+ }
if (u == NULL)
return only_flag ? NULL : name;
return (u->local_name[0] != '\0') ? u->local_name : name;
}
+/* Given a name, return the name under which to load this symbol.
+ Returns NULL if this symbol shouldn't be loaded. */
+
+static const char *
+find_use_name (const char *name)
+{
+ int i = 1;
+ return find_use_name_n (name, &i);
+}
+
+/* Given a real name, return the number of use names associated
+ with it. */
+
+static int
+number_use_names (const char *name)
+{
+ int i = 0;
+ const char *c;
+ c = find_use_name_n (name, &i);
+ return i;
+}
+
/* Try to find the operator in the current list. */
static void bad_module (const char *) ATTRIBUTE_NORETURN;
static void
-bad_module (const char *message)
+bad_module (const char *msgid)
{
- const char *p;
+ fclose (module_fp);
switch (iomode)
{
case IO_INPUT:
- p = "Reading";
+ gfc_fatal_error ("Reading module %s at line %d column %d: %s",
+ module_name, module_line, module_column, msgid);
break;
case IO_OUTPUT:
- p = "Writing";
+ gfc_fatal_error ("Writing module %s at line %d column %d: %s",
+ module_name, module_line, module_column, msgid);
break;
default:
- p = "???";
+ gfc_fatal_error ("Module %s at line %d column %d: %s",
+ module_name, module_line, module_column, msgid);
break;
}
-
- fclose (module_fp);
-
- gfc_fatal_error ("%s module %s at line %d column %d: %s", p,
- module_name, module_line, module_column, message);
}
switch (type)
{
case ATOM_NAME:
- p = "Expected name";
+ p = _("Expected name");
break;
case ATOM_LPAREN:
- p = "Expected left parenthesis";
+ p = _("Expected left parenthesis");
break;
case ATOM_RPAREN:
- p = "Expected right parenthesis";
+ p = _("Expected right parenthesis");
break;
case ATOM_INTEGER:
- p = "Expected integer";
+ p = _("Expected integer");
break;
case ATOM_STRING:
- p = "Expected string";
+ p = _("Expected string");
break;
default:
gfc_internal_error ("require_atom(): bad atom type required");
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;
}
+/* Read and write namelists */
+
+static void
+mio_namelist (gfc_symbol * sym)
+{
+ gfc_namelist *n, *m;
+ const char *check_name;
+
+ mio_lparen ();
+
+ if (iomode == IO_OUTPUT)
+ {
+ for (n = sym->namelist; n; n = n->next)
+ mio_symbol_ref (&n->sym);
+ }
+ else
+ {
+ /* This departure from the standard is flagged as an error.
+ It does, in fact, work correctly. TODO: Allow it
+ conditionally? */
+ if (sym->attr.flavor == FL_NAMELIST)
+ {
+ check_name = find_use_name (sym->name);
+ if (check_name && strcmp (check_name, sym->name) != 0)
+ gfc_error("Namelist %s cannot be renamed by USE"
+ " association to %s",
+ sym->name, check_name);
+ }
+
+ m = NULL;
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ n = gfc_get_namelist ();
+ mio_symbol_ref (&n->sym);
+
+ if (sym->namelist == NULL)
+ sym->namelist = n;
+ else
+ m->next = n;
+
+ m = n;
+ }
+ sym->namelist_tail = m;
+ }
+
+ mio_rparen ();
+}
+
+
/* Save/restore lists of gfc_interface stuctures. When loading an
interface, we are really appending to the existing list of
interfaces. Checking for duplicate and ambiguous interfaces has to
mio_symbol_ref (&sym->result);
+ if (sym->attr.cray_pointee)
+ mio_symbol_ref (&sym->cp_pointer);
+
/* Note that components are always saved, even if they are supposed
to be private. Component access is checked during searching. */
sym->component_access =
MIO_NAME(gfc_access) (sym->component_access, access_types);
+ mio_namelist (sym);
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. The flag in_load_equiv informs
+ mio_expr_ref of this so that unused variables are not loaded and
+ so that the expression can be safely freed.*/
+
+static void
+load_equiv(void)
+{
+ gfc_equiv *head, *tail, *end, *eq;
+ bool unused;
+
+ mio_lparen();
+ in_load_equiv = true;
+
+ end = gfc_current_ns->equiv;
+ while(end != NULL && end->next != NULL)
+ end = end->next;
+
+ while(peek_atom() != ATOM_RPAREN) {
+ mio_lparen();
+ head = tail = NULL;
+
+ while(peek_atom() != ATOM_RPAREN)
+ {
+ if (head == NULL)
+ head = tail = gfc_get_equiv();
+ else
+ {
+ tail->eq = gfc_get_equiv();
+ tail = tail->eq;
+ }
+
+ mio_pool_string(&tail->module);
+ mio_expr(&tail->expr);
+ }
+
+ /* Unused variables have no symtree. */
+ unused = false;
+ for (eq = head; eq; eq = eq->eq)
+ {
+ if (!eq->expr->symtree)
+ {
+ unused = true;
+ break;
+ }
+ }
+
+ if (unused)
+ {
+ for (eq = head; eq; eq = head)
+ {
+ head = eq->eq;
+ gfc_free_expr (eq->expr);
+ gfc_free (eq);
+ }
+ }
+
+ if (end == NULL)
+ gfc_current_ns->equiv = head;
+ else
+ end->next = head;
+
+ if (head != NULL)
+ end = head;
+
+ mio_rparen();
+ }
+
+ mio_rparen();
+ in_load_equiv = false;
+}
/* Recursive function to traverse the pointer_info tree and load a
needed symbol. We return nonzero if we load a symbol and stop the
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;
+ int ambiguous, j, nuse, symbol;
pointer_info *info;
gfc_use_rename *u;
gfc_symtree *st;
get_module_locus (&user_operators);
skip_list ();
skip_list ();
+
+ /* Skip commons and equivalences for now. */
+ skip_list ();
skip_list ();
mio_lparen ();
skip_list ();
/* See if the symbol has already been loaded by a previous module.
- If so, we reference the existing symbol and prevent it from
- being loaded again. */
+ If so, we reference the existing symbol and prevent it from
+ being loaded again. This should not happen if the symbol being
+ read is an index for an assumed shape dummy array (ns != 1). */
sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
- if (sym == NULL)
+
+ if (sym == NULL
+ || (sym->attr.flavor == FL_VARIABLE
+ && info->u.rsym.ns !=1))
continue;
info->u.rsym.state = USED;
info = get_integer (symbol);
- /* Get the local name for this symbol. */
- p = find_use_name (name);
-
- /* Skip symtree nodes not in an ONLY caluse. */
- if (p == NULL)
- continue;
-
- /* Check for ambiguous symbols. */
- st = gfc_find_symtree (gfc_current_ns->sym_root, p);
+ /* See how many use names there are. If none, go through the start
+ of the loop at least once. */
+ nuse = number_use_names (name);
+ if (nuse == 0)
+ nuse = 1;
- if (st != NULL)
- {
- if (st->n.sym != info->u.rsym.sym)
- st->ambiguous = 1;
- info->u.rsym.symtree = st;
- }
- else
+ for (j = 1; j <= nuse; j++)
{
- /* Create a symtree node in the current namespace for this symbol. */
- st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) :
- gfc_new_symtree (&gfc_current_ns->sym_root, p);
+ /* Get the jth local name for this symbol. */
+ p = find_use_name_n (name, &j);
- st->ambiguous = ambiguous;
+ /* Skip symtree nodes not in an ONLY clause. */
+ if (p == NULL)
+ continue;
- sym = info->u.rsym.sym;
+ /* Check for ambiguous symbols. */
+ st = gfc_find_symtree (gfc_current_ns->sym_root, p);
- /* Create a symbol node if it doesn't already exist. */
- if (sym == NULL)
+ if (st != NULL)
{
- sym = info->u.rsym.sym =
- gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns);
-
- sym->module = gfc_get_string (info->u.rsym.module);
+ if (st->n.sym != info->u.rsym.sym)
+ st->ambiguous = 1;
+ info->u.rsym.symtree = st;
}
+ else
+ {
+ /* Create a symtree node in the current namespace for this symbol. */
+ st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) :
+ gfc_new_symtree (&gfc_current_ns->sym_root, p);
- st->n.sym = sym;
- st->n.sym->refs++;
+ st->ambiguous = ambiguous;
- /* Store the symtree pointing to this symbol. */
- info->u.rsym.symtree = st;
+ sym = info->u.rsym.sym;
- if (info->u.rsym.state == UNUSED)
- info->u.rsym.state = NEEDED;
- info->u.rsym.referenced = 1;
+ /* Create a symbol node if it doesn't already exist. */
+ if (sym == NULL)
+ {
+ sym = info->u.rsym.sym =
+ gfc_new_symbol (info->u.rsym.true_name,
+ gfc_current_ns);
+
+ sym->module = gfc_get_string (info->u.rsym.module);
+ }
+
+ st->n.sym = sym;
+ st->n.sym->refs++;
+
+ /* Store the symtree pointing to this symbol. */
+ info->u.rsym.symtree = st;
+
+ if (info->u.rsym.state == UNUSED)
+ info->u.rsym.state = NEEDED;
+ info->u.rsym.referenced = 1;
+ }
}
}
load_generic_interfaces ();
load_commons ();
+ load_equiv();
/* At this point, we read those symbols that are needed but haven't
been loaded yet. If one symbol requires another, the other gets
/* 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;
}
write_common (gfc_symtree *st)
{
gfc_common_head *p;
+ const char * name;
+ int flags;
if (st == NULL)
return;
write_common(st->right);
mio_lparen();
- mio_pool_string(&st->name);
+
+ /* Write the unmangled name. */
+ name = st->n.common->name;
+
+ mio_pool_string(&name);
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 the blank common block to the module */
+
+static void
+write_blank_common (void)
+{
+ const char * name = BLANK_COMMON_NAME;
+ int saved;
+
+ if (gfc_current_ns->blank_common.head == NULL)
+ return;
+
+ mio_lparen();
+
+ mio_pool_string(&name);
+
+ mio_symbol_ref(&gfc_current_ns->blank_common.head);
+ saved = gfc_current_ns->blank_common.saved;
+ mio_integer(&saved);
mio_rparen();
}
+/* Write equivalences to the module. */
+
+static void
+write_equiv(void)
+{
+ gfc_equiv *eq, *e;
+ int num;
+
+ num = 0;
+ for(eq=gfc_current_ns->equiv; eq; eq=eq->next)
+ {
+ mio_lparen();
+
+ for(e=eq; e; e=e->eq)
+ {
+ if (e->module == NULL)
+ e->module = gfc_get_string("%s.eq.%d", module_name, num);
+ mio_allocated_string(e->module);
+ mio_expr(&e->expr);
+ }
+
+ num++;
+ mio_rparen();
+ }
+}
/* Write a symbol to the module. */
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);
write_char ('\n');
mio_lparen ();
+ write_blank_common ();
write_common (gfc_current_ns->common_root);
mio_rparen ();
write_char ('\n');
write_char ('\n');
+ mio_lparen();
+ write_equiv();
+ mio_rparen();
+ write_char('\n'); write_char('\n');
+
/* Write symbol information. First we traverse all symbols in the
primary namespace, writing those that need to be written.
Sometimes writing one symbol will cause another to need to be
void
gfc_dump_module (const char *name, int dump_flag)
{
- char filename[PATH_MAX], *p;
+ int n;
+ char *filename, *p;
time_t now;
- filename[0] = '\0';
+ n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
if (gfc_option.module_dir != NULL)
- strcpy (filename, gfc_option.module_dir);
-
- strcat (filename, name);
+ {
+ filename = (char *) alloca (n + strlen (gfc_option.module_dir));
+ strcpy (filename, gfc_option.module_dir);
+ strcat (filename, name);
+ }
+ else
+ {
+ filename = (char *) alloca (n);
+ strcpy (filename, name);
+ }
strcat (filename, MODULE_EXTENSION);
if (!dump_flag)
}
+/* Add an integer named constant from a given module. */
+static void
+create_int_parameter (const char *name, int value, const char *modname)
+{
+ gfc_symtree * tmp_symtree;
+ gfc_symbol * sym;
+
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (tmp_symtree != NULL)
+ {
+ if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+ return;
+ else
+ gfc_error ("Symbol '%s' already declared", name);
+ }
+
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
+ sym = tmp_symtree->n.sym;
+
+ sym->module = gfc_get_string (modname);
+ sym->attr.flavor = FL_PARAMETER;
+ sym->ts.type = BT_INTEGER;
+ sym->ts.kind = gfc_default_integer_kind;
+ sym->value = gfc_int_expr (value);
+ sym->attr.use_assoc = 1;
+}
+
+/* USE the ISO_FORTRAN_ENV intrinsic module. */
+static void
+use_iso_fortran_env_module (void)
+{
+ static char mod[] = "iso_fortran_env";
+ const char *local_name;
+ gfc_use_rename *u;
+ gfc_symbol *mod_sym;
+ gfc_symtree *mod_symtree;
+ int i;
+
+ mstring symbol[] = {
+#define NAMED_INTCST(a,b,c) minit(b,0),
+#include "iso-fortran-env.def"
+#undef NAMED_INTCST
+ minit (NULL, -1234) };
+
+ i = 0;
+#define NAMED_INTCST(a,b,c) symbol[i++].tag = c;
+#include "iso-fortran-env.def"
+#undef NAMED_INTCST
+
+ /* Generate the symbol for the module itself. */
+ mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
+ if (mod_symtree == NULL)
+ {
+ gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
+ gcc_assert (mod_symtree);
+ mod_sym = mod_symtree->n.sym;
+
+ mod_sym->attr.flavor = FL_MODULE;
+ mod_sym->attr.intrinsic = 1;
+ mod_sym->module = gfc_get_string (mod);
+ }
+ else
+ if (!mod_symtree->n.sym->attr.intrinsic)
+ gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
+ "non-intrinsic module name used previously", mod);
+
+ /* Generate the symbols for the module integer named constants. */
+ if (only_flag)
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ for (i = 0; symbol[i].string; i++)
+ if (strcmp (symbol[i].string, u->use_name) == 0)
+ break;
+
+ if (symbol[i].string == NULL)
+ {
+ gfc_error ("Symbol '%s' referenced at %L does not exist in "
+ "intrinsic module ISO_FORTRAN_ENV", u->use_name,
+ &u->where);
+ continue;
+ }
+
+ if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
+ && strcmp (symbol[i].string, "numeric_storage_size") == 0)
+ gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
+ "from intrinsic module ISO_FORTRAN_ENV at %L is "
+ "incompatible with option %s", &u->where,
+ gfc_option.flag_default_integer
+ ? "-fdefault-integer-8" : "-fdefault-real-8");
+
+ create_int_parameter (u->local_name[0] ? u->local_name
+ : symbol[i].string,
+ symbol[i].tag, mod);
+ }
+ else
+ {
+ for (i = 0; symbol[i].string; i++)
+ {
+ local_name = NULL;
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (strcmp (symbol[i].string, u->use_name) == 0)
+ {
+ local_name = u->local_name;
+ u->found = 1;
+ break;
+ }
+ }
+
+ if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
+ && strcmp (symbol[i].string, "numeric_storage_size") == 0)
+ gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
+ "from intrinsic module ISO_FORTRAN_ENV at %C is "
+ "incompatible with option %s",
+ gfc_option.flag_default_integer
+ ? "-fdefault-integer-8" : "-fdefault-real-8");
+
+ create_int_parameter (local_name ? local_name : symbol[i].string,
+ symbol[i].tag, mod);
+ }
+
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (u->found)
+ continue;
+
+ gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
+ "module ISO_FORTRAN_ENV", u->use_name, &u->where);
+ }
+ }
+}
+
/* Process a USE directive. */
void
gfc_use_module (void)
{
- char filename[GFC_MAX_SYMBOL_LEN + 5];
+ char *filename;
gfc_state_data *p;
- int c, line;
+ int c, line, start;
+ gfc_symtree *mod_symtree;
+ filename = (char *) alloca(strlen(module_name) + strlen(MODULE_EXTENSION)
+ + 1);
strcpy (filename, module_name);
strcat (filename, MODULE_EXTENSION);
- module_fp = gfc_open_included_file (filename);
+ /* First, try to find an non-intrinsic module, unless the USE statement
+ specified that the module is intrinsic. */
+ module_fp = NULL;
+ if (!specified_int)
+ module_fp = gfc_open_included_file (filename, true, true);
+
+ /* Then, see if it's an intrinsic one, unless the USE statement
+ specified that the module is non-intrinsic. */
+ if (module_fp == NULL && !specified_nonint)
+ {
+ if (strcmp (module_name, "iso_fortran_env") == 0
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
+ "ISO_FORTRAN_ENV intrinsic module at %C") != FAILURE)
+ {
+ use_iso_fortran_env_module ();
+ return;
+ }
+
+ module_fp = gfc_open_intrinsic_module (filename);
+
+ if (module_fp == NULL && specified_int)
+ gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
+ module_name);
+ }
+
if (module_fp == NULL)
gfc_fatal_error ("Can't open module file '%s' for reading 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
