/* 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.
( ( <common name> <symbol> <saved flag>)
...
)
+
+ ( equivalence list )
+
( <Symbol Number (in no particular order)>
<True name of symbol>
<Module name of symbol>
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;
+
/*****************************************************************/
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");
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_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
+ AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP, AB_VOLATILE
}
ab_attribute;
minit ("OPTIONAL", AB_OPTIONAL),
minit ("POINTER", AB_POINTER),
minit ("SAVE", AB_SAVE),
+ 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->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_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;
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. */
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);
+ /* 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;
- /* 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);
-
- if (st != NULL)
+ for (j = 1; j <= nuse; j++)
{
- 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);
+ /* 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->ambiguous = ambiguous;
+
+ sym = info->u.rsym.sym;
+
+ /* 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++;
+ st->n.sym = sym;
+ st->n.sym->refs++;
- /* Store the symtree pointing to this symbol. */
- info->u.rsym.symtree = st;
+ /* 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;
+ 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
{
char *filename;
gfc_state_data *p;
- int c, line;
+ int c, line, start;
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);
+ module_fp = gfc_open_included_file (filename, true);
if (module_fp == NULL)
gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
filename, strerror (errno));
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
