[Patch fortran] PR89645 - No IMPLICIT type error with: ASSOCIATE( X => function() )

[Patch fortran] PR89645 - No IMPLICIT type error with: ASSOCIATE( X => function() )

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 348 bytes --]

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

[-- Attachment #2: Change89645.Logs --]
[-- Type: application/octet-stream, Size: 696 bytes --]

Fortran: Fixup derived type function selectors in associate [PR89645]

2023-06-28  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/89645
	* gfortran.h: Add fields 'derived_types' and 'guessed_type' to
	'gfc_association_list'.
	* primary.cc (gfc_match_varspec): Try to fix up the type of an
	associate name with unknown type function target by searching
	for accessible derived derived types with a component matching
	the name of a component reference.
	* symbol.cc (find_derived_types, gfc_find_derived_types): New
	functions that search for derived types that match a component
	reference of an associate name.

gcc/testsuite/
	PR fortran/89645
	* gfortran.dg/pr89645.f90 : New test


[-- Attachment #3: pr89645.diff --]
[-- Type: text/x-patch, Size: 5776 bytes --]

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

[-- Attachment #4: pr89645.f90 --]
[-- Type: text/x-fortran, Size: 1172 bytes --]

! { dg-do run }
!
! Contributed by Ian Harvey  <ian_harvey@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