This is a heads up for a patch that has not been exercised enough as yet. It works rather better and with less pain than I expected.
The testcase is really that of PR99065 but I thought that I should give Ian Harvey prior credit for PR89645. Both appear in the meta-bug PR87477. I'll do the exercising before a proper submission. Regards Paul
Change89645.Logs
Description: Binary data
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 30631abd788..b316901ef8f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2927,6 +2927,11 @@ typedef struct gfc_association_list
locus where;
gfc_expr *target;
+
+ /* Used for guessing the derived type of an associate name, whose selector
+ is a sibling derived type function that has not yet been parsed. */
+ gfc_symbol *derived_types;
+ unsigned guessed_type:1;
}
gfc_association_list;
#define gfc_get_association_list() XCNEW (gfc_association_list)
@@ -3478,6 +3483,7 @@ bool gfc_add_component (gfc_symbol *, const char *, gfc_component **);
gfc_symbol *gfc_use_derived (gfc_symbol *);
gfc_component *gfc_find_component (gfc_symbol *, const char *, bool, bool,
gfc_ref **);
+int gfc_find_derived_types (gfc_symbol *, gfc_namespace *, const char *);
gfc_st_label *gfc_get_st_label (int);
void gfc_free_st_label (gfc_st_label *);
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 0bb440b85a9..00a5e74dce1 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2057,6 +2057,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
bool unknown;
bool inquiry;
bool intrinsic;
+ bool guessed_type;
locus old_loc;
char sep;
@@ -2181,6 +2182,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
}
primary->ts = sym->ts;
+ guessed_type = sym->assoc && sym->assoc->guessed_type;
if (equiv_flag)
return MATCH_YES;
@@ -2194,7 +2196,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
inquiry = false;
if (m == MATCH_YES && sep == '%'
&& primary->ts.type != BT_CLASS
- && primary->ts.type != BT_DERIVED)
+ && (primary->ts.type != BT_DERIVED || guessed_type))
{
match mm;
old_loc = gfc_current_locus;
@@ -2209,7 +2211,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
gfc_set_default_type (sym, 0, sym->ns);
/* See if there is a usable typespec in the "no IMPLICIT type" error. */
- if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
+ if ((sym->ts.type == BT_UNKNOWN || guessed_type)
+ && m == MATCH_YES)
{
bool permissible;
@@ -2228,6 +2231,31 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
sym->ts = tgt_expr->ts;
}
+ /* If this hasn't done the trick and the target expression is a function,
+ then this must be a derived type if 'name' matches an accessible type
+ both in this namespace and the as yet unparsed sibling function. */
+ if (tgt_expr && tgt_expr->expr_type == EXPR_FUNCTION
+ && (sym->ts.type == BT_UNKNOWN || guessed_type)
+ && gfc_find_derived_types (sym, gfc_current_ns, name))
+ {
+ sym->assoc->guessed_type = 1;
+ /* The first returned type is as good as any at this stage. */
+ gfc_symbol **dts = &sym->assoc->derived_types;
+ tgt_expr->ts.type = BT_DERIVED;
+ tgt_expr->ts.kind = 0;
+ tgt_expr->ts.u.derived = *dts;
+ sym->ts = tgt_expr->ts;
+ /* Delete the dt list to prevent interference with trans-type.cc's
+ treatment of derived type decls, even if this process has to be
+ done again for another primary expression. */
+ while (*dts && (*dts)->dt_next)
+ {
+ gfc_symbol **tmp = &(*dts)->dt_next;
+ *dts = NULL;
+ dts = tmp;
+ }
+ }
+
if (sym->ts.type == BT_UNKNOWN)
{
gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 37a9e8fa0ae..272e102ca77 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -2402,6 +2402,65 @@ bad:
}
+/* Find all derived types in the uppermost namespace that have a component
+ a component called name and stash them in the assoc field of an
+ associate name variable.
+ This is used to guess the derived type of an associate name, whose selector
+ is a sibling derived type function that has not yet been parsed. Either
+ the derived type is use associated in both contained and sibling procedures
+ or it appears in the uppermost namespace. */
+
+static int cts = 0;
+static void
+find_derived_types (gfc_symbol *sym, gfc_symtree *st, const char *name,
+ bool contained)
+{
+ if (st->n.sym && st->n.sym->attr.flavor == FL_DERIVED
+ && ((contained && st->n.sym->attr.use_assoc) || !contained)
+ && gfc_find_component (st->n.sym, name, true, true, NULL))
+ {
+ /* Do the stashing. */
+ cts++;
+ if (sym->assoc->derived_types)
+ st->n.sym->dt_next = sym->assoc->derived_types;
+ sym->assoc->derived_types = st->n.sym;
+ }
+
+ if (st->left)
+ find_derived_types (sym, st->left, name, contained);
+
+ if (st->right)
+ find_derived_types (sym, st->right, name, contained);
+}
+
+int
+gfc_find_derived_types (gfc_symbol *sym, gfc_namespace *ns, const char *name)
+{
+ gfc_namespace *encompassing = NULL;
+ gcc_assert (sym->assoc);
+
+ cts = 0;
+ while (ns->parent)
+ {
+ if (!ns->parent->parent && ns->proc_name
+ && (ns->proc_name->attr.function || ns->proc_name->attr.subroutine))
+ encompassing = ns;
+ ns = ns->parent;
+ }
+
+ if (!ns->contained)
+ return cts;
+
+ /* Search the top level namespace first. */
+ find_derived_types (sym, ns->sym_root, name, false);
+
+ /* Then the encompassing namespace. */
+ if (encompassing)
+ find_derived_types (sym, encompassing->sym_root, name, true);
+
+ return cts;
+}
+
/* Find the component with the given name in the union type symbol.
If ref is not NULL it will be set to the chain of components through which
the component can actually be accessed. This is necessary for unions because
! { dg-do run }
!
! Contributed by Ian Harvey <ian_har...@bigpond.com>
!
module m1
implicit none
private
public foo1
type t
integer :: i = 0
end type t
contains
! This is the original testcase. 'bar' has not yet been parsed and so
! the type of var was not known, when parsing var%i giving:
! Error: Symbol ‘var’ at (1) has no IMPLICIT type
subroutine foo1()
associate (var => bar())
if (var%i .ne. 42) stop 1
end associate
end subroutine foo1
type(t) function bar()
bar = t(42)
end
end module m1
module m2
implicit none
private
public foo2
type t
integer :: i = 0
end type t
type s
integer :: i = 0
type(t) :: dt
end type s
contains
! In this version, the order of declarations of 't' and 's' is such that
! parsing var%i sets the type of var to 't' and this is corrected to 's'
! on parsing var%dt%i
subroutine foo2()
associate (var => bar())
if (var%i .ne. 42) stop 2
if (var%dt%i .ne. 84) stop 3
end associate
end subroutine foo2
type(s) function bar()
bar = s(42, t(84))
end
end module m2
program test
use m1
use m2
call foo1
call foo2
end program test
