This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
fix for the multiple-decl problem - please test
- From: Daniel Franke <franke dot daniel at gmail dot com>
- To: fortran at gcc dot gnu dot org
- Cc: "Richard Guenther" <richard dot guenther at gmail dot com>
- Date: Sat, 27 Dec 2008 19:23:28 +0100
- Subject: fix for the multiple-decl problem - please test
Hi all.
This is the first version of a patch for the multiple-decl problem as
discussed before. It enables middle-end optimizations as inlining, but does
not mark intent(in) arguments as TREE_CONSTANT yet (PR23169), nor does it
enables -fwhole-program. The final patch shall do both.
For now, I'd like to ask you to give it a spin on real-life sources and
benchmarks. I'd like to know if it works for you and if there is a measurable
gain from it, because ... although the results are quite promising, there is
one last test in the testsuite that still fails. It seems to be a
miscompilation of some sort. Here I'd need some help:
$> cat function_module_1.f90
module M1
INTEGER p
CONTAINS
subroutine AA ()
implicit NONE
p = BB ()
CONTAINS
function BB()
integer :: BB
BB = 1
end function
end subroutine
end module
program P1
USE M1
implicit none
p = 0
call AA ()
if (p /= 1) call abort
end
$> gfortran-svn -O1 -fdump-tree-optimized function_module_1.f90 && ./a.out
$> gfortran-svn -O2 -fdump-tree-optimized function_module_1.f90 && ./a.out
Aborted
The difference between -O1 and -O2 seems to be, that the CALL to AA is
inlined.
$> cat function_module_1.f90.123t.optimized
[...]
p1 ()
{
static integer(kind=4) bb (void);
static integer(kind=4) options.1[8] = {68, 255, 0, 0, 0, 1, 0, 1};
<bb 2>:
_gfortran_set_options (8, &options.1);
p = 0;
p = 1;
_gfortran_abort ();
}
Invalid sum of incoming frequencies 0, should be 9996
With -O1, there is no note about an "invalid sum of incoming frequencies".
Does this ring a bell anywhere? Richard?
Thanks
Daniel
Index: fortran/trans.h
===================================================================
--- fortran/trans.h (revision 142934)
+++ fortran/trans.h (working copy)
@@ -500,6 +500,7 @@ tree gfc_build_library_function_decl (tr
/* somewhere! */
tree pushdecl (tree);
tree pushdecl_top_level (tree);
+tree find_fndecl (tree name);
void pushlevel (int);
tree poplevel (int, int, int);
tree getdecls (void);
Index: fortran/f95-lang.c
===================================================================
--- fortran/f95-lang.c (revision 142934)
+++ fortran/f95-lang.c (working copy)
@@ -490,7 +490,6 @@ pushdecl (tree decl)
/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL. */
-
tree
pushdecl_top_level (tree x)
{
@@ -503,6 +502,25 @@ pushdecl_top_level (tree x)
return t;
}
+/* Look for a function decl with a given name. */
+tree
+find_fndecl (tree name)
+{
+ struct binding_level *b;
+ tree t;
+
+/* fprintf(stderr, "find_fndecl: looking for %s ... ", name->identifier.id.str); */
+ for (b = current_binding_level; b; b = b->level_chain)
+ for (t = b->names; t; t = TREE_CHAIN (t))
+ if (TREE_CODE (t) == FUNCTION_DECL && DECL_ASSEMBLER_NAME (t) == name) {
+/* fprintf(stderr, "found\n");*/
+ return t;
+ }
+
+/*fprintf(stderr, "not found\n");*/
+ return NULL_TREE;
+}
+
/* Clear the binding stack. */
static void
Index: fortran/trans-decl.c
===================================================================
--- fortran/trans-decl.c (revision 142934)
+++ fortran/trans-decl.c (working copy)
@@ -326,18 +326,58 @@ gfc_sym_mangled_function_id (gfc_symbol
/* use the binding label rather than the mangled name */
return get_identifier (sym->binding_label);
- if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
- || (sym->module != NULL && (sym->attr.external
- || sym->attr.if_source == IFSRC_IFBODY)))
- {
- /* Main program is mangled into MAIN__. */
- if (sym->attr.is_main_program)
- return get_identifier ("MAIN__");
+ /* Main program is mangled into MAIN__. */
+ if (sym->attr.is_main_program)
+ return get_identifier ("MAIN__");
- /* Intrinsic procedures are never mangled. */
- if (sym->attr.proc == PROC_INTRINSIC)
- return get_identifier (sym->name);
+ /* Intrinsic procedures are never mangled. */
+ if (sym->attr.proc == PROC_INTRINSIC)
+ return get_identifier (sym->name);
+
+ /* Procedures contained within module procedures. */
+ if (/*sym->module == NULL */
+ sym->attr.contained
+ && sym->attr.if_source == IFSRC_DECL
+ && sym->attr.proc == PROC_INTERNAL
+ && sym->ns->proc_name->attr.proc == PROC_MODULE
+ && sym->ns->proc_name->attr.flavor == FL_PROCEDURE
+ && sym->ns->proc_name->ns->proc_name
+ && sym->ns->proc_name->ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ snprintf (name, sizeof name, "__%s_MOD_%s_CONT_%s",
+ sym->ns->proc_name->ns->proc_name->name,
+ sym->ns->proc_name->name,
+ sym->name);
+ return get_identifier (name);
+ }
+ /* Module procedures. */
+ if (sym->module != NULL
+ && (sym->attr.if_source == IFSRC_DECL
+ || sym->attr.if_source == IFSRC_IFBODY)
+ && sym->attr.proc == PROC_MODULE
+ && sym->attr.flavor == FL_PROCEDURE
+ && !sym->attr.external)
+ {
+ snprintf (name, sizeof name, "__%s_MOD_%s",
+ sym->module, sym->name);
+ return get_identifier (name);
+ }
+
+ /* Procedures contained in external procedures. */
+ if (sym->module == NULL
+ && sym->attr.proc == PROC_INTERNAL)
+ {
+ snprintf (name, sizeof name, "__%s_CONT_%s",
+ sym->ns->proc_name->name, sym->name);
+ return get_identifier (name);
+ }
+
+ /* External procedures. */
+ if (sym->module == NULL
+ || sym->attr.external
+ || sym->attr.proc == PROC_EXTERNAL)
+ {
if (gfc_option.flag_underscoring)
{
has_underscore = strchr (sym->name, '_') != 0;
@@ -350,11 +390,8 @@ gfc_sym_mangled_function_id (gfc_symbol
else
return get_identifier (sym->name);
}
- else
- {
- snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
- return get_identifier (name);
- }
+
+ gcc_assert(!"name mangling incomplete");
}
@@ -1195,6 +1232,57 @@ get_proc_pointer_decl (gfc_symbol *sym)
}
+static tree
+build_result_decl(gfc_symbol *sym, tree fndecl)
+{
+ /* Figure out the return type of the declared function, and build a
+ RESULT_DECL for it. If this is a subroutine with alternate
+ returns, build a RESULT_DECL for it. */
+
+ tree type, result_decl = NULL_TREE;
+
+ /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
+ if (sym->attr.function)
+ {
+ if (gfc_return_by_reference (sym))
+ type = void_type_node;
+ else
+ {
+ if (sym->result != sym)
+ result_decl = gfc_sym_identifier (sym->result);
+
+ type = TREE_TYPE (TREE_TYPE (fndecl));
+ }
+ }
+ else
+ {
+ /* Look for alternate return placeholders. */
+ gfc_formal_arglist *f;
+ int has_alternate_returns = 0;
+
+ for (f = sym->formal; f; f = f->next)
+ {
+ if (f->sym == NULL)
+ {
+ has_alternate_returns = 1;
+ break;
+ }
+ }
+
+ if (has_alternate_returns)
+ type = integer_type_node;
+ else
+ type = void_type_node;
+ }
+
+ result_decl = build_decl (RESULT_DECL, result_decl, type);
+ DECL_ARTIFICIAL (result_decl) = 1;
+ DECL_IGNORED_P (result_decl) = 1;
+ return result_decl;
+}
+
+
+
/* Get a basic decl for an external function. */
tree
@@ -1275,16 +1363,55 @@ gfc_get_extern_function_decl (gfc_symbol
mangled_name = gfc_sym_mangled_function_id (sym);
}
- type = gfc_get_function_type (sym);
- fndecl = build_decl (FUNCTION_DECL, name, type);
+ /* We try to see if a function decl already exists with this name. */
+ fndecl = find_fndecl (mangled_name);
+ if (fndecl == NULL_TREE)
+ {
+ /* We need to create a new function decl. */
+ type = gfc_get_function_type (sym);
+ fndecl = build_decl (FUNCTION_DECL, name, type);
+ SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
- SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
- /* If the return type is a pointer, avoid alias issues by setting
- DECL_IS_MALLOC to nonzero. This means that the function should be
- treated as if it were a malloc, meaning it returns a pointer that
- is not an alias. */
- if (POINTER_TYPE_P (type))
- DECL_IS_MALLOC (fndecl) = 1;
+/*printf(" --> building decl for called function/subroutine: %s\n", mangled_name->identifier.id.str);*/
+
+ /* If the return type is a pointer, avoid alias issues by setting
+ DECL_IS_MALLOC to nonzero. This means that the function should be
+ treated as if it were a malloc, meaning it returns a pointer that
+ is not an alias. */
+ if (POINTER_TYPE_P (type))
+ DECL_IS_MALLOC (fndecl) = 1;
+
+ DECL_EXTERNAL (fndecl) = 1;
+
+ /* This specifies if a function is globally addressable, i.e. it is
+ the opposite of declaring static in C. */
+ TREE_PUBLIC (fndecl) = 1;
+
+ if (DECL_CONTEXT (fndecl) == NULL_TREE)
+ pushdecl_top_level (fndecl);
+ }
+ else
+ {
+ tree result_decl = build_result_decl(sym, fndecl);
+ type = gfc_get_function_type (sym);
+
+/*printf(" --> updating decl for called function/subroutine: %s\n", mangled_name->identifier.id.str);*/
+
+ /* Here we may update TYPE and RESULT information of an external call.
+ For example, if the symbol was used as an actual argument, its type
+ is a VOID_TYPE, however, it might be a function returning a REAL
+ value. To reflect this, the type is updated if necessary. */
+ if (VOID_TYPE_P(TREE_TYPE(TREE_TYPE(fndecl)))
+ && !VOID_TYPE_P(type))
+ TREE_TYPE (fndecl) = type;
+
+ if (DECL_RESULT(fndecl) == NULL_TREE
+ && result_decl != NULL_TREE)
+ {
+ DECL_CONTEXT (result_decl) = fndecl;
+ DECL_RESULT (fndecl) = result_decl;
+ }
+ }
/* Set the context of this decl. */
if (0 && sym->ns && sym->ns->proc_name)
@@ -1298,12 +1425,6 @@ gfc_get_extern_function_decl (gfc_symbol
DECL_CONTEXT (fndecl) = NULL_TREE;
}
- DECL_EXTERNAL (fndecl) = 1;
-
- /* This specifies if a function is globally addressable, i.e. it is
- the opposite of declaring static in C. */
- TREE_PUBLIC (fndecl) = 1;
-
/* Set attributes for PURE functions. A call to PURE function in the
Fortran 95 sense is both pure and without side effects in the C
sense. */
@@ -1311,6 +1432,7 @@ gfc_get_extern_function_decl (gfc_symbol
{
if (sym->attr.function && !gfc_return_by_reference (sym))
DECL_PURE_P (fndecl) = 1;
+
/* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
parameters and don't use alternate returns (is this
allowed?). In that case, calls to them are meaningless, and
@@ -1323,10 +1445,6 @@ gfc_get_extern_function_decl (gfc_symbol
TREE_THIS_VOLATILE(fndecl) = 1;
sym->backend_decl = fndecl;
-
- if (DECL_CONTEXT (fndecl) == NULL_TREE)
- pushdecl_top_level (fndecl);
-
return fndecl;
}
@@ -1338,10 +1456,7 @@ gfc_get_extern_function_decl (gfc_symbol
static void
build_function_decl (gfc_symbol * sym)
{
- tree fndecl, type;
- symbol_attribute attr;
- tree result_decl;
- gfc_formal_arglist *f;
+ tree fndecl, result_decl, name, mangled_name;
gcc_assert (!sym->backend_decl);
gcc_assert (!sym->attr.external);
@@ -1356,54 +1471,41 @@ build_function_decl (gfc_symbol * sym)
|| TREE_CODE (DECL_CONTEXT (current_function_decl))
== NAMESPACE_DECL);
- type = gfc_get_function_type (sym);
- fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
+ name = gfc_sym_identifier (sym);
+ mangled_name = gfc_sym_mangled_function_id (sym);
+ fndecl = find_fndecl (mangled_name);
- /* Perform name mangling if this is a top level or module procedure. */
- if (current_function_decl == NULL_TREE)
- SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
-
- /* Figure out the return type of the declared function, and build a
- RESULT_DECL for it. If this is a subroutine with alternate
- returns, build a RESULT_DECL for it. */
- attr = sym->attr;
+ /* If we have found a fndecl and it doesn't have a location,
+ it has to be a library function that we're compiling during
+ compilation of libgfortran. The debugger doesn't like that, so
+ we set the location. */
+ if (fndecl && DECL_IS_BUILTIN (fndecl))
+ gfc_set_decl_location (fndecl, &sym->declared_at);
- result_decl = NULL_TREE;
- /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
- if (attr.function)
+ if (fndecl == NULL_TREE)
{
- if (gfc_return_by_reference (sym))
- type = void_type_node;
- else
- {
- if (sym->result != sym)
- result_decl = gfc_sym_identifier (sym->result);
+ tree type = gfc_get_function_type (sym);
+ fndecl = build_decl (FUNCTION_DECL, name, type);
- type = TREE_TYPE (TREE_TYPE (fndecl));
- }
+ SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
+
+/*printf(" --> building decl for function/subroutine: %s\n", gfc_sym_mangled_function_id (sym)->identifier.id.str);*/
+
+ /* Layout the function declaration and put it in the binding level
+ of the current function. */
+ pushdecl (fndecl);
}
- else
+ else if (DECL_EXTERNAL (fndecl))
{
- /* Look for alternate return placeholders. */
- int has_alternate_returns = 0;
- for (f = sym->formal; f; f = f->next)
- {
- if (f->sym == NULL)
- {
- has_alternate_returns = 1;
- break;
- }
- }
+/*printf(" --> updating external decl for function/subroutine: %s\n", gfc_sym_mangled_function_id (sym)->identifier.id.str);*/
+ DECL_EXTERNAL (fndecl) = 0;
- if (has_alternate_returns)
- type = integer_type_node;
- else
- type = void_type_node;
+ /* A function that has been seen before, but without proper interface.
+ Here we add the information the explicit interface provides. */
+ TREE_TYPE (fndecl) = gfc_get_function_type (sym);
}
- result_decl = build_decl (RESULT_DECL, result_decl, type);
- DECL_ARTIFICIAL (result_decl) = 1;
- DECL_IGNORED_P (result_decl) = 1;
+ result_decl = build_result_decl(sym, fndecl);
DECL_CONTEXT (result_decl) = fndecl;
DECL_RESULT (fndecl) = result_decl;
@@ -1414,7 +1516,7 @@ build_function_decl (gfc_symbol * sym)
DECL_IS_MALLOC to nonzero. This means that the function should be
treated as if it were a malloc, meaning it returns a pointer that
is not an alias. */
- if (POINTER_TYPE_P (type))
+ if (POINTER_TYPE_P (DECL_RESULT (fndecl)))
DECL_IS_MALLOC (fndecl) = 1;
/* Set up all attributes for the function. */
@@ -1433,26 +1535,22 @@ build_function_decl (gfc_symbol * sym)
/* Set attributes for PURE functions. A call to a PURE function in the
Fortran 95 sense is both pure and without side effects in the C
sense. */
- if (attr.pure || attr.elemental)
+ if (sym->attr.pure || sym->attr.elemental)
{
/* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
including an alternate return. In that case it can also be
marked as PURE. See also in gfc_get_extern_function_decl(). */
- if (attr.function && !gfc_return_by_reference (sym))
+ if (sym->attr.function && !gfc_return_by_reference (sym))
DECL_PURE_P (fndecl) = 1;
TREE_SIDE_EFFECTS (fndecl) = 0;
}
/* For -fwhole-program to work well, the main program needs to have the
"externally_visible" attribute. */
- if (attr.is_main_program)
+ if (sym->attr.is_main_program)
DECL_ATTRIBUTES (fndecl)
= tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
- /* Layout the function declaration and put it in the binding level
- of the current function. */
- pushdecl (fndecl);
-
sym->backend_decl = fndecl;
}
Index: fortran/trans-types.c
===================================================================
--- fortran/trans-types.c (revision 142934)
+++ fortran/trans-types.c (working copy)
@@ -1727,47 +1727,165 @@ gfc_add_field_to_struct (tree *fieldlist
DECL_USER_ALIGN (decl) = 0;
TREE_CHAIN (decl) = NULL_TREE;
*fieldlist = chainon (*fieldlist, decl);
-
return decl;
}
-/* Copy the backend_decl and component backend_decls if
- the two derived type symbols are "equal", as described
- in 4.4.2 and resolved by gfc_compare_derived_types. */
+/* A linked list of derived types in the namespace. */
+typedef struct gfc_dtdecl_list
+{
+ struct gfc_symbol *derived;
+ struct gfc_dtdecl_list *next;
+}
+gfc_dtdecl_list;
+#define get_dtdecl_list() XCNEW (gfc_dtdecl_list)
+
+/* A list of all derived types. */
+static gfc_dtdecl_list *dtdecl_list;
-static int
-copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
+/* TODO: deep-copied symbols are never cleaned out.
+ De we need to free() them at some point? */
+static gfc_symbol*
+deep_copy_dt_symbol (gfc_symbol *src, gfc_namespace *ns)
{
- gfc_component *to_cm;
- gfc_component *from_cm;
+ gfc_symbol *dest;
+ gfc_namespace *dest_ns;
+ gfc_component *src_comp, *c, *dest_comp_tail;
- if (from->backend_decl == NULL
- || !gfc_compare_derived_types (from, to))
- return 0;
+ gcc_assert (src->attr.flavor == FL_DERIVED);
+
+ /* Use a local namespace to store/lookup nested symbols.
+ If the function is called recursively, ns is set.
+ Thus, if there are different global types with the same
+ name, they end up in different namespaces. */
+ dest_ns = ns ? ns : gfc_get_namespace (NULL, 0);
- to->backend_decl = from->backend_decl;
+ gfc_find_symbol (src->name, dest_ns, 0, &dest);
+ if (dest)
+ return dest;
- to_cm = to->components;
- from_cm = from->components;
+ gfc_get_symbol (src->name, dest_ns, &dest);
- /* Copy the component declarations. If a component is itself
- a derived type, we need a copy of its component declarations.
- This is done by recursing into gfc_get_derived_type and
- ensures that the component's component declarations have
- been built. If it is a character, we need the character
- length, as well. */
- for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
+ /* A new symbol was created. */
+ dest->component_access = src->component_access;
+ dest->attr = src->attr;
+ dest->mark = 1;
+
+ if (src->module)
+ dest->module = gfc_get_string (src->module);
+
+ if (src->backend_decl)
+ dest->backend_decl = src->backend_decl;
+
+ dest_comp_tail = NULL;
+ for (src_comp = src->components; src_comp; src_comp = src_comp->next)
{
- to_cm->backend_decl = from_cm->backend_decl;
- if (!from_cm->attr.pointer && from_cm->ts.type == BT_DERIVED)
- gfc_get_derived_type (to_cm->ts.derived);
+ c = gfc_get_component ();
+ c->name = gfc_get_string (src_comp->name);
+ c->loc = src_comp->loc;
+ c->attr = src_comp->attr;
+
+ if (src_comp->as)
+ c->as = gfc_copy_array_spec (src_comp->as);
+
+ if (src_comp->backend_decl)
+ c->backend_decl = src_comp->backend_decl;
+
+ c->ts.type = src_comp->ts.type;
+ c->ts.kind = src_comp->ts.kind;
+ c->ts.is_c_interop = src_comp->ts.is_c_interop;
+ c->ts.is_iso_c = src_comp->ts.is_iso_c;
+ c->ts.f90_type = src_comp->ts.f90_type;
+
+ if (src_comp->ts.cl)
+ {
+ c->ts.cl = gfc_get_charlen ();
+ c->ts.cl->length= gfc_copy_expr (src_comp->ts.cl->length);
+
+ if (src_comp->ts.cl->backend_decl)
+ c->ts.cl->backend_decl = src_comp->ts.cl->backend_decl;
+ }
+
+ if (src_comp->ts.derived
+ && src_comp->ts.derived != src)
+ c->ts.derived = deep_copy_dt_symbol (src_comp->ts.derived, dest_ns);
+
+ /* Finally, append component to symbol. */
+ if (dest_comp_tail == NULL)
+ dest->components = c;
+ else
+ dest_comp_tail->next = c;
+
+ dest_comp_tail = c;
+ }
+
+ gfc_commit_symbol (dest);
+
+ return dest;
+}
+
+static void
+add_dtdecl(gfc_symbol *derived)
+{
+ gfc_dtdecl_list *dt;
- else if (from_cm->ts.type == BT_CHARACTER)
- to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
+ for (dt = dtdecl_list; dt; dt = dt->next)
+ if (gfc_compare_derived_types(dt->derived, derived))
+ break;
+
+ if (dt == NULL)
+ {
+/* printf("adding derived type: %s\n", derived->name);*/
+ dt = get_dtdecl_list ();
+ dt->next = dtdecl_list;
+ dt->derived = deep_copy_dt_symbol (derived, NULL);
+ dtdecl_list = dt;
}
+/*else
+ printf("derived type already exists\n");*/
+}
+
+static void
+find_dtdecl (gfc_symbol *derived)
+{
+ gfc_dtdecl_list *dt;
+
+ for (dt = dtdecl_list; dt; dt = dt->next)
+ if (gfc_compare_derived_types(dt->derived, derived))
+ break;
+
+/*printf("looking for derived type: %s ... ", derived->name);*/
- return 1;
+ if (dt)
+ {
+ /* Copy the component declarations. If a component is itself
+ a derived type, we need a copy of its component declarations.
+ This is done by recursing into gfc_get_derived_type and
+ ensures that the component's component declarations have
+ been built. If it is a character, we need the character
+ length, as well. */
+
+ gfc_component *from = dt->derived->components,
+ *to = derived->components;
+
+ derived->backend_decl = dt->derived->backend_decl;
+
+/*printf("found\n");*/
+ for ( ; to && from; from = from->next, to = to->next)
+ {
+ to->backend_decl = from->backend_decl;
+/*printf("-------> component: %s\n", from->name);*/
+ if (from->ts.derived
+ && from->ts.derived->backend_decl)
+ {
+ gfc_get_derived_type (to->ts.derived);
+ }
+ else if (from->ts.type == BT_CHARACTER)
+ to->ts.cl->backend_decl = from->ts.cl->backend_decl;
+ }
+ }
+/*else
+ printf("not found\n");*/
}
@@ -1781,7 +1899,6 @@ gfc_get_derived_type (gfc_symbol * deriv
{
tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
gfc_component *c;
- gfc_dt_list *dt;
gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
@@ -1810,14 +1927,19 @@ gfc_get_derived_type (gfc_symbol * deriv
BT_INTEGER that needs to fit a void * for the purpose of the
iso_c_binding derived types. */
derived->ts.f90_type = BT_VOID;
-
+
return derived->backend_decl;
}
-
+
+ if (! derived->backend_decl)
+ find_dtdecl (derived);
+
/* derived->backend_decl != 0 means we saw it before, but its
components' backend_decl may have not been built. */
if (derived->backend_decl)
{
+/*printf("%s: decl found, fields available: %s\n", derived->name, (TYPE_FIELDS (derived->backend_decl) ? "yes" : "no"));*/
+
/* Its components' backend_decl have been built. */
if (TYPE_FIELDS (derived->backend_decl))
return derived->backend_decl;
@@ -1826,7 +1948,6 @@ gfc_get_derived_type (gfc_symbol * deriv
}
else
{
-
/* We see this derived type first time, so build the type node. */
typenode = make_node (RECORD_TYPE);
TYPE_NAME (typenode) = get_identifier (derived->name);
@@ -1866,7 +1987,10 @@ gfc_get_derived_type (gfc_symbol * deriv
}
if (TYPE_FIELDS (derived->backend_decl))
- return derived->backend_decl;
+ {
+ add_dtdecl (derived);
+ return derived->backend_decl;
+ }
/* Build the type member list. Install the newly created RECORD_TYPE
node as DECL_CONTEXT of each FIELD_DECL. */
@@ -1879,6 +2003,7 @@ gfc_get_derived_type (gfc_symbol * deriv
{
if (c->ts.type == BT_CHARACTER)
{
+/*printf("building character component: %s\n", c->name);*/
/* Evaluate the string length. */
gfc_conv_const_charlen (c->ts.cl);
gcc_assert (c->ts.cl->backend_decl);
@@ -1912,6 +2037,7 @@ gfc_get_derived_type (gfc_symbol * deriv
field = gfc_add_field_to_struct (&fieldlist, typenode,
get_identifier (c->name),
field_type);
+
if (c->loc.lb)
gfc_set_decl_location (field, &c->loc);
else if (derived->declared_at.lb)
@@ -1944,9 +2070,8 @@ gfc_get_derived_type (gfc_symbol * deriv
derived->backend_decl = typenode;
- /* Add this backend_decl to all the other, equal derived types. */
- for (dt = gfc_derived_types; dt; dt = dt->next)
- copy_dt_decls_ifequal (derived, dt->derived);
+ /* Add the symbol to the list of known types with a backend_decl. */
+ add_dtdecl (derived);
return derived->backend_decl;
}
Index: fortran/gfortran.h
===================================================================
--- fortran/gfortran.h (revision 142934)
+++ fortran/gfortran.h (working copy)
@@ -1218,19 +1218,6 @@ typedef struct gfc_symtree
}
gfc_symtree;
-/* A linked list of derived types in the namespace. */
-typedef struct gfc_dt_list
-{
- struct gfc_symbol *derived;
- struct gfc_dt_list *next;
-}
-gfc_dt_list;
-
-#define gfc_get_dt_list() XCNEW (gfc_dt_list)
-
- /* A list of all derived types. */
- extern gfc_dt_list *gfc_derived_types;
-
/* A namespace describes the contents of procedure, module or
interface block. */
/* ??? Anything else use these? */
Index: fortran/symbol.c
===================================================================
--- fortran/symbol.c (revision 142934)
+++ fortran/symbol.c (working copy)
@@ -98,9 +98,6 @@ gfc_gsymbol *gfc_gsym_root = NULL;
static gfc_symbol *changed_syms = NULL;
-gfc_dt_list *gfc_derived_types;
-
-
/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
/* The following static variable indicates whether a particular element has
@@ -2602,7 +2599,6 @@ gfc_get_symbol (const char *name, gfc_na
return i;
}
-
/* Subroutine that searches for a symbol, creating it if it doesn't
exist, but tries to host-associate the symbol if possible. */
@@ -2928,7 +2924,7 @@ free_sym_tree (gfc_symtree *sym_tree)
}
else if (sym->refs == 0)
{
- /* Go ahead and delete the symbol. */
+ /* Go ahead and delete the symbol if it is not a derived type. */
gfc_free_symbol (sym);
}
@@ -2936,23 +2932,6 @@ free_sym_tree (gfc_symtree *sym_tree)
}
-/* Free the derived type list. */
-
-static void
-gfc_free_dt_list (void)
-{
- gfc_dt_list *dt, *n;
-
- for (dt = gfc_derived_types; dt; dt = n)
- {
- n = dt->next;
- gfc_free (dt);
- }
-
- gfc_derived_types = NULL;
-}
-
-
/* Free the gfc_equiv_info's. */
static void
@@ -3088,7 +3067,6 @@ gfc_symbol_done_2 (void)
gfc_free_namespace (gfc_current_ns);
gfc_current_ns = NULL;
- gfc_free_dt_list ();
}
@@ -3287,29 +3265,38 @@ gfc_get_gsymbol (const char *name)
}
-static gfc_symbol *
-get_iso_c_binding_dt (int sym_id)
+static gfc_symbol*
+get_iso_c_binding_dt_recursive (gfc_symtree *st, int sym_id)
{
- gfc_dt_list *dt_list;
+ gfc_symbol *sym;
- dt_list = gfc_derived_types;
+ if (!st)
+ return NULL;
- /* Loop through the derived types in the name list, searching for
- the desired symbol from iso_c_binding. Search the parent namespaces
- if necessary and requested to (parent_flag). */
- while (dt_list != NULL)
- {
- if (dt_list->derived->from_intmod != INTMOD_NONE
- && dt_list->derived->intmod_sym_id == sym_id)
- return dt_list->derived;
+ sym = get_iso_c_binding_dt_recursive(st->left, sym_id);
+ if (sym)
+ return sym;
- dt_list = dt_list->next;
- }
+ sym = st->n.sym;
+ if (sym->from_intmod != INTMOD_NONE
+ && sym->intmod_sym_id == sym_id)
+ return sym;
+
+ sym = get_iso_c_binding_dt_recursive(st->right, sym_id);
+ if (sym)
+ return sym;
return NULL;
}
+static gfc_symbol*
+get_iso_c_binding_dt (int sym_id)
+{
+ return get_iso_c_binding_dt_recursive (gfc_current_ns->sym_root, sym_id);
+}
+
+
/* Verifies that the given derived type symbol, derived_sym, is interoperable
with C. This is necessary for any derived type that is BIND(C) and for
derived types that are parameters to functions that are BIND(C). All
@@ -3924,6 +3911,11 @@ std_for_isocbinding_symbol (int id)
is given, it must have a NULL in the first empty spot to mark the
end of the list. */
+/* TODO: this should be moved to intrinsic.c; intrinsic procedures should
+ there be created via add_sym_[1234]() and make_alias() for local names.
+ Following this, gfc_find_iso_c_symbol() could be removed and replaced by
+ find_iso_c_intrinsic(), traversing the list of intrinsic symbols instead
+ of the current namespace. */
void
generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
@@ -3933,7 +3925,6 @@ generate_isocbinding_symbol (const char
: c_interop_kinds_table[s].name;
gfc_symtree *tmp_symtree = NULL;
gfc_symbol *tmp_sym = NULL;
- gfc_dt_list **dt_list_ptr = NULL;
gfc_component *tmp_comp = NULL;
char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
int index;
@@ -4054,24 +4045,9 @@ generate_isocbinding_symbol (const char
interoperable (J3/04-007, Section 15.2.3), even though
the binding label is not used. */
tmp_sym->attr.is_bind_c = 1;
-
tmp_sym->attr.referenced = 1;
-
tmp_sym->ts.derived = tmp_sym;
- /* Add the symbol created for the derived type to the current ns. */
- dt_list_ptr = &(gfc_derived_types);
- while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
- dt_list_ptr = &((*dt_list_ptr)->next);
-
- /* There is already at least one derived type in the list, so append
- the one we're currently building for c_ptr or c_funptr. */
- if (*dt_list_ptr != NULL)
- dt_list_ptr = &((*dt_list_ptr)->next);
- (*dt_list_ptr) = gfc_get_dt_list ();
- (*dt_list_ptr)->derived = tmp_sym;
- (*dt_list_ptr)->next = NULL;
-
/* Set up the component of the derived type, which will be
an integer with kind equal to c_ptr_size. Mangle the name of
the field for the c_address to prevent the curious user from
Index: fortran/resolve.c
===================================================================
--- fortran/resolve.c (revision 142934)
+++ fortran/resolve.c (working copy)
@@ -8621,27 +8621,6 @@ resolve_typebound_procedures (gfc_symbol
}
-/* Add a derived type to the dt_list. The dt_list is used in trans-types.c
- to give all identical derived types the same backend_decl. */
-static void
-add_dt_to_dt_list (gfc_symbol *derived)
-{
- gfc_dt_list *dt_list;
-
- for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
- if (derived == dt_list->derived)
- break;
-
- if (dt_list == NULL)
- {
- dt_list = gfc_get_dt_list ();
- dt_list->next = gfc_derived_types;
- dt_list->derived = derived;
- gfc_derived_types = dt_list;
- }
-}
-
-
/* Resolve the components of a derived type. */
static gfc_try
@@ -8731,16 +8710,6 @@ resolve_fl_derived (gfc_symbol *sym)
return FAILURE;
}
- /* Ensure that all the derived type components are put on the
- derived type list; even in formal namespaces, where derived type
- pointer components might not have been declared. */
- if (c->ts.type == BT_DERIVED
- && c->ts.derived
- && c->ts.derived->components
- && c->attr.pointer
- && sym != c->ts.derived)
- add_dt_to_dt_list (c->ts.derived);
-
if (c->attr.pointer || c->attr.allocatable || c->as == NULL)
continue;
@@ -8769,9 +8738,6 @@ resolve_fl_derived (gfc_symbol *sym)
if (gfc_resolve_finalizers (sym) == FAILURE)
return FAILURE;
- /* Add derived type to the derived type list. */
- add_dt_to_dt_list (sym);
-
return SUCCESS;
}
Index: testsuite/gfortran.dg/entry_13.f90
===================================================================
--- testsuite/gfortran.dg/entry_13.f90 (revision 142934)
+++ testsuite/gfortran.dg/entry_13.f90 (working copy)
@@ -67,14 +67,14 @@ program test
type(z) z1
z1 = x1//y1
- if (z1%x .ne. 19.0_4 + 7.0_4) call abort ()
+ if (ABS(z1%x - (19.0_4 + 7.0_4)) > TINY(1.0_4)) call abort ()
z1 = y1//x1
- if (z1%x .ne. 19.0_4 - 7.0_4) call abort ()
+ if (ABS(z1%x - (19.0_4 - 7.0_4)) > TINY(1.0_4)) call abort ()
z1 = x1==y1
- if (z1%x .ne. 19.0_4/7.0_4) call abort ()
+ if (ABS(z1%x - 19.0_4/7.0_4) > 1e-6) call abort ()
z1 = y1==x1
- if (z1%x .ne. 19.0_4/7.0_4) call abort ()
+ if (ABS(z1%x - 19.0_4/7.0_4) > 1e-6) call abort ()
end program test
! { dg-final { cleanup-modules "type_mod" } }
Index: testsuite/gfortran.dg/integer_exponentiation_3.F90
===================================================================
--- testsuite/gfortran.dg/integer_exponentiation_3.F90 (revision 142934)
+++ testsuite/gfortran.dg/integer_exponentiation_3.F90 (working copy)
@@ -31,12 +31,12 @@ contains
subroutine check_r8 (a, b)
real(kind=8), intent(in) :: a, b
- if (a /= b) call abort()
+ if (ABS(a - b) > TINY(a)) call abort()
end subroutine check_r8
subroutine check_r4 (a, b)
real(kind=4), intent(in) :: a, b
- if (a /= b) call abort()
+ if (ABS(a - b) > TINY(a)) call abort()
end subroutine check_r4
subroutine check_c8 (a, b)