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_IMPLICIT_PURE
+ AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY
}
ab_attribute;
static const mstring attr_bits[] =
{
minit ("ALLOCATABLE", AB_ALLOCATABLE),
+ minit ("ARTIFICIAL", AB_ARTIFICIAL),
minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
minit ("DIMENSION", AB_DIMENSION),
minit ("CODIMENSION", AB_CODIMENSION),
minit ("VTAB", AB_VTAB),
minit ("CLASS_POINTER", AB_CLASS_POINTER),
minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
+ minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
minit (NULL, -1)
};
{
if (attr->allocatable)
MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
+ if (attr->artificial)
+ MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits);
if (attr->asynchronous)
MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
if (attr->dimension)
MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
if (attr->implicit_pure)
MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
+ if (attr->unlimited_polymorphic)
+ MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits);
if (attr->recursive)
MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
if (attr->always_explicit)
case AB_ALLOCATABLE:
attr->allocatable = 1;
break;
+ case AB_ARTIFICIAL:
+ attr->artificial = 1;
+ break;
case AB_ASYNCHRONOUS:
attr->asynchronous = 1;
break;
case AB_IMPLICIT_PURE:
attr->implicit_pure = 1;
break;
+ case AB_UNLIMITED_POLY:
+ attr->unlimited_polymorphic = 1;
+ break;
case AB_RECURSIVE:
attr->recursive = 1;
break;
if (iomode == IO_OUTPUT)
{
+ int rank;
+
if (*asp == NULL)
goto done;
as = *asp;
+
+ /* mio_integer expects nonnegative values. */
+ rank = as->rank > 0 ? as->rank : 0;
+ mio_integer (&rank);
}
else
{
}
*asp = as = gfc_get_array_spec ();
+ mio_integer (&as->rank);
}
- mio_integer (&as->rank);
mio_integer (&as->corank);
as->type = MIO_NAME (array_type) (as->type, array_spec_types);
+ if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK)
+ as->rank = -1;
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_expr (&as->upper[i]);
- }
+ if (as->rank + as->corank > 0)
+ for (i = 0; i < as->rank + as->corank; i++)
+ {
+ mio_expr (&as->lower[i]);
+ mio_expr (&as->upper[i]);
+ }
done:
mio_rparen ();
c->attr.class_ok = 1;
c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
- if (!vtype)
+ if (!vtype || strcmp (c->name, "_final") == 0
+ || strcmp (c->name, "_hash") == 0)
mio_expr (&c->initializer);
if (c->attr.proc_pointer)
{
mio_namespace_ref (&sym->formal_ns);
if (sym->formal_ns)
- {
- sym->formal_ns->proc_name = sym;
- sym->refs++;
- }
+ sym->formal_ns->proc_name = sym;
}
/* Save/restore common block links. */
module_locus locus;
symbol_attribute attr;
- if (st_sym->ns->proc_name && st_sym->name == st_sym->ns->proc_name->name)
+ if (st_sym->name == gfc_current_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);
if (p == NULL)
{
st = gfc_find_symtree (gfc_current_ns->sym_root, name);
- if (st != NULL)
- info->u.rsym.symtree = st;
+ if (st != NULL
+ && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
+ && st->n.sym->module != NULL
+ && strcmp (st->n.sym->module, info->u.rsym.module) == 0)
+ {
+ info->u.rsym.symtree = st;
+ info->u.rsym.sym = st->n.sym;
+ }
continue;
}
/* Check for ambiguous symbols. */
if (check_for_ambiguous (st->n.sym, info))
st->ambiguous = 1;
- info->u.rsym.symtree = st;
+ else
+ info->u.rsym.symtree = st;
}
else
{
}
-/* Recursive traversal function to write the secondary set of symbols
- to the module file. These are symbols that were not public yet are
- needed by the public symbols or another dependent symbol. The act
- of writing a symbol can modify the pointer_info tree, so we cease
- traversal if we find a symbol to write. We return nonzero if a
- symbol was written and pass that information upwards. */
+/* Type for the temporary tree used when writing secondary symbols. */
+
+struct sorted_pointer_info
+{
+ BBT_HEADER (sorted_pointer_info);
+
+ pointer_info *p;
+};
+
+#define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
+
+/* Recursively traverse the temporary tree, free its contents. */
+
+static void
+free_sorted_pointer_info_tree (sorted_pointer_info *p)
+{
+ if (!p)
+ return;
+
+ free_sorted_pointer_info_tree (p->left);
+ free_sorted_pointer_info_tree (p->right);
+
+ free (p);
+}
+
+/* Comparison function for the temporary tree. */
static int
-write_symbol1 (pointer_info *p)
+compare_sorted_pointer_info (void *_spi1, void *_spi2)
{
- int result;
+ sorted_pointer_info *spi1, *spi2;
+ spi1 = (sorted_pointer_info *)_spi1;
+ spi2 = (sorted_pointer_info *)_spi2;
+
+ if (spi1->p->integer < spi2->p->integer)
+ return -1;
+ if (spi1->p->integer > spi2->p->integer)
+ return 1;
+ return 0;
+}
+
+/* Finds the symbols that need to be written and collects them in the
+ sorted_pi tree so that they can be traversed in an order
+ independent of memory addresses. */
+
+static void
+find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
+{
+ if (!p)
+ return;
+
+ if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE)
+ {
+ sorted_pointer_info *sp = gfc_get_sorted_pointer_info();
+ sp->p = p;
+
+ gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
+ }
+
+ find_symbols_to_write (tree, p->left);
+ find_symbols_to_write (tree, p->right);
+}
+
+
+/* Recursive function that traverses the tree of symbols that need to be
+ written and writes them in order. */
+
+static void
+write_symbol1_recursion (sorted_pointer_info *sp)
+{
+ if (!sp)
+ return;
+
+ write_symbol1_recursion (sp->left);
+
+ pointer_info *p1 = sp->p;
+ gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE);
+
+ p1->u.wsym.state = WRITTEN;
+ write_symbol (p1->integer, p1->u.wsym.sym);
+ p1->u.wsym.sym->attr.public_used = 1;
+
+ write_symbol1_recursion (sp->right);
+}
+
+
+/* Write the secondary set of symbols to the module file. These are
+ symbols that were not public yet are needed by the public symbols
+ or another dependent symbol. The act of writing a symbol can add
+ symbols to the pointer_info tree, so we return nonzero if a symbol
+ was written and pass that information upwards. The caller will
+ then call this function again until nothing was written. It uses
+ the utility functions and a temporary tree to ensure a reproducible
+ ordering of the symbol output and thus the module file. */
+
+static int
+write_symbol1 (pointer_info *p)
+{
if (!p)
return 0;
- result = write_symbol1 (p->left);
+ /* Put symbols that need to be written into a tree sorted on the
+ integer field. */
- if (!(p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE))
- {
- p->u.wsym.state = WRITTEN;
- write_symbol (p->integer, p->u.wsym.sym);
- result = 1;
- }
+ sorted_pointer_info *spi_root = NULL;
+ find_symbols_to_write (&spi_root, p);
+
+ /* No symbols to write, return. */
+ if (!spi_root)
+ return 0;
+
+ /* Otherwise, write and free the tree again. */
+ write_symbol1_recursion (spi_root);
+ free_sorted_pointer_info_tree (spi_root);
- result |= write_symbol1 (p->right);
- return result;
+ return 1;
}
return;
write_generic (st->left);
- write_generic (st->right);
sym = st->n.sym;
- if (!sym || check_unique_name (st->name))
- return;
-
- if (sym->generic == NULL || !gfc_check_symbol_access (sym))
- return;
+ if (sym && !check_unique_name (st->name)
+ && sym->generic && gfc_check_symbol_access (sym))
+ {
+ if (!sym->module)
+ sym->module = module_name;
- if (sym->module == NULL)
- sym->module = module_name;
+ mio_symbol_interface (&st->name, &sym->module, &sym->generic);
+ }
- mio_symbol_interface (&st->name, &sym->module, &sym->generic);
+ write_generic (st->right);
}
"intrinsic module at %C") != FAILURE)
{
use_iso_fortran_env_module ();
+ free_rename (module->rename);
+ module->rename = NULL;
gfc_current_locus = old_locus;
module->intrinsic = true;
return;
"ISO_C_BINDING module at %C") != FAILURE)
{
import_iso_c_binding_module();
+ free_rename (module->rename);
+ module->rename = NULL;
gfc_current_locus = old_locus;
module->intrinsic = true;
return;
next = module_list->next;
rename_list_remove_duplicate (module_list->rename);
gfc_use_module (module_list);
- if (module_list->intrinsic)
- free_rename (module_list->rename);
free (module_list);
}
gfc_rename_list = NULL;