public inbox for fortran@gcc.gnu.org
 help / color / mirror / Atom feed
* [Patch, fortran PR89645/99065 No IMPLICIT type error with: ASSOCIATE( X => function() )
@ 2024-01-06 17:26 Paul Richard Thomas
  2024-01-08 21:53 ` Harald Anlauf
  0 siblings, 1 reply; 7+ messages in thread
From: Paul Richard Thomas @ 2024-01-06 17:26 UTC (permalink / raw)
  To: fortran, gcc-patches


[-- Attachment #1.1: Type: text/plain, Size: 4379 bytes --]

These PRs come about because of gfortran's single pass parsing. If the
function in the title is parsed after the associate construct, then its
type and rank are not known. The point at which this becomes a problem is
when expressions within the associate block are parsed. primary.cc
(gfc_match_varspec) could already deal with intrinsic types and so
component references were the trigger for the problem.

The two major parts of this patch are the fixup needed in gfc_match_varspec
and the resolution of  expressions with references in resolve.cc
(gfc_fixup_inferred_type_refs). The former relies on the two new functions
in symbol.cc to search for derived types with an appropriate component to
match the component reference and then set the associate name to have a
matching derived type. gfc_fixup_inferred_type_refs is called in resolution
and so the type of the selector function is known.
gfc_fixup_inferred_type_refs ensures that the component references use this
derived type and that array references occur in the right place in
expressions and match preceding array specs. Most of the work in preparing
the patch was sorting out cases where the selector was not a derived type
but, instead, a class function. If it were not for this, the patch would
have been submitted six months ago :-(

The patch is relatively safe because most of the chunks are guarded by
testing for the associate name being an inferred type, which is set in
gfc_match_varspec. For this reason, I do not think it likely that the patch
will cause regressions. However, it is more than possible that variants not
appearing in the submitted testcase will throw up new bugs.

Jerry has already given the patch a whirl and found that it applies
cleanly, regtests OK and works as advertised.

OK for trunk?

Paul

Fortran: Fix class/derived type function associate selectors [PR87477]

2024-01-06  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
PR fortran/87477
PR fortran/89645
PR fortran/99065
* class.cc (gfc_change_class): New function needed for
associate names, when rank changes or a derived type is
produced by resolution
* dump-parse-tree.cc (show_code_node): Make output for SELECT
TYPE more comprehensible.
* gfortran.h : Add 'gfc_association_list' to structure
'gfc_association_list'. Add prototypes for
'gfc_find_derived_types', 'gfc_fixup_inferred_type_refs' and
'gfc_change_class'. Add macro IS_INFERRED_TYPE.
* match.cc (copy_ts_from_selector_to_associate): Add bolean arg
'select_type' with default false. If this is a select type name
and the selector is a inferred type, build the class type and
apply it to the associate name.
(build_associate_name): Pass true to 'select_type' in call to
previous.
* parse.cc (parse_associate): If the selector is a inferred type
the associate name is too. Make sure that function selector
class and rank, if known, are passed to the associate name. If
a function result exists, pass its typespec to the associate
name.
* primary.cc (gfc_match_varspec): If a scalar derived type
select type temporary has an array reference, match the array
reference, treating this in the same way as an equivalence
member. If this is a inferred type with a component reference,
call 'gfc_find_derived_types' to find a suitable derived type.
* resolve.cc (resolve_variable): Call new function below.
(gfc_fixup_inferred_type_refs): New function to ensure that the
expression references for a inferred type are consistent with
the now fixed up selector.
(resolve_assoc_var): Ensure that derived type or class function
selectors transmit the correct arrayspec to the associate name.
(resolve_select_type): If the selector is an associate name of
inferred type and has no component references, the associate
name should have its typespec.
* symbol.cc (gfc_set_default_type): If an associate name with
unknown type has a selector expression, try resolving the expr.
(find_derived_types, gfc_find_derived_types): New functions
that search for a derived type with a given name.
* trans-expr.cc (gfc_conv_variable): Some inferred type exprs
escape resolution so call 'gfc_fixup_inferred_type_refs'.
* trans-stmt.cc (trans_associate_var): Tidy up expression for
'class_target'. Correctly handle selectors that are class array
references, passed as derived types.

gcc/testsuite/
PR fortran/87477
PR fortran/89645
PR fortran/99065
* gfortran.dg/associate_64.f90 : New test

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 31437 bytes --]

diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 5c43b77dba3..7db1ecbd264 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -815,6 +815,56 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 }
 
 
+/* Change class, using gfc_build_class_symbol. This is needed for associate
+   names, when rank changes or a derived type is produced by resolution.  */
+
+void
+gfc_change_class (gfc_typespec *ts, symbol_attribute *sym_attr,
+		  gfc_array_spec *sym_as, int rank, int corank)
+{
+  symbol_attribute attr;
+  gfc_component *c;
+  gfc_array_spec *as = NULL;
+  gfc_symbol *der = ts->u.derived;
+
+  ts->type = BT_CLASS;
+  attr = *sym_attr;
+  attr.class_ok = 0;
+  attr.associate_var = 1;
+  attr.class_pointer = 1;
+  attr.allocatable = 0;
+  attr.pointer = 1;
+  attr.dimension = rank ? 1 : 0;
+  if (rank)
+    {
+      if (sym_as)
+	as = gfc_copy_array_spec (sym_as);
+      else
+	{
+	  as = gfc_get_array_spec ();
+	  as->rank = rank;
+	  as->type = AS_DEFERRED;
+	  as->corank = corank;
+	}
+    }
+  if (as && as->corank != 0)
+    attr.codimension = 1;
+
+  if (!gfc_build_class_symbol (ts, &attr, &as))
+    gcc_unreachable ();
+
+  gfc_set_sym_referenced (ts->u.derived);
+
+  /* Make sure the _vptr is set.  */
+  c = gfc_find_component (ts->u.derived, "_vptr", true, true, NULL);
+  if (c->ts.u.derived == NULL)
+    c->ts.u.derived = gfc_find_derived_vtab (der);
+  /* _vptr now has the _vtab in it, change it to the _vtype.  */
+  if (c->ts.u.derived->attr.vtab)
+    c->ts.u.derived = c->ts.u.derived->ts.u.derived;
+}
+
+
 /* Add a procedure pointer component to the vtype
    to represent a specific type-bound procedure.  */
 
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index ecf71036444..a233f9f1110 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2690,11 +2690,20 @@ show_code_node (int level, gfc_code *c)
 
     case EXEC_BLOCK:
       {
-	const char* blocktype;
+	const char *blocktype, *sname = NULL;
 	gfc_namespace *saved_ns;
 	gfc_association_list *alist;
 
-	if (c->ext.block.assoc)
+	if (c->ext.block.ns && c->ext.block.ns->code
+	    && c->ext.block.ns->code->op == EXEC_SELECT_TYPE)
+	  {
+	    gfc_expr *fcn = c->ext.block.ns->code->expr1;
+	    blocktype = "SELECT TYPE";
+	    /* expr1 is _loc(assoc_name->vptr)  */
+	    if (fcn && fcn->expr_type == EXPR_FUNCTION)
+	      sname = fcn->value.function.actual->expr->symtree->n.sym->name;
+	  }
+	else if (c->ext.block.assoc)
 	  blocktype = "ASSOCIATE";
 	else
 	  blocktype = "BLOCK";
@@ -2702,7 +2711,7 @@ show_code_node (int level, gfc_code *c)
 	fprintf (dumpfile, "%s ", blocktype);
 	for (alist = c->ext.block.assoc; alist; alist = alist->next)
 	  {
-	    fprintf (dumpfile, " %s = ", alist->name);
+	    fprintf (dumpfile, " %s = ", sname ? sname : alist->name);
 	    show_expr (alist->target);
 	  }
 
@@ -2733,7 +2742,7 @@ show_code_node (int level, gfc_code *c)
       if (c->op == EXEC_SELECT_RANK)
 	fputs ("SELECT RANK ", dumpfile);
       else if (c->op == EXEC_SELECT_TYPE)
-	fputs ("SELECT TYPE ", dumpfile);
+	fputs ("SELECT CASE ", dumpfile); // Preceded by SELECT TYPE construct
       else
 	fputs ("SELECT CASE ", dumpfile);
       show_expr (c->expr1);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b5e1b4c9d4b..13d5c5b2244 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2963,6 +2963,11 @@ typedef struct gfc_association_list
   locus where;
 
   gfc_expr *target;
+
+  /* Used for inferring 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 inferred_type:1;
 }
 gfc_association_list;
 #define gfc_get_association_list() XCNEW (gfc_association_list)
@@ -3529,6 +3534,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 *);
@@ -3794,6 +3800,7 @@ void gfc_free_association_list (gfc_association_list *);
 void gfc_expression_rank (gfc_expr *);
 bool gfc_op_rank_conformable (gfc_expr *, gfc_expr *);
 bool gfc_resolve_ref (gfc_expr *);
+void gfc_fixup_inferred_type_refs (gfc_expr *);
 bool gfc_resolve_expr (gfc_expr *);
 void gfc_resolve (gfc_namespace *);
 void gfc_resolve_code (gfc_code *, gfc_namespace *);
@@ -3987,6 +3994,8 @@ unsigned int gfc_hash_value (gfc_symbol *);
 gfc_expr *gfc_get_len_component (gfc_expr *e, int);
 bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
 			     gfc_array_spec **);
+void gfc_change_class (gfc_typespec *, symbol_attribute *,
+		       gfc_array_spec *, int, int);
 gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
 gfc_symbol *gfc_find_vtab (gfc_typespec *);
 gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*,
@@ -4017,6 +4026,10 @@ bool gfc_may_be_finalized (gfc_typespec);
 #define IS_PROC_POINTER(sym) \
 	(sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym) \
 	 ? CLASS_DATA (sym)->attr.proc_pointer : sym->attr.proc_pointer)
+#define IS_INFERRED_TYPE(expr) \
+	(expr && expr->expr_type == EXPR_VARIABLE \
+	 && expr->symtree->n.sym->assoc \
+	 && expr->symtree->n.sym->assoc->inferred_type)
 
 /* frontend-passes.cc */
 
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index df9adb359a0..6a523d5ab6e 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -6322,7 +6322,8 @@ gfc_match_select (void)
 /* Transfer the selector typespec to the associate name.  */
 
 static void
-copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
+copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector,
+				    bool select_type = false)
 {
   gfc_ref *ref;
   gfc_symbol *assoc_sym;
@@ -6405,12 +6406,30 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
     assoc_sym->as = NULL;
 
 build_class_sym:
-  if (selector->ts.type == BT_CLASS)
+  /* Deal with the very specific case of a SELECT_TYPE selector being an
+     associate_name whose type has been identified by component references.
+     It must be assumed that it will be identified as a CLASS expression,
+     so convert it now.  */
+  if (select_type
+      && IS_INFERRED_TYPE (selector)
+      && selector->ts.type == BT_DERIVED)
+    {
+      gfc_find_derived_vtab (selector->ts.u.derived);
+      /* The correct class container has to be available.  */
+      assoc_sym->ts.u.derived = selector->ts.u.derived;
+      assoc_sym->ts.type = BT_CLASS;
+      assoc_sym->attr.pointer = 1;
+      if (!selector->ts.u.derived->attr.is_class)
+	gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
+      associate->ts = assoc_sym->ts;
+    }
+  else if (selector->ts.type == BT_CLASS)
     {
       /* The correct class container has to be available.  */
       assoc_sym->ts.type = BT_CLASS;
       assoc_sym->ts.u.derived = CLASS_DATA (selector)
-	? CLASS_DATA (selector)->ts.u.derived : selector->ts.u.derived;
+				? CLASS_DATA (selector)->ts.u.derived
+				: selector->ts.u.derived;
       assoc_sym->attr.pointer = 1;
       gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
     }
@@ -6438,7 +6457,7 @@ build_associate_name (const char *name, gfc_expr **e1, gfc_expr **e2)
   if (expr2->ts.type == BT_UNKNOWN)
     sym->attr.untyped = 1;
   else
-    copy_ts_from_selector_to_associate (expr1, expr2);
+    copy_ts_from_selector_to_associate (expr1, expr2, true);
 
   sym->attr.flavor = FL_VARIABLE;
   sym->attr.referenced = 1;
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 042a6ad5e59..8c7d269ab96 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5149,6 +5149,17 @@ parse_associate (void)
       sym->declared_at = a->where;
       gfc_set_sym_referenced (sym);
 
+      /* If the selector is a inferred type then the associate_name had better
+	 be as well. Use array references, if present, to identify it as an
+	 array.  */
+      if (IS_INFERRED_TYPE (a->target))
+	{
+	  sym->assoc->inferred_type = 1;
+	  for (gfc_ref *r = a->target->ref; r; r = r->next)
+	    if (r->type == REF_ARRAY)
+	      sym->attr.dimension = 1;
+	}
+
       /* Initialize the typespec.  It is not available in all cases,
 	 however, as it may only be set on the target during resolution.
 	 Still, sometimes it helps to have it right now -- especially
@@ -5175,21 +5186,41 @@ parse_associate (void)
 	       && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
 	sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
 
+      /* If the function has been parsed, go straight to the result to
+	 obtain the expression rank.  */
+      if (target->expr_type == EXPR_FUNCTION
+	  && target->symtree
+	  && target->symtree->n.sym)
+	{
+	  tsym = target->symtree->n.sym;
+	  if (!tsym->result)
+	    tsym->result = tsym;
+	  sym->ts = tsym->result->ts;
+	  if (sym->ts.type == BT_CLASS)
+	    {
+	      if (CLASS_DATA (sym)->as)
+		target->rank = CLASS_DATA (sym)->as->rank;
+	      sym->attr.class_ok = 1;
+	    }
+	  else
+	    target->rank = tsym->result->as ? tsym->result->as->rank : 0;
+	}
+
       /* Check if the target expression is array valued. This cannot be done
 	 by calling gfc_resolve_expr because the context is unavailable.
 	 However, the references can be resolved and the rank of the target
 	 expression set.  */
-      if (target->ref && gfc_resolve_ref (target)
+      if (!sym->assoc->inferred_type
+	  && target->ref && gfc_resolve_ref (target)
 	  && target->expr_type != EXPR_ARRAY
 	  && target->expr_type != EXPR_COMPCALL)
 	gfc_expression_rank (target);
 
       /* Determine whether or not function expressions with unknown type are
 	 structure constructors. If so, the function result can be converted
-	 to be a derived type.
-	 TODO: Deal with references to sibling functions that have not yet been
-	 parsed (PRs 89645 and 99065).  */
-      if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN)
+	 to be a derived type.  */
+      if (target->expr_type == EXPR_FUNCTION
+	  && target->ts.type == BT_UNKNOWN)
 	{
 	  gfc_symbol *derived;
 	  /* The derived type has a leading uppercase character.  */
@@ -5199,16 +5230,7 @@ parse_associate (void)
 	    {
 	      sym->ts.type = BT_DERIVED;
 	      sym->ts.u.derived = derived;
-	    }
-	  else if (target->symtree && (tsym = target->symtree->n.sym))
-	    {
-	      sym->ts = tsym->result ? tsym->result->ts : tsym->ts;
-	      if (sym->ts.type == BT_CLASS)
-		{
-		  if (CLASS_DATA (sym)->as)
-		    target->rank = CLASS_DATA (sym)->as->rank;
-		  sym->attr.class_ok = 1;
-		}
+	      sym->assoc->inferred_type = 0;
 	    }
 	}
 
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index f8a1c09d190..17710b1f99d 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 inferred_type;
   locus old_loc;
   char sep;
 
@@ -2087,6 +2088,18 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
   if (sym->assoc && sym->assoc->target)
     tgt_expr = sym->assoc->target;
 
+  inferred_type = IS_INFERRED_TYPE (primary);
+
+  /* SELECT TYPE and SELECT RANK temporaries within an ASSOCIATE block, whose
+     selector has not been parsed, can generate errors with array and component
+     refs.. Use 'inferred_type' as a flag to suppress these errors.  */
+  if (!inferred_type
+      && (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
+      && !sym->attr.codimension
+      && sym->attr.select_type_temporary
+      && !sym->attr.select_rank_temporary)
+    inferred_type = true;
+
   /* For associate names, we may not yet know whether they are arrays or not.
      If the selector expression is unambiguously an array; eg. a full array
      or an array section, then the associate name must be an array and we can
@@ -2136,7 +2149,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	sym->ts.u.derived = tgt_expr->ts.u.derived;
     }
 
-  if ((equiv_flag && gfc_peek_ascii_char () == '(')
+  if ((inferred_type && !sym->as && gfc_peek_ascii_char () == '(')
+      || (equiv_flag && gfc_peek_ascii_char () == '(')
       || gfc_peek_ascii_char () == '[' || sym->attr.codimension
       || (sym->attr.dimension && sym->ts.type != BT_CLASS
 	  && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
@@ -2194,7 +2208,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 || inferred_type))
     {
       match mm;
       old_loc = gfc_current_locus;
@@ -2209,7 +2223,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 || inferred_type)
+      && m == MATCH_YES)
     {
       bool permissible;
 
@@ -2228,9 +2243,34 @@ 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 || inferred_type)
+	  && gfc_find_derived_types (sym, gfc_current_ns, name))
+	{
+	  sym->assoc->inferred_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);
+	  gfc_error ("Symbol %qs at %C has no IMPLICIT type(primary)", sym->name);
 	  return MATCH_ERROR;
 	}
     }
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 2925f7da28c..dcf8750ba97 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5866,6 +5866,13 @@ resolve_variable (gfc_expr *e)
       return false;
     }
 
+  /* Guessed type variables are associate_names whose selector had not been
+     parsed at the time that the construct was parsed. Now the namespace is
+     being resolved, the TKR of the selector will be available for fixup of
+     the associate_name.  */
+  if (IS_INFERRED_TYPE (e) && e->ref)
+    gfc_fixup_inferred_type_refs (e);
+
   /* For variables that are used in an associate (target => object) where
      the object's basetype is array valued while the target is scalar,
      the ts' type of the component refs is still array valued, which
@@ -6171,6 +6178,124 @@ resolve_procedure:
 }
 
 
+/* 'sym' was initially guessed to be derived type but has been corrected
+   in resolve_assoc_var to be a class entity or the derived type correcting.
+   If a class entity it will certainly need the _data reference or the
+   reference derived type symbol correcting in the first component ref if
+   a derived type.  */
+
+void
+gfc_fixup_inferred_type_refs (gfc_expr *e)
+{
+  gfc_ref *ref;
+  gfc_symbol *sym, *derived;
+
+  sym = e->symtree->n.sym;
+
+  /* This is an associate_name whose selector is a component ref of a selector
+     that is a inferred type associate_name.  */
+  if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+    {
+      e->rank = sym->as ? sym->as->rank : 0;
+      sym->attr.dimension = e->rank ? 1 : 0;
+      if (!e->rank && e->ref->type == REF_ARRAY)
+	{
+	  ref = e->ref;
+	  e->ref = ref->next;
+	  free (ref);
+	}
+      return;
+    }
+
+  derived = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->ts.u.derived
+				     : sym->ts.u.derived;
+
+  /* Ensure that class symbols have an array spec and ensure that there
+     is a _data field reference following class type references.  */
+  if (sym->ts.type == BT_CLASS
+      && sym->assoc->target->ts.type == BT_CLASS)
+    {
+      e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0;
+      sym->attr.dimension = 0;
+      CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0;
+      if (e->ref && (e->ref->type != REF_COMPONENT
+		     || e->ref->u.c.component->name[0] != '_'))
+	{
+	  ref = gfc_get_ref ();
+	  ref->type = REF_COMPONENT;
+	  ref->next = e->ref;
+	  e->ref = ref;
+	  ref->u.c.component = gfc_find_component (sym->ts.u.derived, "_data",
+						   true, true, NULL);
+	  ref->u.c.sym = sym->ts.u.derived;
+	}
+    }
+
+  /* Proceed as far as the first component reference and ensure that the
+     correct derived type is being used.  */
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      {
+	if (ref->u.c.component->name[0] != '_')
+	  ref->u.c.sym = derived;
+	else
+	  ref->u.c.sym = sym->ts.u.derived;
+	break;
+      }
+
+  gfc_expr *target = sym->assoc->target;
+  if (sym->ts.type == BT_CLASS
+      && IS_INFERRED_TYPE (target)
+      && target->ts.type == BT_DERIVED
+      && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived
+      && target->ref && target->ref->next
+      && target->ref->next->type == REF_ARRAY)
+    target->ts = target->symtree->n.sym->ts;
+
+  /* Verify that the type inferrence mechanism has not introduced a spurious
+     array reference.  This can happen with an associate name, whose selector
+     is an element of another inferred type.  */
+  if (!(sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as)
+      && e != e->symtree->n.sym->assoc->target
+      && !e->symtree->n.sym->assoc->target->rank)
+    {
+      /* First case: array ref after the scalar class or derived associate_name.  */
+      if (e->ref && e->ref->type == REF_ARRAY
+	  && e->ref->u.ar.type != AR_ELEMENT)
+	{
+	  ref = e->ref;
+	  e->ref = ref->next;
+	  free (ref);
+
+	  /* If it hasn't a ref to the '_data' field supply one.  */
+	  if (sym->ts.type == BT_CLASS
+	      && !(e->ref->type == REF_COMPONENT
+		   && strcmp (e->ref->u.c.component->name, "_data")))
+	    {
+	      gfc_ref *new_ref;
+	      gfc_find_component (e->symtree->n.sym->ts.u.derived,
+				  "_data", true, true, &new_ref);
+	      new_ref->next = e->ref;
+	      e->ref = new_ref;
+	    }
+	}
+      /* 2nd case: a ref to the '_data' field followed by an array ref.  */
+      else if (e->ref && e->ref->type == REF_COMPONENT
+	       && strcmp (e->ref->u.c.component->name, "_data") == 0
+	       && e->ref->next && e->ref->next->type == REF_ARRAY
+	       && e->ref->next->u.ar.type != AR_ELEMENT)
+	{
+	  ref = e->ref->next;
+	  e->ref->next = e->ref->next->next;
+	  free (ref);
+	}
+    }
+
+  /* Now that all the references are OK, get the expression rank.  */
+  gfc_expression_rank (e);
+}
+
+
 /* Checks to see that the correct symbol has been host associated.
    The only situations where this arises are:
 	(i)  That in which a twice contained function is parsed after
@@ -9263,6 +9388,46 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
       return;
     }
 
+  if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target))
+    {
+      symbol_attribute attr;
+
+      /* By now, the type of the target has been fixed up.  */
+      if (sym->ts.type == BT_DERIVED
+	  && target->ts.type == BT_CLASS
+	  && !UNLIMITED_POLY (target))
+	{
+	  sym->ts = CLASS_DATA (target)->ts;
+	  if (!sym->as)
+	    sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as);
+	  attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
+	  sym->attr.dimension = target->rank ? 1 : 0;
+	  gfc_change_class (&sym->ts, &attr, sym->as,
+			    target->rank, gfc_get_corank (target));
+	  sym->as = NULL;
+	}
+      else if (target->ts.type == BT_DERIVED
+	       && target->symtree->n.sym->ts.type == BT_CLASS
+	       && IS_INFERRED_TYPE (target)
+	       && target->ref && target->ref->next
+	       && target->ref->next->type == REF_ARRAY
+	       && !target->ref->next->next)
+	{
+	  sym->ts = target->ts;
+	  attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
+	  sym->attr.dimension = target->rank ? 1 : 0;
+	  gfc_change_class (&sym->ts, &attr, sym->as,
+			    target->rank, gfc_get_corank (target));
+	  sym->as = NULL;
+	  target->ts = sym->ts;
+	}
+      else if ((target->ts.type == BT_DERIVED)
+	       || (sym->ts.type == BT_CLASS && target->ts.type == BT_CLASS
+		   && CLASS_DATA (target)->as && !CLASS_DATA (sym)->as))
+	sym->ts = target->ts;
+    }
+
+
   if (target->expr_type == EXPR_NULL)
     {
       gfc_error ("Selector at %L cannot be NULL()", &target->where);
@@ -9289,15 +9454,50 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 			  || gfc_is_ptr_fcn (target));
 
   /* Finally resolve if this is an array or not.  */
+  if (target->expr_type == EXPR_FUNCTION
+      && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
+    {
+      gfc_expression_rank (target);
+      if (target->ts.type == BT_DERIVED
+	  && !sym->as
+	  && target->symtree->n.sym->as)
+	{
+	  sym->as = gfc_copy_array_spec (target->symtree->n.sym->as);
+	  sym->attr.dimension = 1;
+	}
+      else if (target->ts.type == BT_CLASS
+	       && CLASS_DATA (target)->as)
+	{
+	  target->rank = CLASS_DATA (target)->as->rank;
+	  if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
+	    {
+	      sym->ts = target->ts;
+	      sym->attr.dimension = 0;
+	    }
+	}
+    }
+
+
   if (sym->attr.dimension && target->rank == 0)
     {
       /* primary.cc makes the assumption that a reference to an associate
 	 name followed by a left parenthesis is an array reference.  */
-      if (sym->ts.type != BT_CHARACTER)
-	gfc_error ("Associate-name %qs at %L is used as array",
-		   sym->name, &sym->declared_at);
-      sym->attr.dimension = 0;
-      return;
+      if (sym->assoc->inferred_type && sym->ts.type != BT_CLASS)
+	{
+	  gfc_expression_rank (sym->assoc->target);
+	  sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
+	  if (!sym->attr.dimension && sym->as)
+	    sym->as = NULL;
+	}
+
+      if (sym->attr.dimension && target->rank == 0)
+	{
+	  if (sym->ts.type != BT_CHARACTER)
+	    gfc_error ("Associate-name %qs at %L is used as array",
+		       sym->name, &sym->declared_at);
+	  sym->attr.dimension = 0;
+	  return;
+	}
     }
 
   /* We cannot deal with class selectors that need temporaries.  */
@@ -9356,7 +9556,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	     correct this now.  */
 	  gfc_typespec *ts = &target->ts;
 	  gfc_ref *ref;
-	  gfc_component *c;
+
 	  for (ref = target->ref; ref != NULL; ref = ref->next)
 	    {
 	      switch (ref->type)
@@ -9374,32 +9574,15 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	    }
 	  /* Create a scalar instance of the current class type.  Because the
 	     rank of a class array goes into its name, the type has to be
-	     rebuild.  The alternative of (re-)setting just the attributes
+	     rebuilt.  The alternative of (re-)setting just the attributes
 	     and as in the current type, destroys the type also in other
 	     places.  */
 	  as = NULL;
 	  sym->ts = *ts;
 	  sym->ts.type = BT_CLASS;
 	  attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
-	  attr.class_ok = 0;
-	  attr.associate_var = 1;
-	  attr.dimension = attr.codimension = 0;
-	  attr.class_pointer = 1;
-	  if (!gfc_build_class_symbol (&sym->ts, &attr, &as))
-	    gcc_unreachable ();
-	  /* Make sure the _vptr is set.  */
-	  c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL);
-	  if (c->ts.u.derived == NULL)
-	    c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived);
-	  CLASS_DATA (sym)->attr.pointer = 1;
-	  CLASS_DATA (sym)->attr.class_pointer = 1;
-	  gfc_set_sym_referenced (sym->ts.u.derived);
-	  gfc_commit_symbol (sym->ts.u.derived);
-	  /* _vptr now has the _vtab in it, change it to the _vtype.  */
-	  if (c->ts.u.derived->attr.vtab)
-	    c->ts.u.derived = c->ts.u.derived->ts.u.derived;
-	  c->ts.u.derived->ns->types_resolved = 0;
-	  resolve_types (c->ts.u.derived->ns);
+	  gfc_change_class (&sym->ts, &attr, as, 0, 0);
+	  sym->as = NULL;
 	}
     }
 
@@ -9443,6 +9626,14 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	}
     }
 
+  if (sym->ts.type == BT_CLASS
+      && IS_INFERRED_TYPE (target)
+      && target->ts.type == BT_DERIVED
+      && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived
+      && target->ref && target->ref->next
+      && target->ref->next->type == REF_ARRAY)
+    target->ts = target->symtree->n.sym->ts;
+
   /* If the target is a good class object, so is the associate variable.  */
   if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
     sym->attr.class_ok = 1;
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index a6078bc608a..f66831df15f 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -291,6 +291,19 @@ bool
 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
 {
   gfc_typespec *ts;
+  gfc_expr *e;
+
+  /* Check to see if a function selector of unknown type can be resolved.  */
+  if (sym->assoc
+      && (e = sym->assoc->target)
+      && e->expr_type == EXPR_FUNCTION)
+    {
+      if (e->ts.type == BT_UNKNOWN)
+	gfc_resolve_expr (e);
+      sym->ts = e->ts;
+      if (sym->ts.type != BT_UNKNOWN)
+	return true;
+    }
 
   if (sym->ts.type != BT_UNKNOWN)
     gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
@@ -307,7 +320,7 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
 		       "; did you mean %qs?",
 		       sym->name, &sym->declared_at, guessed);
 	  else
-	    gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type(symbol)",
 		       sym->name, &sym->declared_at);
 	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
 	}
@@ -2402,6 +2415,66 @@ 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 infer 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
+      && !st->n.sym->attr.is_class
+      && ((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
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index f4185db5b7f..3dac9d990f0 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -3134,6 +3134,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
       gcc_assert (se->string_length);
     }
 
+  /* Some expressions leak through that haven't been fixed up.  */
+  if (IS_INFERRED_TYPE (expr) && expr->ref)
+    gfc_fixup_inferred_type_refs (expr);
+
   gfc_typespec *ts = &sym->ts;
   while (ref)
     {
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 517b7aaa898..bf4f1876969 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1746,9 +1746,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   e = sym->assoc->target;
 
   class_target = (e->expr_type == EXPR_VARIABLE)
-		    && e->ts.type == BT_CLASS
-		    && (gfc_is_class_scalar_expr (e)
-			|| gfc_is_class_array_ref (e, NULL));
+		  && e->ts.type == BT_CLASS
+		  && (gfc_is_class_scalar_expr (e)
+		      || gfc_is_class_array_ref (e, NULL));
 
   unlimited = UNLIMITED_POLY (e);
 
@@ -2156,26 +2156,36 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	    {
 	      tree stmp;
 	      tree dtmp;
+	      tree ctmp;
 
-	      se.expr = ctree;
+	      ctmp = ctree;
 	      dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl));
 	      ctree = gfc_create_var (dtmp, "class");
 
-	      stmp = gfc_class_data_get (se.expr);
+	      if (IS_INFERRED_TYPE (e)
+		  && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
+		stmp = se.expr;
+	      else
+		stmp = gfc_class_data_get (ctmp);
+
 	      /* Coarray scalar component expressions can emerge from
 		 the front end as array elements of the _data field.  */
 	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp)))
 		stmp = gfc_conv_descriptor_data_get (stmp);
+
+	      if (!POINTER_TYPE_P (TREE_TYPE (stmp)))
+		stmp = gfc_build_addr_expr (NULL, stmp);
+
 	      dtmp = gfc_class_data_get (ctree);
 	      stmp = fold_convert (TREE_TYPE (dtmp), stmp);
 	      gfc_add_modify (&se.pre, dtmp, stmp);
-	      stmp = gfc_class_vptr_get (se.expr);
+	      stmp = gfc_class_vptr_get (ctmp);
 	      dtmp = gfc_class_vptr_get (ctree);
 	      stmp = fold_convert (TREE_TYPE (dtmp), stmp);
 	      gfc_add_modify (&se.pre, dtmp, stmp);
 	      if (UNLIMITED_POLY (sym))
 		{
-		  stmp = gfc_class_len_get (se.expr);
+		  stmp = gfc_class_len_get (ctmp);
 		  dtmp = gfc_class_len_get (ctree);
 		  stmp = fold_convert (TREE_TYPE (dtmp), stmp);
 		  gfc_add_modify (&se.pre, dtmp, stmp);

[-- Attachment #3: associate_64.f90 --]
[-- Type: text/x-fortran, Size: 9013 bytes --]

! { dg-do run }
!
! Tests the fix for PR89645 and 99065, in which derived type or class functions,
! used as associate selectors and which were parsed after the containing scope
! of the associate statement, caused "no IMPLICIT type" and "Syntax" errors.
!
! Contributed by Ian Harvey  <ian_harvey@bigpond.com>
!
module m
  implicit none
  type t
    integer :: i = 0
  end type t
  integer :: i = 0
  type(t), parameter :: test_array (2) = [t(42),t(84)], &
                        test_scalar = t(99)
end module m

! DERIVED TYPE VERSION OF THE PROBLEM, AS REPORTED IN THE PRs
module type_selectors
  use m
  implicit none
  private
  public foo1
contains
! Since these functions are parsed first, the symbols are available for
! parsing in 'foo'.
  function bar1() result(res) ! The array version caused syntax errors in foo
    type(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end
  function bar2() result(res) ! Scalar class functions were OK - test anyway
    type(t), allocatable :: res
    allocate (res, source = test_scalar)
  end
  subroutine foo1()
! First the array selector
    associate (var1 => bar1())
      if (any (var1%i .ne. test_array%i)) stop 1
      if (var1(2)%i .ne. test_array(2)%i) stop 2
    end associate
! Now the scalar selector
    associate (var2 => bar2())
      if (var2%i .ne. test_scalar%i) stop 3
    end associate

! Now the array selector that needed fixing up because the function follows....
    associate (var1 => bar3())
      if (any (var1%i .ne. test_array%i)) stop 4
      if (var1(2)%i .ne. test_array(2)%i) stop 5
    end associate
! ....and equivalent scalar selector
    associate (var2 => bar4())
      if (var2%i .ne. test_scalar%i) stop 6
    end associate
  end subroutine foo1

! These functions are parsed after 'foo' so the symbols were not available
! for the selectors and the fixup, tested here, was necessary.
  function bar3() result(res)
    class(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end

  function bar4() result(res)
    class(t), allocatable :: res
    allocate (res, source = t(99))
  end
end module type_selectors

! CLASS VERSION OF THE PROBLEM, WHICH REQUIRED MOST OF THE WORK!
module class_selectors
  use m
  implicit none
  private
  public foo2
contains

! Since these functions are parsed first, the symbols are available for
! parsing in 'foo'.
  function bar1() result(res) ! The array version caused syntax errors in foo
    class(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end

  function bar2() result(res) ! Scalar class functions were OK - test anyway
    class(t), allocatable :: res
    allocate (res, source = t(99))
  end

  subroutine foo2()
! First the array selector
    associate (var1 => bar1())
      if (any (var1%i .ne. test_array%i)) stop 7
      if (var1(2)%i .ne. test_array(2)%i) stop 8
      select type (x => var1)
        type is (t)
          if (any (x%i .ne. test_array%i)) stop 9
          if (x(1)%i .ne. test_array(1)%i) stop 10
        class default
          stop 11
      end select
    end associate

! Now scalar selector
    associate (var2 => bar2())
      select type (z => var2)
        type is (t)
          if (z%i .ne. test_scalar%i) stop 12
        class default
          stop 13
      end select
    end associate

! This is the array selector that needed the fixup.
    associate (var1 => bar3())
      if (any (var1%i .ne. test_array%i)) stop 14
      if (var1(2)%i .ne. test_array(2)%i) stop 15
      select type (x => var1)
        type is (t)
          if (any (x%i .ne. test_array%i)) stop 16
          if (x(1)%i .ne. test_array(1)%i) stop 17
        class default
          stop 18
      end select
    end associate

! Now the equivalent scalar selector
    associate (var2 => bar4())
      select type (z => var2)
        type is (t)
          if (z%i .ne. test_scalar%i) stop 19
        class default
          stop 20
      end select
    end associate

  end subroutine foo2

! These functions are parsed after 'foo' so the symbols were not available
! for the selectors and the fixup, tested here, was necessary.
  function bar3() result(res)
    class(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end

  function bar4() result(res)
    class(t), allocatable :: res
    allocate (res, source = t(99))
  end
end module class_selectors

! THESE TESTS CAUSED PROBLEMS DURING DEVELOPMENT FOR BOTH PARSING ORDERS.
module problem_selectors
  implicit none
  private
  public foo3, foo4
  type t
    integer :: i
  end type t
  type s
    integer :: i
    type(t) :: dt
  end type s
  type(t), parameter :: test_array (2) = [t(42),t(84)], &
                        test_scalar = t(99)
  type(s), parameter :: test_sarray (2) = [s(142,t(42)),s(184,t(84))]
contains

  subroutine foo3()
    integer :: i
    block
      associate (var1 => bar7())
        if (any (var1%i .ne. test_array%i)) stop 21
        if (var1(2)%i .ne. test_array(2)%i) stop 22
        associate (z => var1(1)%i)
           if (z .ne. 42) stop 23
        end associate
    end associate
    end block

    associate (var2 => bar8())
      i = var2(2)%i
      associate (var3 => var2%dt)
        if (any (var3%i .ne. test_sarray%dt%i)) stop 24
      end associate
      associate (var4 => var2(2))
        if (var4%i .ne. 184) stop 25
      end associate
    end associate
  end subroutine foo3

  function bar7() result(res)
    type(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end

  function bar8() result(res)
    type(s), allocatable :: res(:)
    allocate (res, source = test_sarray)
  end

  subroutine foo4()
    integer :: i
    block
      associate (var1 => bar7())
        if (any (var1%i .ne. test_array%i)) stop 26
        if (var1(2)%i .ne. test_array(2)%i) stop 27
        associate (z => var1(1)%i)
           if (z .ne. 42) stop 28
        end associate
    end associate
    end block

    associate (var2 => bar8())
      i = var2(2)%i
      associate (var3 => var2%dt)
        if (any (var3%i .ne. test_sarray%dt%i)) stop 29
      end associate
      associate (var4 => var2(2))
        if (var4%i .ne. 184) stop 30
      end associate
    end associate
  end subroutine foo4

end module problem_selectors

module more_problem_selectors
  implicit none
  private
  public foo5, foo6
  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 foo5()
    associate (var3 => bar3())
      if (var3%i .ne. 42) stop 31
      if (var3%dt%i .ne. 84) stop 32
    end associate

! Repeat with class version
    associate (var4 => bar4())
      if (var4%i .ne. 84) stop 33
      if (var4%dt%i .ne. 168) stop 34
      select type (x => var4)
        type is (s)
          if (x%i .ne. var4%i) stop 35
          if (x%dt%i .ne. var4%dt%i) stop 36
        class default
          stop 37
      end select
    end associate

! Ditto with no type component clues for select type
    associate (var5 => bar4())
      select type (z => var5)
        type is (s)
          if (z%i .ne. 84) stop 38
          if (z%dt%i .ne. 168) stop 39
        class default
          stop 40
      end select
    end associate
  end subroutine foo5

! Now the array versions
  subroutine foo6()
    class(s), allocatable :: elem
    associate (var6 => bar5())
      if (var6(1)%i .ne. 42) stop 41
      if (any (var6%dt%i .ne. [84])) stop 42
    end associate

! Class version with an assignment to a named variable
    associate (var7 => bar6())
      elem = var7(2)
      if (any (var7%i .ne. [84, 168])) stop 43
      if (any (var7%dt%i .ne. [168, 336])) stop 44
    end associate
    if (elem%i .ne. 168) stop 45
    if (elem%dt%i .ne. 336) stop 46

    select type (z => elem)
      type is (s)
        if (z%i .ne. 168) stop 47
        if (z%dt%i .ne. 336) stop 48
      class default
        stop 49
    end select

! Array version without type clues before select type
    associate (var8 => bar6())
      select type (z => var8)
        type is (s)
          if (any (z%i .ne. [84,168])) stop 50
          if (any (z%dt%i .ne. [168,336])) stop 51
        class default
          stop 52
      end select
    end associate
  end subroutine foo6

  type(s) function bar3()
    bar3= s(42, t(84))
  end

  function bar4() result(res)
    class(s), allocatable :: res
    res = s(84, t(168))
  end

  function bar5() result (res)
    type(s), allocatable :: res(:)
    res = [s(42, t(84))]
  end

  function bar6() result (res)
    class(s), allocatable :: res(:)
    res = [s(84, t(168)),s(168, t(336))]
  end

end module more_problem_selectors

program test
  use type_selectors
  use class_selectors
  use problem_selectors
  use more_problem_selectors
  call foo1()
  call foo2()
  call foo3()
  call foo4()
  call foo5()
  call foo6()
end program test

^ permalink raw reply	[flat|nested] 7+ messages in thread

* Re: [Patch, fortran PR89645/99065 No IMPLICIT type error with: ASSOCIATE( X => function() )
  2024-01-06 17:26 [Patch, fortran PR89645/99065 No IMPLICIT type error with: ASSOCIATE( X => function() ) Paul Richard Thomas
@ 2024-01-08 21:53 ` Harald Anlauf
  2024-03-03 16:04   ` Paul Richard Thomas
  0 siblings, 1 reply; 7+ messages in thread
From: Harald Anlauf @ 2024-01-08 21:53 UTC (permalink / raw)
  To: Paul Richard Thomas, fortran, gcc-patches

Hi Paul,

your patch looks already very impressive!

Regarding the patch as is, I am still trying to grok it, even with your
explanations at hand...

While the testcase works as advertised, I noticed that it exhibits a
runtime memleak that occurs for (likely) each case where the associate
target is an allocatable, class-valued function result.

I tried to produce a minimal testcase using class(*), which apparently
is not handled by your patch (it ICEs for me):

program p
   implicit none
   class(*), allocatable :: x(:)
   x = foo()
   call prt (x)
   deallocate (x)
   ! up to here no memleak...
   associate (var => foo())
     call prt (var)
   end associate
contains
   function foo() result(res)
     class(*), allocatable :: res(:)
     res = [42]
   end function foo
   subroutine prt (x)
     class(*), intent(in) :: x(:)
     select type (x)
     type is (integer)
        print *, x
     class default
        stop 99
     end select
   end subroutine prt
end

Traceback (truncated):

foo.f90:9:18:

     9 |     call prt (var)
       |                  1
internal compiler error: tree check: expected record_type or union_type
or qual_union_type, have function_type in gfc_class_len_get, at
fortran/trans-expr.cc:271
0x19fd5d5 tree_check_failed(tree_node const*, char const*, int, char
const*, ...)
         ../../gcc-trunk/gcc/tree.cc:8952
0xe1562d tree_check3(tree_node*, char const*, int, char const*,
tree_code, tree_code, tree_code)
         ../../gcc-trunk/gcc/tree.h:3652
0xe3e264 gfc_class_len_get(tree_node*)
         ../../gcc-trunk/gcc/fortran/trans-expr.cc:271
0xecda48 trans_associate_var
         ../../gcc-trunk/gcc/fortran/trans-stmt.cc:2325
0xecdd09 gfc_trans_block_construct(gfc_code*)
         ../../gcc-trunk/gcc/fortran/trans-stmt.cc:2383
[...]

I don't see anything wrong with it: NAG groks it, like Nvidia and Flang,
while Intel crashes at runtime.

Can you have another brief look?

Thanks,
Harald


On 1/6/24 18:26, Paul Richard Thomas wrote:
> These PRs come about because of gfortran's single pass parsing. If the
> function in the title is parsed after the associate construct, then its
> type and rank are not known. The point at which this becomes a problem is
> when expressions within the associate block are parsed. primary.cc
> (gfc_match_varspec) could already deal with intrinsic types and so
> component references were the trigger for the problem.
>
> The two major parts of this patch are the fixup needed in gfc_match_varspec
> and the resolution of  expressions with references in resolve.cc
> (gfc_fixup_inferred_type_refs). The former relies on the two new functions
> in symbol.cc to search for derived types with an appropriate component to
> match the component reference and then set the associate name to have a
> matching derived type. gfc_fixup_inferred_type_refs is called in resolution
> and so the type of the selector function is known.
> gfc_fixup_inferred_type_refs ensures that the component references use this
> derived type and that array references occur in the right place in
> expressions and match preceding array specs. Most of the work in preparing
> the patch was sorting out cases where the selector was not a derived type
> but, instead, a class function. If it were not for this, the patch would
> have been submitted six months ago :-(
>
> The patch is relatively safe because most of the chunks are guarded by
> testing for the associate name being an inferred type, which is set in
> gfc_match_varspec. For this reason, I do not think it likely that the patch
> will cause regressions. However, it is more than possible that variants not
> appearing in the submitted testcase will throw up new bugs.
>
> Jerry has already given the patch a whirl and found that it applies
> cleanly, regtests OK and works as advertised.
>
> OK for trunk?
>
> Paul
>
> Fortran: Fix class/derived type function associate selectors [PR87477]
>
> 2024-01-06  Paul Thomas  <pault@gcc.gnu.org>
>
> gcc/fortran
> PR fortran/87477
> PR fortran/89645
> PR fortran/99065
> * class.cc (gfc_change_class): New function needed for
> associate names, when rank changes or a derived type is
> produced by resolution
> * dump-parse-tree.cc (show_code_node): Make output for SELECT
> TYPE more comprehensible.
> * gfortran.h : Add 'gfc_association_list' to structure
> 'gfc_association_list'. Add prototypes for
> 'gfc_find_derived_types', 'gfc_fixup_inferred_type_refs' and
> 'gfc_change_class'. Add macro IS_INFERRED_TYPE.
> * match.cc (copy_ts_from_selector_to_associate): Add bolean arg
> 'select_type' with default false. If this is a select type name
> and the selector is a inferred type, build the class type and
> apply it to the associate name.
> (build_associate_name): Pass true to 'select_type' in call to
> previous.
> * parse.cc (parse_associate): If the selector is a inferred type
> the associate name is too. Make sure that function selector
> class and rank, if known, are passed to the associate name. If
> a function result exists, pass its typespec to the associate
> name.
> * primary.cc (gfc_match_varspec): If a scalar derived type
> select type temporary has an array reference, match the array
> reference, treating this in the same way as an equivalence
> member. If this is a inferred type with a component reference,
> call 'gfc_find_derived_types' to find a suitable derived type.
> * resolve.cc (resolve_variable): Call new function below.
> (gfc_fixup_inferred_type_refs): New function to ensure that the
> expression references for a inferred type are consistent with
> the now fixed up selector.
> (resolve_assoc_var): Ensure that derived type or class function
> selectors transmit the correct arrayspec to the associate name.
> (resolve_select_type): If the selector is an associate name of
> inferred type and has no component references, the associate
> name should have its typespec.
> * symbol.cc (gfc_set_default_type): If an associate name with
> unknown type has a selector expression, try resolving the expr.
> (find_derived_types, gfc_find_derived_types): New functions
> that search for a derived type with a given name.
> * trans-expr.cc (gfc_conv_variable): Some inferred type exprs
> escape resolution so call 'gfc_fixup_inferred_type_refs'.
> * trans-stmt.cc (trans_associate_var): Tidy up expression for
> 'class_target'. Correctly handle selectors that are class array
> references, passed as derived types.
>
> gcc/testsuite/
> PR fortran/87477
> PR fortran/89645
> PR fortran/99065
> * gfortran.dg/associate_64.f90 : New test
>


^ permalink raw reply	[flat|nested] 7+ messages in thread

* Re: [Patch, fortran PR89645/99065 No IMPLICIT type error with: ASSOCIATE( X => function() )
  2024-01-08 21:53 ` Harald Anlauf
@ 2024-03-03 16:04   ` Paul Richard Thomas
  2024-03-03 20:20     ` Harald Anlauf
  0 siblings, 1 reply; 7+ messages in thread
From: Paul Richard Thomas @ 2024-03-03 16:04 UTC (permalink / raw)
  To: Harald Anlauf; +Cc: fortran, gcc-patches, Steve Kargl


[-- Attachment #1.1: Type: text/plain, Size: 4719 bytes --]

Hi Harald,

Please find an updated version of the patch that rolls in Steve's patch for
PR114141, fixes unlimited polymorphic function selectors and cures the
memory leaks. I apologise for not working on this sooner but, as I informed
you, I have been away for an extended trip to Australia.

The chunks that fix PR114141 are picked out in comment 14 to the PR and the
cures to the problems that you found in the first review are found at
trans-stmt.cc:2047-49.

Regtests fine. OK for trunk, bearing in mind that most of the patch is ring
fenced by the inferred_type flag?

Cheers

Paul


On Mon, 8 Jan 2024 at 21:53, Harald Anlauf <anlauf@gmx.de> wrote:

> Hi Paul,
>
> your patch looks already very impressive!
>
> Regarding the patch as is, I am still trying to grok it, even with your
> explanations at hand...
>
> While the testcase works as advertised, I noticed that it exhibits a
> runtime memleak that occurs for (likely) each case where the associate
> target is an allocatable, class-valued function result.
>
> I tried to produce a minimal testcase using class(*), which apparently
> is not handled by your patch (it ICEs for me):
>
> program p
>    implicit none
>    class(*), allocatable :: x(:)
>    x = foo()
>    call prt (x)
>    deallocate (x)
>    ! up to here no memleak...
>    associate (var => foo())
>      call prt (var)
>    end associate
> contains
>    function foo() result(res)
>      class(*), allocatable :: res(:)
>      res = [42]
>    end function foo
>    subroutine prt (x)
>      class(*), intent(in) :: x(:)
>      select type (x)
>      type is (integer)
>         print *, x
>      class default
>         stop 99
>      end select
>    end subroutine prt
> end
>
> Traceback (truncated):
>
> foo.f90:9:18:
>
>      9 |     call prt (var)
>        |                  1
> internal compiler error: tree check: expected record_type or union_type
> or qual_union_type, have function_type in gfc_class_len_get, at
> fortran/trans-expr.cc:271
> 0x19fd5d5 tree_check_failed(tree_node const*, char const*, int, char
> const*, ...)
>          ../../gcc-trunk/gcc/tree.cc:8952
> 0xe1562d tree_check3(tree_node*, char const*, int, char const*,
> tree_code, tree_code, tree_code)
>          ../../gcc-trunk/gcc/tree.h:3652
> 0xe3e264 gfc_class_len_get(tree_node*)
>          ../../gcc-trunk/gcc/fortran/trans-expr.cc:271
> 0xecda48 trans_associate_var
>          ../../gcc-trunk/gcc/fortran/trans-stmt.cc:2325
> 0xecdd09 gfc_trans_block_construct(gfc_code*)
>          ../../gcc-trunk/gcc/fortran/trans-stmt.cc:2383
> [...]
>
> I don't see anything wrong with it: NAG groks it, like Nvidia and Flang,
> while Intel crashes at runtime.
>
> Can you have another brief look?
>
> Thanks,
> Harald
>
>
> On 1/6/24 18:26, Paul Richard Thomas wrote:
> > These PRs come about because of gfortran's single pass parsing. If the
> > function in the title is parsed after the associate construct, then its
> > type and rank are not known. The point at which this becomes a problem is
> > when expressions within the associate block are parsed. primary.cc
> > (gfc_match_varspec) could already deal with intrinsic types and so
> > component references were the trigger for the problem.
> >
> > The two major parts of this patch are the fixup needed in
> gfc_match_varspec
> > and the resolution of  expressions with references in resolve.cc
> > (gfc_fixup_inferred_type_refs). The former relies on the two new
> functions
> > in symbol.cc to search for derived types with an appropriate component to
> > match the component reference and then set the associate name to have a
> > matching derived type. gfc_fixup_inferred_type_refs is called in
> resolution
> > and so the type of the selector function is known.
> > gfc_fixup_inferred_type_refs ensures that the component references use
> this
> > derived type and that array references occur in the right place in
> > expressions and match preceding array specs. Most of the work in
> preparing
> > the patch was sorting out cases where the selector was not a derived type
> > but, instead, a class function. If it were not for this, the patch would
> > have been submitted six months ago :-(
> >
> > The patch is relatively safe because most of the chunks are guarded by
> > testing for the associate name being an inferred type, which is set in
> > gfc_match_varspec. For this reason, I do not think it likely that the
> patch
> > will cause regressions. However, it is more than possible that variants
> not
> > appearing in the submitted testcase will throw up new bugs.
> >
> > Jerry has already given the patch a whirl and found that it applies
> > cleanly, regtests OK and works as advertised.
> >
> > OK for trunk?
> >
> > Paul
> ...snip...

[-- Attachment #2: resubmit.diff --]
[-- Type: text/x-patch, Size: 33421 bytes --]

diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index ce31a93abcd..abe89630be3 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -815,6 +815,56 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 }
 
 
+/* Change class, using gfc_build_class_symbol. This is needed for associate
+   names, when rank changes or a derived type is produced by resolution.  */
+
+void
+gfc_change_class (gfc_typespec *ts, symbol_attribute *sym_attr,
+		  gfc_array_spec *sym_as, int rank, int corank)
+{
+  symbol_attribute attr;
+  gfc_component *c;
+  gfc_array_spec *as = NULL;
+  gfc_symbol *der = ts->u.derived;
+
+  ts->type = BT_CLASS;
+  attr = *sym_attr;
+  attr.class_ok = 0;
+  attr.associate_var = 1;
+  attr.class_pointer = 1;
+  attr.allocatable = 0;
+  attr.pointer = 1;
+  attr.dimension = rank ? 1 : 0;
+  if (rank)
+    {
+      if (sym_as)
+	as = gfc_copy_array_spec (sym_as);
+      else
+	{
+	  as = gfc_get_array_spec ();
+	  as->rank = rank;
+	  as->type = AS_DEFERRED;
+	  as->corank = corank;
+	}
+    }
+  if (as && as->corank != 0)
+    attr.codimension = 1;
+
+  if (!gfc_build_class_symbol (ts, &attr, &as))
+    gcc_unreachable ();
+
+  gfc_set_sym_referenced (ts->u.derived);
+
+  /* Make sure the _vptr is set.  */
+  c = gfc_find_component (ts->u.derived, "_vptr", true, true, NULL);
+  if (c->ts.u.derived == NULL)
+    c->ts.u.derived = gfc_find_derived_vtab (der);
+  /* _vptr now has the _vtab in it, change it to the _vtype.  */
+  if (c->ts.u.derived->attr.vtab)
+    c->ts.u.derived = c->ts.u.derived->ts.u.derived;
+}
+
+
 /* Add a procedure pointer component to the vtype
    to represent a specific type-bound procedure.  */
 
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 7b154eb3ca7..99b577c91c4 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2692,11 +2692,20 @@ show_code_node (int level, gfc_code *c)
 
     case EXEC_BLOCK:
       {
-	const char* blocktype;
+	const char *blocktype, *sname = NULL;
 	gfc_namespace *saved_ns;
 	gfc_association_list *alist;
 
-	if (c->ext.block.assoc)
+	if (c->ext.block.ns && c->ext.block.ns->code
+	    && c->ext.block.ns->code->op == EXEC_SELECT_TYPE)
+	  {
+	    gfc_expr *fcn = c->ext.block.ns->code->expr1;
+	    blocktype = "SELECT TYPE";
+	    /* expr1 is _loc(assoc_name->vptr)  */
+	    if (fcn && fcn->expr_type == EXPR_FUNCTION)
+	      sname = fcn->value.function.actual->expr->symtree->n.sym->name;
+	  }
+	else if (c->ext.block.assoc)
 	  blocktype = "ASSOCIATE";
 	else
 	  blocktype = "BLOCK";
@@ -2704,7 +2713,7 @@ show_code_node (int level, gfc_code *c)
 	fprintf (dumpfile, "%s ", blocktype);
 	for (alist = c->ext.block.assoc; alist; alist = alist->next)
 	  {
-	    fprintf (dumpfile, " %s = ", alist->name);
+	    fprintf (dumpfile, " %s = ", sname ? sname : alist->name);
 	    show_expr (alist->target);
 	  }
 
@@ -2735,7 +2744,7 @@ show_code_node (int level, gfc_code *c)
       if (c->op == EXEC_SELECT_RANK)
 	fputs ("SELECT RANK ", dumpfile);
       else if (c->op == EXEC_SELECT_TYPE)
-	fputs ("SELECT TYPE ", dumpfile);
+	fputs ("SELECT CASE ", dumpfile); // Preceded by SELECT TYPE construct
       else
 	fputs ("SELECT CASE ", dumpfile);
       show_expr (c->expr1);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ebba2336e12..70b9faad074 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2963,6 +2963,11 @@ typedef struct gfc_association_list
   locus where;
 
   gfc_expr *target;
+
+  /* Used for inferring 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 inferred_type:1;
 }
 gfc_association_list;
 #define gfc_get_association_list() XCNEW (gfc_association_list)
@@ -3529,6 +3534,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 *);
@@ -3795,6 +3801,7 @@ void gfc_free_association_list (gfc_association_list *);
 void gfc_expression_rank (gfc_expr *);
 bool gfc_op_rank_conformable (gfc_expr *, gfc_expr *);
 bool gfc_resolve_ref (gfc_expr *);
+void gfc_fixup_inferred_type_refs (gfc_expr *);
 bool gfc_resolve_expr (gfc_expr *);
 void gfc_resolve (gfc_namespace *);
 void gfc_resolve_code (gfc_code *, gfc_namespace *);
@@ -3988,6 +3995,8 @@ unsigned int gfc_hash_value (gfc_symbol *);
 gfc_expr *gfc_get_len_component (gfc_expr *e, int);
 bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
 			     gfc_array_spec **);
+void gfc_change_class (gfc_typespec *, symbol_attribute *,
+		       gfc_array_spec *, int, int);
 gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
 gfc_symbol *gfc_find_vtab (gfc_typespec *);
 gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*,
@@ -4018,6 +4027,10 @@ bool gfc_may_be_finalized (gfc_typespec);
 #define IS_PROC_POINTER(sym) \
 	(sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym) \
 	 ? CLASS_DATA (sym)->attr.proc_pointer : sym->attr.proc_pointer)
+#define IS_INFERRED_TYPE(expr) \
+	(expr && expr->expr_type == EXPR_VARIABLE \
+	 && expr->symtree->n.sym->assoc \
+	 && expr->symtree->n.sym->assoc->inferred_type)
 
 /* frontend-passes.cc */
 
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index eee569dac91..64f61c50c66 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -1963,6 +1963,20 @@ gfc_match_associate (void)
 	  goto assocListError;
 	}
 
+      /* If the selector expression is enclosed in parentheses and the
+	 expression is not a variable, throw the parentheses away.  */
+      while (newAssoc->target->expr_type == EXPR_OP
+	     && newAssoc->target->value.op.op == INTRINSIC_PARENTHESES)
+	{
+	  if (newAssoc->target->value.op.op1->expr_type == EXPR_VARIABLE)
+	    break;
+	  else
+	    {
+	      gfc_expr *e = gfc_copy_expr (newAssoc->target->value.op.op1);
+	      gfc_replace_expr (newAssoc->target, e);
+	    }
+	}
+
       /* The `variable' field is left blank for now; because the target is not
 	 yet resolved, we can't use gfc_has_vector_subscript to determine it
 	 for now.  This is set during resolution.  */
@@ -6322,7 +6336,8 @@ gfc_match_select (void)
 /* Transfer the selector typespec to the associate name.  */
 
 static void
-copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
+copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector,
+				    bool select_type = false)
 {
   gfc_ref *ref;
   gfc_symbol *assoc_sym;
@@ -6405,12 +6420,30 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
     assoc_sym->as = NULL;
 
 build_class_sym:
-  if (selector->ts.type == BT_CLASS)
+  /* Deal with the very specific case of a SELECT_TYPE selector being an
+     associate_name whose type has been identified by component references.
+     It must be assumed that it will be identified as a CLASS expression,
+     so convert it now.  */
+  if (select_type
+      && IS_INFERRED_TYPE (selector)
+      && selector->ts.type == BT_DERIVED)
+    {
+      gfc_find_derived_vtab (selector->ts.u.derived);
+      /* The correct class container has to be available.  */
+      assoc_sym->ts.u.derived = selector->ts.u.derived;
+      assoc_sym->ts.type = BT_CLASS;
+      assoc_sym->attr.pointer = 1;
+      if (!selector->ts.u.derived->attr.is_class)
+	gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
+      associate->ts = assoc_sym->ts;
+    }
+  else if (selector->ts.type == BT_CLASS)
     {
       /* The correct class container has to be available.  */
       assoc_sym->ts.type = BT_CLASS;
       assoc_sym->ts.u.derived = CLASS_DATA (selector)
-	? CLASS_DATA (selector)->ts.u.derived : selector->ts.u.derived;
+				? CLASS_DATA (selector)->ts.u.derived
+				: selector->ts.u.derived;
       assoc_sym->attr.pointer = 1;
       gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
     }
@@ -6438,7 +6471,7 @@ build_associate_name (const char *name, gfc_expr **e1, gfc_expr **e2)
   if (expr2->ts.type == BT_UNKNOWN)
     sym->attr.untyped = 1;
   else
-    copy_ts_from_selector_to_associate (expr1, expr2);
+    copy_ts_from_selector_to_associate (expr1, expr2, true);
 
   sym->attr.flavor = FL_VARIABLE;
   sym->attr.referenced = 1;
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index a4fda6e5eb6..a2bf328f681 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5150,6 +5150,17 @@ parse_associate (void)
       sym->declared_at = a->where;
       gfc_set_sym_referenced (sym);
 
+      /* If the selector is a inferred type then the associate_name had better
+	 be as well. Use array references, if present, to identify it as an
+	 array.  */
+      if (IS_INFERRED_TYPE (a->target))
+	{
+	  sym->assoc->inferred_type = 1;
+	  for (gfc_ref *r = a->target->ref; r; r = r->next)
+	    if (r->type == REF_ARRAY)
+	      sym->attr.dimension = 1;
+	}
+
       /* Initialize the typespec.  It is not available in all cases,
 	 however, as it may only be set on the target during resolution.
 	 Still, sometimes it helps to have it right now -- especially
@@ -5176,21 +5187,41 @@ parse_associate (void)
 	       && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
 	sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
 
+      /* If the function has been parsed, go straight to the result to
+	 obtain the expression rank.  */
+      if (target->expr_type == EXPR_FUNCTION
+	  && target->symtree
+	  && target->symtree->n.sym)
+	{
+	  tsym = target->symtree->n.sym;
+	  if (!tsym->result)
+	    tsym->result = tsym;
+	  sym->ts = tsym->result->ts;
+	  if (sym->ts.type == BT_CLASS)
+	    {
+	      if (CLASS_DATA (sym)->as)
+		target->rank = CLASS_DATA (sym)->as->rank;
+	      sym->attr.class_ok = 1;
+	    }
+	  else
+	    target->rank = tsym->result->as ? tsym->result->as->rank : 0;
+	}
+
       /* Check if the target expression is array valued. This cannot be done
 	 by calling gfc_resolve_expr because the context is unavailable.
 	 However, the references can be resolved and the rank of the target
 	 expression set.  */
-      if (target->ref && gfc_resolve_ref (target)
+      if (!sym->assoc->inferred_type
+	  && target->ref && gfc_resolve_ref (target)
 	  && target->expr_type != EXPR_ARRAY
 	  && target->expr_type != EXPR_COMPCALL)
 	gfc_expression_rank (target);
 
       /* Determine whether or not function expressions with unknown type are
 	 structure constructors. If so, the function result can be converted
-	 to be a derived type.
-	 TODO: Deal with references to sibling functions that have not yet been
-	 parsed (PRs 89645 and 99065).  */
-      if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN)
+	 to be a derived type.  */
+      if (target->expr_type == EXPR_FUNCTION
+	  && target->ts.type == BT_UNKNOWN)
 	{
 	  gfc_symbol *derived;
 	  /* The derived type has a leading uppercase character.  */
@@ -5200,16 +5231,7 @@ parse_associate (void)
 	    {
 	      sym->ts.type = BT_DERIVED;
 	      sym->ts.u.derived = derived;
-	    }
-	  else if (target->symtree && (tsym = target->symtree->n.sym))
-	    {
-	      sym->ts = tsym->result ? tsym->result->ts : tsym->ts;
-	      if (sym->ts.type == BT_CLASS)
-		{
-		  if (CLASS_DATA (sym)->as)
-		    target->rank = CLASS_DATA (sym)->as->rank;
-		  sym->attr.class_ok = 1;
-		}
+	      sym->assoc->inferred_type = 0;
 	    }
 	}
 
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 12e7bf3c873..c64ebf67c70 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 inferred_type;
   locus old_loc;
   char sep;
 
@@ -2087,6 +2088,18 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
   if (sym->assoc && sym->assoc->target)
     tgt_expr = sym->assoc->target;
 
+  inferred_type = IS_INFERRED_TYPE (primary);
+
+  /* SELECT TYPE and SELECT RANK temporaries within an ASSOCIATE block, whose
+     selector has not been parsed, can generate errors with array and component
+     refs.. Use 'inferred_type' as a flag to suppress these errors.  */
+  if (!inferred_type
+      && (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
+      && !sym->attr.codimension
+      && sym->attr.select_type_temporary
+      && !sym->attr.select_rank_temporary)
+    inferred_type = true;
+
   /* For associate names, we may not yet know whether they are arrays or not.
      If the selector expression is unambiguously an array; eg. a full array
      or an array section, then the associate name must be an array and we can
@@ -2136,7 +2149,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	sym->ts.u.derived = tgt_expr->ts.u.derived;
     }
 
-  if ((equiv_flag && gfc_peek_ascii_char () == '(')
+  if ((inferred_type && !sym->as && gfc_peek_ascii_char () == '(')
+      || (equiv_flag && gfc_peek_ascii_char () == '(')
       || gfc_peek_ascii_char () == '[' || sym->attr.codimension
       || (sym->attr.dimension && sym->ts.type != BT_CLASS
 	  && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
@@ -2194,7 +2208,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 || inferred_type))
     {
       match mm;
       old_loc = gfc_current_locus;
@@ -2209,7 +2223,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 || inferred_type)
+      && m == MATCH_YES)
     {
       bool permissible;
 
@@ -2220,7 +2235,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 			|| tgt_expr->symtree->n.sym->attr.if_source
 								== IFSRC_DECL);
       permissible = permissible
-		    || (tgt_expr && tgt_expr->expr_type == EXPR_OP);
+		    || (tgt_expr && (tgt_expr->expr_type == EXPR_OP
+			|| (inquiry && tgt_expr->expr_type == EXPR_FUNCTION)));
 
       if (permissible)
 	{
@@ -2228,6 +2244,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 || inferred_type)
+	  && gfc_find_derived_types (sym, gfc_current_ns, name))
+	{
+	  sym->assoc->inferred_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);
@@ -2294,6 +2335,17 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 		      break;
 		    }
 
+		  /* With 'associate(x => sin(cmplx(1,0)))', gfortran gets here
+		     with an unknown type-spec for primary, but it can be
+		     gleaned from the associate target.  */
+		  if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
+		      && primary->ts.type == BT_UNKNOWN
+		      && primary->symtree && primary->symtree->n.sym
+		      && primary->symtree->n.sym->assoc
+		      && primary->symtree->n.sym->assoc->target
+		      && primary->symtree->n.sym->assoc->target->ts.type == BT_COMPLEX)
+		    primary->ts = primary->symtree->n.sym->assoc->target->ts;
+
 		  if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
 		      && primary->ts.type != BT_COMPLEX)
 		    {
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 02acc4aef31..3f48ec34932 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5866,6 +5866,13 @@ resolve_variable (gfc_expr *e)
       return false;
     }
 
+  /* Guessed type variables are associate_names whose selector had not been
+     parsed at the time that the construct was parsed. Now the namespace is
+     being resolved, the TKR of the selector will be available for fixup of
+     the associate_name.  */
+  if (IS_INFERRED_TYPE (e) && e->ref)
+    gfc_fixup_inferred_type_refs (e);
+
   /* For variables that are used in an associate (target => object) where
      the object's basetype is array valued while the target is scalar,
      the ts' type of the component refs is still array valued, which
@@ -6171,6 +6178,115 @@ resolve_procedure:
 }
 
 
+/* 'sym' was initially guessed to be derived type but has been corrected
+   in resolve_assoc_var to be a class entity or the derived type correcting.
+   If a class entity it will certainly need the _data reference or the
+   reference derived type symbol correcting in the first component ref if
+   a derived type.  */
+
+void
+gfc_fixup_inferred_type_refs (gfc_expr *e)
+{
+  gfc_ref *ref;
+  gfc_symbol *sym, *derived;
+  gfc_expr *target;
+  sym = e->symtree->n.sym;
+
+  /* This is an associate_name whose selector is a component ref of a selector
+     that is a inferred type associate_name.  */
+  if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+    {
+      e->rank = sym->as ? sym->as->rank : 0;
+      sym->attr.dimension = e->rank ? 1 : 0;
+      if (!e->rank && e->ref->type == REF_ARRAY)
+	{
+	  ref = e->ref;
+	  e->ref = ref->next;
+	  free (ref);
+	}
+      return;
+    }
+
+  derived = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->ts.u.derived
+				     : sym->ts.u.derived;
+
+  /* Ensure that class symbols have an array spec and ensure that there
+     is a _data field reference following class type references.  */
+  if (sym->ts.type == BT_CLASS
+      && sym->assoc->target->ts.type == BT_CLASS)
+    {
+      e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0;
+      sym->attr.dimension = 0;
+      CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0;
+      if (e->ref && (e->ref->type != REF_COMPONENT
+		     || e->ref->u.c.component->name[0] != '_'))
+	{
+	  ref = gfc_get_ref ();
+	  ref->type = REF_COMPONENT;
+	  ref->next = e->ref;
+	  e->ref = ref;
+	  ref->u.c.component = gfc_find_component (sym->ts.u.derived, "_data",
+						   true, true, NULL);
+	  ref->u.c.sym = sym->ts.u.derived;
+	}
+    }
+
+  /* Proceed as far as the first component reference and ensure that the
+     correct derived type is being used.  */
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      {
+	if (ref->u.c.component->name[0] != '_')
+	  ref->u.c.sym = derived;
+	else
+	  ref->u.c.sym = sym->ts.u.derived;
+	break;
+      }
+
+  /* Verify that the type inferrence mechanism has not introduced a spurious
+     array reference.  This can happen with an associate name, whose selector
+     is an element of another inferred type.  */
+  target = e->symtree->n.sym->assoc->target;
+  if (!(sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as)
+      && e != target && !target->rank)
+    {
+      /* First case: array ref after the scalar class or derived associate_name.  */
+      if (e->ref && e->ref->type == REF_ARRAY
+	  && e->ref->u.ar.type != AR_ELEMENT)
+	{
+	  ref = e->ref;
+	  e->ref = ref->next;
+	  free (ref);
+
+	  /* If it hasn't a ref to the '_data' field supply one.  */
+	  if (sym->ts.type == BT_CLASS
+	      && !(e->ref->type == REF_COMPONENT
+		   && strcmp (e->ref->u.c.component->name, "_data")))
+	    {
+	      gfc_ref *new_ref;
+	      gfc_find_component (e->symtree->n.sym->ts.u.derived,
+				  "_data", true, true, &new_ref);
+	      new_ref->next = e->ref;
+	      e->ref = new_ref;
+	    }
+	}
+      /* 2nd case: a ref to the '_data' field followed by an array ref.  */
+      else if (e->ref && e->ref->type == REF_COMPONENT
+	       && strcmp (e->ref->u.c.component->name, "_data") == 0
+	       && e->ref->next && e->ref->next->type == REF_ARRAY
+	       && e->ref->next->u.ar.type != AR_ELEMENT)
+	{
+	  ref = e->ref->next;
+	  e->ref->next = e->ref->next->next;
+	  free (ref);
+	}
+    }
+
+  /* Now that all the references are OK, get the expression rank.  */
+  gfc_expression_rank (e);
+}
+
+
 /* Checks to see that the correct symbol has been host associated.
    The only situations where this arises are:
 	(i)  That in which a twice contained function is parsed after
@@ -9263,6 +9379,46 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
       return;
     }
 
+  if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target))
+    {
+      symbol_attribute attr;
+
+      /* By now, the type of the target has been fixed up.  */
+      if (sym->ts.type == BT_DERIVED
+	  && target->ts.type == BT_CLASS
+	  && !UNLIMITED_POLY (target))
+	{
+	  sym->ts = CLASS_DATA (target)->ts;
+	  if (!sym->as)
+	    sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as);
+	  attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
+	  sym->attr.dimension = target->rank ? 1 : 0;
+	  gfc_change_class (&sym->ts, &attr, sym->as,
+			    target->rank, gfc_get_corank (target));
+	  sym->as = NULL;
+	}
+      else if (target->ts.type == BT_DERIVED
+	       && target->symtree->n.sym->ts.type == BT_CLASS
+	       && IS_INFERRED_TYPE (target)
+	       && target->ref && target->ref->next
+	       && target->ref->next->type == REF_ARRAY
+	       && !target->ref->next->next)
+	{
+	  sym->ts = target->ts;
+	  attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
+	  sym->attr.dimension = target->rank ? 1 : 0;
+	  gfc_change_class (&sym->ts, &attr, sym->as,
+			    target->rank, gfc_get_corank (target));
+	  sym->as = NULL;
+	  target->ts = sym->ts;
+	}
+      else if ((target->ts.type == BT_DERIVED)
+	       || (sym->ts.type == BT_CLASS && target->ts.type == BT_CLASS
+		   && CLASS_DATA (target)->as && !CLASS_DATA (sym)->as))
+	sym->ts = target->ts;
+    }
+
+
   if (target->expr_type == EXPR_NULL)
     {
       gfc_error ("Selector at %L cannot be NULL()", &target->where);
@@ -9289,15 +9445,50 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 			  || gfc_is_ptr_fcn (target));
 
   /* Finally resolve if this is an array or not.  */
+  if (target->expr_type == EXPR_FUNCTION
+      && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
+    {
+      gfc_expression_rank (target);
+      if (target->ts.type == BT_DERIVED
+	  && !sym->as
+	  && target->symtree->n.sym->as)
+	{
+	  sym->as = gfc_copy_array_spec (target->symtree->n.sym->as);
+	  sym->attr.dimension = 1;
+	}
+      else if (target->ts.type == BT_CLASS
+	       && CLASS_DATA (target)->as)
+	{
+	  target->rank = CLASS_DATA (target)->as->rank;
+	  if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
+	    {
+	      sym->ts = target->ts;
+	      sym->attr.dimension = 0;
+	    }
+	}
+    }
+
+
   if (sym->attr.dimension && target->rank == 0)
     {
       /* primary.cc makes the assumption that a reference to an associate
 	 name followed by a left parenthesis is an array reference.  */
-      if (sym->ts.type != BT_CHARACTER)
-	gfc_error ("Associate-name %qs at %L is used as array",
-		   sym->name, &sym->declared_at);
-      sym->attr.dimension = 0;
-      return;
+      if (sym->assoc->inferred_type && sym->ts.type != BT_CLASS)
+	{
+	  gfc_expression_rank (sym->assoc->target);
+	  sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
+	  if (!sym->attr.dimension && sym->as)
+	    sym->as = NULL;
+	}
+
+      if (sym->attr.dimension && target->rank == 0)
+	{
+	  if (sym->ts.type != BT_CHARACTER)
+	    gfc_error ("Associate-name %qs at %L is used as array",
+		       sym->name, &sym->declared_at);
+	  sym->attr.dimension = 0;
+	  return;
+	}
     }
 
   /* We cannot deal with class selectors that need temporaries.  */
@@ -9356,7 +9547,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	     correct this now.  */
 	  gfc_typespec *ts = &target->ts;
 	  gfc_ref *ref;
-	  gfc_component *c;
+
 	  for (ref = target->ref; ref != NULL; ref = ref->next)
 	    {
 	      switch (ref->type)
@@ -9374,32 +9565,15 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	    }
 	  /* Create a scalar instance of the current class type.  Because the
 	     rank of a class array goes into its name, the type has to be
-	     rebuild.  The alternative of (re-)setting just the attributes
+	     rebuilt.  The alternative of (re-)setting just the attributes
 	     and as in the current type, destroys the type also in other
 	     places.  */
 	  as = NULL;
 	  sym->ts = *ts;
 	  sym->ts.type = BT_CLASS;
 	  attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
-	  attr.class_ok = 0;
-	  attr.associate_var = 1;
-	  attr.dimension = attr.codimension = 0;
-	  attr.class_pointer = 1;
-	  if (!gfc_build_class_symbol (&sym->ts, &attr, &as))
-	    gcc_unreachable ();
-	  /* Make sure the _vptr is set.  */
-	  c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL);
-	  if (c->ts.u.derived == NULL)
-	    c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived);
-	  CLASS_DATA (sym)->attr.pointer = 1;
-	  CLASS_DATA (sym)->attr.class_pointer = 1;
-	  gfc_set_sym_referenced (sym->ts.u.derived);
-	  gfc_commit_symbol (sym->ts.u.derived);
-	  /* _vptr now has the _vtab in it, change it to the _vtype.  */
-	  if (c->ts.u.derived->attr.vtab)
-	    c->ts.u.derived = c->ts.u.derived->ts.u.derived;
-	  c->ts.u.derived->ns->types_resolved = 0;
-	  resolve_types (c->ts.u.derived->ns);
+	  gfc_change_class (&sym->ts, &attr, as, 0, 0);
+	  sym->as = NULL;
 	}
     }
 
@@ -9443,6 +9617,14 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	}
     }
 
+  if (sym->ts.type == BT_CLASS
+      && IS_INFERRED_TYPE (target)
+      && target->ts.type == BT_DERIVED
+      && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived
+      && target->ref && target->ref->next
+      && target->ref->next->type == REF_ARRAY)
+    target->ts = target->symtree->n.sym->ts;
+
   /* If the target is a good class object, so is the associate variable.  */
   if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
     sym->attr.class_ok = 1;
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 5d9852c79e0..6d8cdf39f94 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -291,6 +291,19 @@ bool
 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
 {
   gfc_typespec *ts;
+  gfc_expr *e;
+
+  /* Check to see if a function selector of unknown type can be resolved.  */
+  if (sym->assoc
+      && (e = sym->assoc->target)
+      && e->expr_type == EXPR_FUNCTION)
+    {
+      if (e->ts.type == BT_UNKNOWN)
+	gfc_resolve_expr (e);
+      sym->ts = e->ts;
+      if (sym->ts.type != BT_UNKNOWN)
+	return true;
+    }
 
   if (sym->ts.type != BT_UNKNOWN)
     gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
@@ -307,7 +320,7 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
 		       "; did you mean %qs?",
 		       sym->name, &sym->declared_at, guessed);
 	  else
-	    gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type(symbol)",
 		       sym->name, &sym->declared_at);
 	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
 	}
@@ -2402,6 +2415,66 @@ 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 infer 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
+      && !st->n.sym->attr.is_class
+      && ((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
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d63c304661a..bd14ce99ed6 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -3142,6 +3142,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
       gcc_assert (se->string_length);
     }
 
+  /* Some expressions leak through that haven't been fixed up.  */
+  if (IS_INFERRED_TYPE (expr) && expr->ref)
+    gfc_fixup_inferred_type_refs (expr);
+
   gfc_typespec *ts = &sym->ts;
   while (ref)
     {
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index e09828e218b..1ec76f9778c 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1747,9 +1747,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   e = sym->assoc->target;
 
   class_target = (e->expr_type == EXPR_VARIABLE)
-		    && e->ts.type == BT_CLASS
-		    && (gfc_is_class_scalar_expr (e)
-			|| gfc_is_class_array_ref (e, NULL));
+		  && e->ts.type == BT_CLASS
+		  && (gfc_is_class_scalar_expr (e)
+		      || gfc_is_class_array_ref (e, NULL));
 
   unlimited = UNLIMITED_POLY (e);
 
@@ -2043,6 +2043,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	{
 	  gfc_conv_expr (&se, e);
 	  se.expr = gfc_evaluate_now (se.expr, &se.pre);
+	  /* Finalize the expression and free if it is allocatable.  */
+	  gfc_finalize_tree_expr (&se, NULL, gfc_expr_attr (e), e->rank);
+	  gfc_add_block_to_block (&se.post, &se.finalblock);
+	  need_len_assign = false;
 	}
       else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
 	{
@@ -2157,26 +2161,36 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	    {
 	      tree stmp;
 	      tree dtmp;
+	      tree ctmp;
 
-	      se.expr = ctree;
+	      ctmp = ctree;
 	      dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl));
 	      ctree = gfc_create_var (dtmp, "class");
 
-	      stmp = gfc_class_data_get (se.expr);
+	      if (IS_INFERRED_TYPE (e)
+		  && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
+		stmp = se.expr;
+	      else
+		stmp = gfc_class_data_get (ctmp);
+
 	      /* Coarray scalar component expressions can emerge from
 		 the front end as array elements of the _data field.  */
 	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp)))
 		stmp = gfc_conv_descriptor_data_get (stmp);
+
+	      if (!POINTER_TYPE_P (TREE_TYPE (stmp)))
+		stmp = gfc_build_addr_expr (NULL, stmp);
+
 	      dtmp = gfc_class_data_get (ctree);
 	      stmp = fold_convert (TREE_TYPE (dtmp), stmp);
 	      gfc_add_modify (&se.pre, dtmp, stmp);
-	      stmp = gfc_class_vptr_get (se.expr);
+	      stmp = gfc_class_vptr_get (ctmp);
 	      dtmp = gfc_class_vptr_get (ctree);
 	      stmp = fold_convert (TREE_TYPE (dtmp), stmp);
 	      gfc_add_modify (&se.pre, dtmp, stmp);
 	      if (UNLIMITED_POLY (sym))
 		{
-		  stmp = gfc_class_len_get (se.expr);
+		  stmp = gfc_class_len_get (ctmp);
 		  dtmp = gfc_class_len_get (ctree);
 		  stmp = fold_convert (TREE_TYPE (dtmp), stmp);
 		  gfc_add_modify (&se.pre, dtmp, stmp);

[-- Attachment #3: associate_66.f90 --]
[-- Type: text/x-fortran, Size: 1210 bytes --]

! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! Tests unlimited polymorphic function selectors in ASSOCIATE.
!
! Contributed by Harald Anlauf  <anlauf@gmx.de> in
! https://gcc.gnu.org/pipermail/fortran/2024-January/060098.html
!
program p
   implicit none
!             scalar             array
   associate (var1 => foo1(),    var2 => foo2())
    call prt (var1);   call prt (var2)
   end associate
contains
! Scalar value
   function foo1() result(res)
     class(*), allocatable :: res
     res = 42.0
   end function foo1
! Array value
   function foo2() result(res)
     class(*), allocatable :: res(:)
     res = [42, 84]
   end function foo2
! Test the associate-name value
   subroutine prt (x)
     class(*), intent(in) :: x(..)
     logical :: ok = .false.
     select rank(x)
       rank (0)
         select type (x)
           type is (real)
           if (int(x*10) .eq. 420) ok = .true.
         end select
       rank (1)
         select type (x)
           type is (integer)
           if (all (x .eq. [42, 84])) ok = .true.
         end select
     end select
     if (.not.ok) stop 1
   end subroutine prt
end
! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } }

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

! { dg-do run }
! Test fix for PR114141
! Contributed by Steve Kargl  <sgk@troutmask.apl.washington.edu>
program foo
   implicit none
   real :: y
   complex :: z = cmplx(-1,0)
   associate (x => log(cmplx(-1,0)))
      y = x%im  ! Gave 'Symbol ‘x’ at (1) has no IMPLICIT type'
      if (int(100*y)-314 /= 0) stop 1
   end associate

! Check wrinkle in comment 1 (parentheses around selector) of the PR is fixed.
   associate (x => ((log(cmplx(-1,0)))))
      y = x%im  ! Gave 'The RE or IM part_ref at (1) must be applied to a
                ! COMPLEX expression'
      if (int(100*y)-314 /= 0) stop 2
   end associate

! Make sure that IMAG intrinsic is OK.
   associate (x => ((log(cmplx(-1,0)))))
      y = imag (x)
      if (int(100*y)-314 /= 0) stop 3
   end associate
end program

[-- Attachment #5: associate_64.f90 --]
[-- Type: text/x-fortran, Size: 9124 bytes --]

! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! Tests the fix for PR89645 and 99065, in which derived type or class functions,
! used as associate selectors and which were parsed after the containing scope
! of the associate statement, caused "no IMPLICIT type" and "Syntax" errors.
!
! Contributed by Ian Harvey  <ian_harvey@bigpond.com>
!
module m
  implicit none
  type t
    integer :: i = 0
  end type t
  integer :: i = 0
  type(t), parameter :: test_array (2) = [t(42),t(84)], &
                        test_scalar = t(99)
end module m

! DERIVED TYPE VERSION OF THE PROBLEM, AS REPORTED IN THE PRs
module type_selectors
  use m
  implicit none
  private
  public foo1
contains
! Since these functions are parsed first, the symbols are available for
! parsing in 'foo'.
  function bar1() result(res) ! The array version caused syntax errors in foo
    type(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end
  function bar2() result(res) ! Scalar class functions were OK - test anyway
    type(t), allocatable :: res
    allocate (res, source = test_scalar)
  end
  subroutine foo1()
! First the array selector
    associate (var1 => bar1())
      if (any (var1%i .ne. test_array%i)) stop 1
      if (var1(2)%i .ne. test_array(2)%i) stop 2
    end associate
! Now the scalar selector
    associate (var2 => bar2())
      if (var2%i .ne. test_scalar%i) stop 3
    end associate

! Now the array selector that needed fixing up because the function follows....
    associate (var1 => bar3())
      if (any (var1%i .ne. test_array%i)) stop 4
      if (var1(2)%i .ne. test_array(2)%i) stop 5
    end associate
! ....and equivalent scalar selector
    associate (var2 => bar4())
      if (var2%i .ne. test_scalar%i) stop 6
    end associate
  end subroutine foo1

! These functions are parsed after 'foo' so the symbols were not available
! for the selectors and the fixup, tested here, was necessary.
  function bar3() result(res)
    class(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end

  function bar4() result(res)
    class(t), allocatable :: res
    allocate (res, source = t(99))
  end
end module type_selectors

! CLASS VERSION OF THE PROBLEM, WHICH REQUIRED MOST OF THE WORK!
module class_selectors
  use m
  implicit none
  private
  public foo2
contains

! Since these functions are parsed first, the symbols are available for
! parsing in 'foo'.
  function bar1() result(res) ! The array version caused syntax errors in foo
    class(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end

  function bar2() result(res) ! Scalar class functions were OK - test anyway
    class(t), allocatable :: res
    allocate (res, source = t(99))
  end

  subroutine foo2()
! First the array selector
    associate (var1 => bar1())
      if (any (var1%i .ne. test_array%i)) stop 7
      if (var1(2)%i .ne. test_array(2)%i) stop 8
      select type (x => var1)
        type is (t)
          if (any (x%i .ne. test_array%i)) stop 9
          if (x(1)%i .ne. test_array(1)%i) stop 10
        class default
          stop 11
      end select
    end associate

! Now scalar selector
    associate (var2 => bar2())
      select type (z => var2)
        type is (t)
          if (z%i .ne. test_scalar%i) stop 12
        class default
          stop 13
      end select
    end associate

! This is the array selector that needed the fixup.
    associate (var1 => bar3())
      if (any (var1%i .ne. test_array%i)) stop 14
      if (var1(2)%i .ne. test_array(2)%i) stop 15
      select type (x => var1)
        type is (t)
          if (any (x%i .ne. test_array%i)) stop 16
          if (x(1)%i .ne. test_array(1)%i) stop 17
        class default
          stop 18
      end select
    end associate

! Now the equivalent scalar selector
    associate (var2 => bar4())
      select type (z => var2)
        type is (t)
          if (z%i .ne. test_scalar%i) stop 19
        class default
          stop 20
      end select
    end associate

  end subroutine foo2

! These functions are parsed after 'foo' so the symbols were not available
! for the selectors and the fixup, tested here, was necessary.
  function bar3() result(res)
    class(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end

  function bar4() result(res)
    class(t), allocatable :: res
    allocate (res, source = t(99))
  end
end module class_selectors

! THESE TESTS CAUSED PROBLEMS DURING DEVELOPMENT FOR BOTH PARSING ORDERS.
module problem_selectors
  implicit none
  private
  public foo3, foo4
  type t
    integer :: i
  end type t
  type s
    integer :: i
    type(t) :: dt
  end type s
  type(t), parameter :: test_array (2) = [t(42),t(84)], &
                        test_scalar = t(99)
  type(s), parameter :: test_sarray (2) = [s(142,t(42)),s(184,t(84))]
contains

  subroutine foo3()
    integer :: i
    block
      associate (var1 => bar7())
        if (any (var1%i .ne. test_array%i)) stop 21
        if (var1(2)%i .ne. test_array(2)%i) stop 22
        associate (z => var1(1)%i)
           if (z .ne. 42) stop 23
        end associate
    end associate
    end block

    associate (var2 => bar8())
      i = var2(2)%i
      associate (var3 => var2%dt)
        if (any (var3%i .ne. test_sarray%dt%i)) stop 24
      end associate
      associate (var4 => var2(2))
        if (var4%i .ne. 184) stop 25
      end associate
    end associate
  end subroutine foo3

  function bar7() result(res)
    type(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end

  function bar8() result(res)
    type(s), allocatable :: res(:)
    allocate (res, source = test_sarray)
  end

  subroutine foo4()
    integer :: i
    block
      associate (var1 => bar7())
        if (any (var1%i .ne. test_array%i)) stop 26
        if (var1(2)%i .ne. test_array(2)%i) stop 27
        associate (z => var1(1)%i)
           if (z .ne. 42) stop 28
        end associate
    end associate
    end block

    associate (var2 => bar8())
      i = var2(2)%i
      associate (var3 => var2%dt)
        if (any (var3%i .ne. test_sarray%dt%i)) stop 29
      end associate
      associate (var4 => var2(2))
        if (var4%i .ne. 184) stop 30
      end associate
    end associate
  end subroutine foo4

end module problem_selectors

module more_problem_selectors
  implicit none
  private
  public foo5, foo6
  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 foo5()
    associate (var3 => bar3())
      if (var3%i .ne. 42) stop 31
      if (var3%dt%i .ne. 84) stop 32
    end associate

! Repeat with class version
    associate (var4 => bar4())
      if (var4%i .ne. 84) stop 33
      if (var4%dt%i .ne. 168) stop 34
      select type (x => var4)
        type is (s)
          if (x%i .ne. var4%i) stop 35
          if (x%dt%i .ne. var4%dt%i) stop 36
        class default
          stop 37
      end select
    end associate

! Ditto with no type component clues for select type
    associate (var5 => bar4())
      select type (z => var5)
        type is (s)
          if (z%i .ne. 84) stop 38
          if (z%dt%i .ne. 168) stop 39
        class default
          stop 40
      end select
    end associate
  end subroutine foo5

! Now the array versions
  subroutine foo6()
    class(s), allocatable :: elem
    associate (var6 => bar5())
      if (var6(1)%i .ne. 42) stop 41
      if (any (var6%dt%i .ne. [84])) stop 42
    end associate

! Class version with an assignment to a named variable
    associate (var7 => bar6())
      elem = var7(2)
      if (any (var7%i .ne. [84, 168])) stop 43
      if (any (var7%dt%i .ne. [168, 336])) stop 44
    end associate
    if (elem%i .ne. 168) stop 45
    if (elem%dt%i .ne. 336) stop 46

    select type (z => elem)
      type is (s)
        if (z%i .ne. 168) stop 47
        if (z%dt%i .ne. 336) stop 48
      class default
        stop 49
    end select

! Array version without type clues before select type
    associate (var8 => bar6())
      select type (z => var8)
        type is (s)
          if (any (z%i .ne. [84,168])) stop 50
          if (any (z%dt%i .ne. [168,336])) stop 51
        class default
          stop 52
      end select
    end associate
  end subroutine foo6

  type(s) function bar3()
    bar3= s(42, t(84))
  end

  function bar4() result(res)
    class(s), allocatable :: res
    res = s(84, t(168))
  end

  function bar5() result (res)
    type(s), allocatable :: res(:)
    res = [s(42, t(84))]
  end

  function bar6() result (res)
    class(s), allocatable :: res(:)
    res = [s(84, t(168)),s(168, t(336))]
  end

end module more_problem_selectors

program test
  use type_selectors
  use class_selectors
  use problem_selectors
  use more_problem_selectors
  call foo1()
  call foo2()
  call foo3()
  call foo4()
  call foo5()
  call foo6()
end program test
! { dg-final { scan-tree-dump-times "__builtin_free" 18 "original" } }

[-- Attachment #6: Change99065.Logs --]
[-- Type: application/octet-stream, Size: 3094 bytes --]

Fortran: Fix class/derived/complex function associate selectors [PR87477]

2024-03-03  Paul Thomas  <pault@gcc.gnu.org>
	    Steve Kargl  <sgk@troutmask.apl.washington.edu>

gcc/fortran
	PR fortran/87477
	PR fortran/89645
	PR fortran/99065
	PR fortran/114141
	* class.cc (gfc_change_class): New function needed for
	associate names, when rank changes or a derived type is
	produced by resolution
	* dump-parse-tree.cc (show_code_node): Make output for SELECT
	TYPE more comprehensible.
	* gfortran.h : Add 'gfc_association_list' to structure
	'gfc_association_list'. Add prototypes for
	'gfc_find_derived_types', 'gfc_fixup_inferred_type_refs' and
	'gfc_change_class'. Add macro IS_INFERRED_TYPE.
	* match.cc (gfc_match_associate): Eliminate parentheses from
	selector expression except for variables.
	(copy_ts_from_selector_to_associate): Add bolean arg
	'select_type' with default false. If this is a select type name
	and the selector is a inferred type, build the class type and
	apply it to the associate name.
	(build_associate_name): Pass true to 'select_type' in call to
	previous.
	* parse.cc (parse_associate): If the selector is a inferred type
	the associate name is too. Make sure that function selector
	class and rank, if known, are passed to the associate name. If
	a function result exists, pass its typespec to the associate
	name.
	* primary.cc (gfc_match_varspec): If a scalar derived type
	select type temporary has an array reference, match the array
	reference, treating this in the same way as an equivalence
	member. If this is a inferred type with a component reference,
	call 'gfc_find_derived_types' to find a suitable derived type.
	If this is an inquiry reference, the target expression is
	permissable and can be resolved and the primary expression must
	be complex for re and im references.
	* resolve.cc (resolve_variable): Call new function below.
	(gfc_fixup_inferred_type_refs): New function to ensure that the
	expression references for a inferred type are consistent with
	the now fixed up selector.
	(resolve_assoc_var): Ensure that derived type or class function
	selectors transmit the correct arrayspec to the associate name.
	(resolve_select_type): If the selector is an associate name of
	inferred type and has no component references, the associate
	name should have its typespec.
	* symbol.cc (gfc_set_default_type): If an associate name with
	unknown type has a selector expression, try resolving the expr.
	(find_derived_types, gfc_find_derived_types): New functions
	that search for a derived type with a given name.
	* trans-expr.cc (gfc_conv_variable): Some inferred type exprs
	escape resolution so call 'gfc_fixup_inferred_type_refs'.
	* trans-stmt.cc (trans_associate_var): Tidy up expression for
	'class_target'. Correctly handle selectors that are class
	functions and class array references, passed as derived types.

gcc/testsuite/
	PR fortran/87477
	PR fortran/89645
	PR fortran/99065
	* gfortran.dg/associate_64.f90 : New test
	* gfortran.dg/associate_66.f90 : New test

	PR fortran/114141
	* gfortran.dg/associate_65.f90 : New test

^ permalink raw reply	[flat|nested] 7+ messages in thread

* Re: [Patch, fortran PR89645/99065 No IMPLICIT type error with: ASSOCIATE( X => function() )
  2024-03-03 16:04   ` Paul Richard Thomas
@ 2024-03-03 20:20     ` Harald Anlauf
  2024-03-12 14:54       ` Paul Richard Thomas
  0 siblings, 1 reply; 7+ messages in thread
From: Harald Anlauf @ 2024-03-03 20:20 UTC (permalink / raw)
  To: Paul Richard Thomas; +Cc: fortran, gcc-patches, Steve Kargl

Hi Paul,

welcome back!

On 3/3/24 17:04, Paul Richard Thomas wrote:
> Hi Harald,
>
> Please find an updated version of the patch that rolls in Steve's patch for
> PR114141, fixes unlimited polymorphic function selectors and cures the
> memory leaks. I apologise for not working on this sooner but, as I informed
> you, I have been away for an extended trip to Australia.
>
> The chunks that fix PR114141 are picked out in comment 14 to the PR and the
> cures to the problems that you found in the first review are found at
> trans-stmt.cc:2047-49.
>
> Regtests fine. OK for trunk, bearing in mind that most of the patch is ring
> fenced by the inferred_type flag?

I would say that it is almost fine.

Two things that I found:

- Testcase associate_65.f90 does not compile with -std=f2023, because
   IMAG is a GNU extension, while AIMAG is the standard version.
   Could you please adjust that?

- I think the handling of parentheses and functions returning pointers
   does not work correctly.  Consider:


program paul
   implicit none
   type t
      integer :: i
   end type t
   type(t), pointer :: p(:)
   allocate (p(-3:3))

   associate (q => p)
     print *, lbound (q), ubound (q) ! Should print -3 3 (OK)
   end associate

   associate (q => set_ptr())
     print *, lbound (q), ubound (q) ! Should print -3 3 (OK)
   end associate

   associate (q => (p))
     print *, lbound (q), ubound (q) ! Should print 1 7 (OK)
   end associate

   associate (q => (set_ptr()))      ! <- are these parentheses lost?
     print *, lbound (q), ubound (q) ! Should print 1 7
   end associate
contains
   function set_ptr () result (res)
     type(t), pointer :: res(:)
     res => p
   end function set_ptr
end


While the first three variants give the right bounds, the last version
- after applying your patch - is mishandled and the testcase now prints:

           -3           3
           -3           3
            1           7
           -3           3

Both NAG and Intel support my expectation, namely that the last line
should equal the next-to-last.

Can you recheck the logic for that particular corner case?

With these points addressed, your patch is OK from my side.

Thanks for the patch and your endurance!

Harald


> Cheers
>
> Paul
>
>
> On Mon, 8 Jan 2024 at 21:53, Harald Anlauf <anlauf@gmx.de> wrote:
>
>> Hi Paul,
>>
>> your patch looks already very impressive!
>>
>> Regarding the patch as is, I am still trying to grok it, even with your
>> explanations at hand...
>>
>> While the testcase works as advertised, I noticed that it exhibits a
>> runtime memleak that occurs for (likely) each case where the associate
>> target is an allocatable, class-valued function result.
>>
>> I tried to produce a minimal testcase using class(*), which apparently
>> is not handled by your patch (it ICEs for me):
>>
>> program p
>>     implicit none
>>     class(*), allocatable :: x(:)
>>     x = foo()
>>     call prt (x)
>>     deallocate (x)
>>     ! up to here no memleak...
>>     associate (var => foo())
>>       call prt (var)
>>     end associate
>> contains
>>     function foo() result(res)
>>       class(*), allocatable :: res(:)
>>       res = [42]
>>     end function foo
>>     subroutine prt (x)
>>       class(*), intent(in) :: x(:)
>>       select type (x)
>>       type is (integer)
>>          print *, x
>>       class default
>>          stop 99
>>       end select
>>     end subroutine prt
>> end
>>
>> Traceback (truncated):
>>
>> foo.f90:9:18:
>>
>>       9 |     call prt (var)
>>         |                  1
>> internal compiler error: tree check: expected record_type or union_type
>> or qual_union_type, have function_type in gfc_class_len_get, at
>> fortran/trans-expr.cc:271
>> 0x19fd5d5 tree_check_failed(tree_node const*, char const*, int, char
>> const*, ...)
>>           ../../gcc-trunk/gcc/tree.cc:8952
>> 0xe1562d tree_check3(tree_node*, char const*, int, char const*,
>> tree_code, tree_code, tree_code)
>>           ../../gcc-trunk/gcc/tree.h:3652
>> 0xe3e264 gfc_class_len_get(tree_node*)
>>           ../../gcc-trunk/gcc/fortran/trans-expr.cc:271
>> 0xecda48 trans_associate_var
>>           ../../gcc-trunk/gcc/fortran/trans-stmt.cc:2325
>> 0xecdd09 gfc_trans_block_construct(gfc_code*)
>>           ../../gcc-trunk/gcc/fortran/trans-stmt.cc:2383
>> [...]
>>
>> I don't see anything wrong with it: NAG groks it, like Nvidia and Flang,
>> while Intel crashes at runtime.
>>
>> Can you have another brief look?
>>
>> Thanks,
>> Harald
>>
>>
>> On 1/6/24 18:26, Paul Richard Thomas wrote:
>>> These PRs come about because of gfortran's single pass parsing. If the
>>> function in the title is parsed after the associate construct, then its
>>> type and rank are not known. The point at which this becomes a problem is
>>> when expressions within the associate block are parsed. primary.cc
>>> (gfc_match_varspec) could already deal with intrinsic types and so
>>> component references were the trigger for the problem.
>>>
>>> The two major parts of this patch are the fixup needed in
>> gfc_match_varspec
>>> and the resolution of  expressions with references in resolve.cc
>>> (gfc_fixup_inferred_type_refs). The former relies on the two new
>> functions
>>> in symbol.cc to search for derived types with an appropriate component to
>>> match the component reference and then set the associate name to have a
>>> matching derived type. gfc_fixup_inferred_type_refs is called in
>> resolution
>>> and so the type of the selector function is known.
>>> gfc_fixup_inferred_type_refs ensures that the component references use
>> this
>>> derived type and that array references occur in the right place in
>>> expressions and match preceding array specs. Most of the work in
>> preparing
>>> the patch was sorting out cases where the selector was not a derived type
>>> but, instead, a class function. If it were not for this, the patch would
>>> have been submitted six months ago :-(
>>>
>>> The patch is relatively safe because most of the chunks are guarded by
>>> testing for the associate name being an inferred type, which is set in
>>> gfc_match_varspec. For this reason, I do not think it likely that the
>> patch
>>> will cause regressions. However, it is more than possible that variants
>> not
>>> appearing in the submitted testcase will throw up new bugs.
>>>
>>> Jerry has already given the patch a whirl and found that it applies
>>> cleanly, regtests OK and works as advertised.
>>>
>>> OK for trunk?
>>>
>>> Paul
>> ...snip...
>


^ permalink raw reply	[flat|nested] 7+ messages in thread

* Re: [Patch, fortran PR89645/99065 No IMPLICIT type error with: ASSOCIATE( X => function() )
  2024-03-03 20:20     ` Harald Anlauf
@ 2024-03-12 14:54       ` Paul Richard Thomas
  2024-03-12 21:07         ` Harald Anlauf
  0 siblings, 1 reply; 7+ messages in thread
From: Paul Richard Thomas @ 2024-03-12 14:54 UTC (permalink / raw)
  To: fortran, gcc-patches; +Cc: Steve Kargl, Harald Anlauf, Damian Rouson


[-- Attachment #1.1: Type: text/plain, Size: 4488 bytes --]

Hi All,

This is the last posting of this patch before I push it. Harald is OK with
it on the grounds that the inferred_type flag guards the whole lot,
except for the chunks in trans-stmt.cc.

In spite of Harald's off-list admonition not to try to fix everything at
once, this version fixes most of the inquiry reference bugs
(associate_68.f90) with the exception of character(kind=4) function
selectors. The reason for this is that I have some housekeeping to do
before release on finalization and then I want to replace this patch in
15-branch with two pass parsing. My first attempts at the latter were a
partial success.

It regtests OK on x86_64. Unless there are objections, I will commit on
Thursday evening.

Cheers

Paul

Fortran: Fix class/derived/complex function associate selectors [PR87477]

2024-03-12  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
PR fortran/87477
PR fortran/89645
PR fortran/99065
PR fortran/114141
PR fortran/114280
* class.cc (gfc_change_class): New function needed for
associate names, when rank changes or a derived type is
produced by resolution
* dump-parse-tree.cc (show_code_node): Make output for SELECT
TYPE more comprehensible.
* expr.cc (find_inquiry_ref): Do not simplify expressions of
an inferred type.
* gfortran.h : Add 'gfc_association_list' to structure
'gfc_association_list'. Add prototypes for
'gfc_find_derived_types', 'gfc_fixup_inferred_type_refs' and
'gfc_change_class'. Add macro IS_INFERRED_TYPE.
* match.cc (copy_ts_from_selector_to_associate): Add bolean arg
'select_type' with default false. If this is a select type name
and the selector is a inferred type, build the class type and
apply it to the associate name.
(build_associate_name): Pass true to 'select_type' in call to
previous.
* parse.cc (parse_associate): If the selector is inferred type
the associate name is too. Make sure that function selector
class and rank, if known, are passed to the associate name. If
a function result exists, pass its typespec to the associate
name.
* primary.cc (resolvable_fcns): New function to check that all
the function references are resolvable.
(gfc_match_varspec): If a scalar derived type select type
temporary has an array reference, match the array reference,
treating this in the same way as an equivalence member. Do not
set 'inquiry' if applied to an unknown type the inquiry name
is ambiguous with the component of an accessible derived type.
Check that resolution of the target expression is OK by testing
if the symbol is declared or is an operator expression, then
using 'resolvable_fcns' recursively. If all is well, resolve
the expression. If this is an inferred type with a component
reference, call 'gfc_find_derived_types' to find a suitable
derived type. If there is an inquiry ref and the symbol either
is of unknown type or is inferred to be a derived type, set the
primary and symbol TKR appropriately.
* resolve.cc (resolve_variable): Call new function below.
(gfc_fixup_inferred_type_refs): New function to ensure that the
expression references for a inferred type are consistent with
the now fixed up selector.
(resolve_assoc_var): Ensure that derived type or class function
selectors transmit the correct arrayspec to the associate name.
(resolve_select_type): If the selector is an associate name of
inferred type and has no component references, the associate
name should have its typespec. Simplify the conversion of a
class array to class scalar by calling 'gfc_change_class'.
Make sure that a class, inferred type selector with an array
ref transfers the typespec from the symbol to the expression.
* symbol.cc (gfc_set_default_type): If an associate name with
unknown type has a selector expression, try resolving the expr.
(find_derived_types, gfc_find_derived_types): New functions
that search for a derived type with a given name.
* trans-expr.cc (gfc_conv_variable): Some inferred type exprs
escape resolution so call 'gfc_fixup_inferred_type_refs'.
* trans-stmt.cc (trans_associate_var): Tidy up expression for
'class_target'. Finalize and free class function results.
Correctly handle selectors that are class functions and class
array references, passed as derived types.

gcc/testsuite/
PR fortran/87477
PR fortran/89645
PR fortran/99065
* gfortran.dg/associate_64.f90 : New test
* gfortran.dg/associate_66.f90 : New test
* gfortran.dg/associate_67.f90 : New test

PR fortran/114141
* gfortran.dg/associate_65.f90 : New test

PR fortran/114280
* gfortran.dg/associate_68.f90 : New test

[-- Attachment #2: commit.diff --]
[-- Type: text/x-patch, Size: 40255 bytes --]

diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index ce31a93abcd..abe89630be3 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -815,6 +815,56 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 }
 
 
+/* Change class, using gfc_build_class_symbol. This is needed for associate
+   names, when rank changes or a derived type is produced by resolution.  */
+
+void
+gfc_change_class (gfc_typespec *ts, symbol_attribute *sym_attr,
+		  gfc_array_spec *sym_as, int rank, int corank)
+{
+  symbol_attribute attr;
+  gfc_component *c;
+  gfc_array_spec *as = NULL;
+  gfc_symbol *der = ts->u.derived;
+
+  ts->type = BT_CLASS;
+  attr = *sym_attr;
+  attr.class_ok = 0;
+  attr.associate_var = 1;
+  attr.class_pointer = 1;
+  attr.allocatable = 0;
+  attr.pointer = 1;
+  attr.dimension = rank ? 1 : 0;
+  if (rank)
+    {
+      if (sym_as)
+	as = gfc_copy_array_spec (sym_as);
+      else
+	{
+	  as = gfc_get_array_spec ();
+	  as->rank = rank;
+	  as->type = AS_DEFERRED;
+	  as->corank = corank;
+	}
+    }
+  if (as && as->corank != 0)
+    attr.codimension = 1;
+
+  if (!gfc_build_class_symbol (ts, &attr, &as))
+    gcc_unreachable ();
+
+  gfc_set_sym_referenced (ts->u.derived);
+
+  /* Make sure the _vptr is set.  */
+  c = gfc_find_component (ts->u.derived, "_vptr", true, true, NULL);
+  if (c->ts.u.derived == NULL)
+    c->ts.u.derived = gfc_find_derived_vtab (der);
+  /* _vptr now has the _vtab in it, change it to the _vtype.  */
+  if (c->ts.u.derived->attr.vtab)
+    c->ts.u.derived = c->ts.u.derived->ts.u.derived;
+}
+
+
 /* Add a procedure pointer component to the vtype
    to represent a specific type-bound procedure.  */
 
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 7b154eb3ca7..99b577c91c4 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2692,11 +2692,20 @@ show_code_node (int level, gfc_code *c)
 
     case EXEC_BLOCK:
       {
-	const char* blocktype;
+	const char *blocktype, *sname = NULL;
 	gfc_namespace *saved_ns;
 	gfc_association_list *alist;
 
-	if (c->ext.block.assoc)
+	if (c->ext.block.ns && c->ext.block.ns->code
+	    && c->ext.block.ns->code->op == EXEC_SELECT_TYPE)
+	  {
+	    gfc_expr *fcn = c->ext.block.ns->code->expr1;
+	    blocktype = "SELECT TYPE";
+	    /* expr1 is _loc(assoc_name->vptr)  */
+	    if (fcn && fcn->expr_type == EXPR_FUNCTION)
+	      sname = fcn->value.function.actual->expr->symtree->n.sym->name;
+	  }
+	else if (c->ext.block.assoc)
 	  blocktype = "ASSOCIATE";
 	else
 	  blocktype = "BLOCK";
@@ -2704,7 +2713,7 @@ show_code_node (int level, gfc_code *c)
 	fprintf (dumpfile, "%s ", blocktype);
 	for (alist = c->ext.block.assoc; alist; alist = alist->next)
 	  {
-	    fprintf (dumpfile, " %s = ", alist->name);
+	    fprintf (dumpfile, " %s = ", sname ? sname : alist->name);
 	    show_expr (alist->target);
 	  }
 
@@ -2735,7 +2744,7 @@ show_code_node (int level, gfc_code *c)
       if (c->op == EXEC_SELECT_RANK)
 	fputs ("SELECT RANK ", dumpfile);
       else if (c->op == EXEC_SELECT_TYPE)
-	fputs ("SELECT TYPE ", dumpfile);
+	fputs ("SELECT CASE ", dumpfile); // Preceded by SELECT TYPE construct
       else
 	fputs ("SELECT CASE ", dumpfile);
       show_expr (c->expr1);
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 37ea95d0185..e898faa4cfb 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -1844,6 +1844,11 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
 
   gfc_resolve_expr (tmp);
 
+  /* Leave these to the backend since the type and kind is not confirmed until
+     resolution.  */
+  if (IS_INFERRED_TYPE (tmp))
+    goto cleanup;
+
   /* In principle there can be more than one inquiry reference.  */
   for (; inquiry; inquiry = inquiry->next)
     {
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ebba2336e12..ab78542ba82 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2963,6 +2963,11 @@ typedef struct gfc_association_list
   locus where;
 
   gfc_expr *target;
+
+  /* Used for inferring 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 inferred_type:1;
 }
 gfc_association_list;
 #define gfc_get_association_list() XCNEW (gfc_association_list)
@@ -3529,6 +3534,8 @@ 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 *,
+			    bool stash = false);
 
 gfc_st_label *gfc_get_st_label (int);
 void gfc_free_st_label (gfc_st_label *);
@@ -3795,6 +3802,7 @@ void gfc_free_association_list (gfc_association_list *);
 void gfc_expression_rank (gfc_expr *);
 bool gfc_op_rank_conformable (gfc_expr *, gfc_expr *);
 bool gfc_resolve_ref (gfc_expr *);
+void gfc_fixup_inferred_type_refs (gfc_expr *);
 bool gfc_resolve_expr (gfc_expr *);
 void gfc_resolve (gfc_namespace *);
 void gfc_resolve_code (gfc_code *, gfc_namespace *);
@@ -3921,6 +3929,7 @@ const char *gfc_dt_upper_string (const char *);
 symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
 symbol_attribute gfc_expr_attr (gfc_expr *);
 symbol_attribute gfc_caf_attr (gfc_expr *, bool i = false, bool *r = NULL);
+bool is_inquiry_ref (const char *, gfc_ref **);
 match gfc_match_rvalue (gfc_expr **);
 match gfc_match_varspec (gfc_expr*, int, bool, bool);
 bool gfc_check_digit (char, int);
@@ -3988,6 +3997,8 @@ unsigned int gfc_hash_value (gfc_symbol *);
 gfc_expr *gfc_get_len_component (gfc_expr *e, int);
 bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
 			     gfc_array_spec **);
+void gfc_change_class (gfc_typespec *, symbol_attribute *,
+		       gfc_array_spec *, int, int);
 gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
 gfc_symbol *gfc_find_vtab (gfc_typespec *);
 gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*,
@@ -4018,6 +4029,10 @@ bool gfc_may_be_finalized (gfc_typespec);
 #define IS_PROC_POINTER(sym) \
 	(sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym) \
 	 ? CLASS_DATA (sym)->attr.proc_pointer : sym->attr.proc_pointer)
+#define IS_INFERRED_TYPE(expr) \
+	(expr && expr->expr_type == EXPR_VARIABLE \
+	 && expr->symtree->n.sym->assoc \
+	 && expr->symtree->n.sym->assoc->inferred_type)
 
 /* frontend-passes.cc */
 
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index eee569dac91..4539c9bb134 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -6322,7 +6322,8 @@ gfc_match_select (void)
 /* Transfer the selector typespec to the associate name.  */
 
 static void
-copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
+copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector,
+				    bool select_type = false)
 {
   gfc_ref *ref;
   gfc_symbol *assoc_sym;
@@ -6405,12 +6406,30 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
     assoc_sym->as = NULL;
 
 build_class_sym:
-  if (selector->ts.type == BT_CLASS)
+  /* Deal with the very specific case of a SELECT_TYPE selector being an
+     associate_name whose type has been identified by component references.
+     It must be assumed that it will be identified as a CLASS expression,
+     so convert it now.  */
+  if (select_type
+      && IS_INFERRED_TYPE (selector)
+      && selector->ts.type == BT_DERIVED)
+    {
+      gfc_find_derived_vtab (selector->ts.u.derived);
+      /* The correct class container has to be available.  */
+      assoc_sym->ts.u.derived = selector->ts.u.derived;
+      assoc_sym->ts.type = BT_CLASS;
+      assoc_sym->attr.pointer = 1;
+      if (!selector->ts.u.derived->attr.is_class)
+	gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
+      associate->ts = assoc_sym->ts;
+    }
+  else if (selector->ts.type == BT_CLASS)
     {
       /* The correct class container has to be available.  */
       assoc_sym->ts.type = BT_CLASS;
       assoc_sym->ts.u.derived = CLASS_DATA (selector)
-	? CLASS_DATA (selector)->ts.u.derived : selector->ts.u.derived;
+				? CLASS_DATA (selector)->ts.u.derived
+				: selector->ts.u.derived;
       assoc_sym->attr.pointer = 1;
       gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
     }
@@ -6438,7 +6457,7 @@ build_associate_name (const char *name, gfc_expr **e1, gfc_expr **e2)
   if (expr2->ts.type == BT_UNKNOWN)
     sym->attr.untyped = 1;
   else
-    copy_ts_from_selector_to_associate (expr1, expr2);
+    copy_ts_from_selector_to_associate (expr1, expr2, true);
 
   sym->attr.flavor = FL_VARIABLE;
   sym->attr.referenced = 1;
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index a4fda6e5eb6..a2bf328f681 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5150,6 +5150,17 @@ parse_associate (void)
       sym->declared_at = a->where;
       gfc_set_sym_referenced (sym);
 
+      /* If the selector is a inferred type then the associate_name had better
+	 be as well. Use array references, if present, to identify it as an
+	 array.  */
+      if (IS_INFERRED_TYPE (a->target))
+	{
+	  sym->assoc->inferred_type = 1;
+	  for (gfc_ref *r = a->target->ref; r; r = r->next)
+	    if (r->type == REF_ARRAY)
+	      sym->attr.dimension = 1;
+	}
+
       /* Initialize the typespec.  It is not available in all cases,
 	 however, as it may only be set on the target during resolution.
 	 Still, sometimes it helps to have it right now -- especially
@@ -5176,21 +5187,41 @@ parse_associate (void)
 	       && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
 	sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
 
+      /* If the function has been parsed, go straight to the result to
+	 obtain the expression rank.  */
+      if (target->expr_type == EXPR_FUNCTION
+	  && target->symtree
+	  && target->symtree->n.sym)
+	{
+	  tsym = target->symtree->n.sym;
+	  if (!tsym->result)
+	    tsym->result = tsym;
+	  sym->ts = tsym->result->ts;
+	  if (sym->ts.type == BT_CLASS)
+	    {
+	      if (CLASS_DATA (sym)->as)
+		target->rank = CLASS_DATA (sym)->as->rank;
+	      sym->attr.class_ok = 1;
+	    }
+	  else
+	    target->rank = tsym->result->as ? tsym->result->as->rank : 0;
+	}
+
       /* Check if the target expression is array valued. This cannot be done
 	 by calling gfc_resolve_expr because the context is unavailable.
 	 However, the references can be resolved and the rank of the target
 	 expression set.  */
-      if (target->ref && gfc_resolve_ref (target)
+      if (!sym->assoc->inferred_type
+	  && target->ref && gfc_resolve_ref (target)
 	  && target->expr_type != EXPR_ARRAY
 	  && target->expr_type != EXPR_COMPCALL)
 	gfc_expression_rank (target);
 
       /* Determine whether or not function expressions with unknown type are
 	 structure constructors. If so, the function result can be converted
-	 to be a derived type.
-	 TODO: Deal with references to sibling functions that have not yet been
-	 parsed (PRs 89645 and 99065).  */
-      if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN)
+	 to be a derived type.  */
+      if (target->expr_type == EXPR_FUNCTION
+	  && target->ts.type == BT_UNKNOWN)
 	{
 	  gfc_symbol *derived;
 	  /* The derived type has a leading uppercase character.  */
@@ -5200,16 +5231,7 @@ parse_associate (void)
 	    {
 	      sym->ts.type = BT_DERIVED;
 	      sym->ts.u.derived = derived;
-	    }
-	  else if (target->symtree && (tsym = target->symtree->n.sym))
-	    {
-	      sym->ts = tsym->result ? tsym->result->ts : tsym->ts;
-	      if (sym->ts.type == BT_CLASS)
-		{
-		  if (CLASS_DATA (sym)->as)
-		    target->rank = CLASS_DATA (sym)->as->rank;
-		  sym->attr.class_ok = 1;
-		}
+	      sym->assoc->inferred_type = 0;
 	    }
 	}
 
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 12e7bf3c873..0ab69bb9dce 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2003,7 +2003,7 @@ extend_ref (gfc_expr *primary, gfc_ref *tail)
 
 /* Used by gfc_match_varspec() to match an inquiry reference.  */
 
-static bool
+bool
 is_inquiry_ref (const char *name, gfc_ref **ref)
 {
   inquiry_type type;
@@ -2035,6 +2035,29 @@ is_inquiry_ref (const char *name, gfc_ref **ref)
 }
 
 
+/* Check to see if functions in operator expressions can be resolved now.  */
+
+static bool
+resolvable_fcns (gfc_expr *e,
+		  gfc_symbol *sym ATTRIBUTE_UNUSED,
+		  int *f ATTRIBUTE_UNUSED)
+{
+  bool p;
+  gfc_symbol *s;
+
+  if (e->expr_type != EXPR_FUNCTION)
+    return false;
+
+  s = e && e->symtree && e->symtree->n.sym ? e->symtree->n.sym : NULL;
+  p = s && (s->attr.use_assoc
+	    || s->attr.host_assoc
+	    || s->attr.if_source == IFSRC_DECL
+	    || s->attr.proc == PROC_INTRINSIC
+	    || gfc_is_intrinsic (s, 0, e->where));
+  return !p;
+}
+
+
 /* Match any additional specifications associated with the current
    variable like member references or substrings.  If equiv_flag is
    set we only match stuff that is allowed inside an EQUIVALENCE
@@ -2057,6 +2080,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
   bool unknown;
   bool inquiry;
   bool intrinsic;
+  bool inferred_type;
   locus old_loc;
   char sep;
 
@@ -2087,6 +2111,18 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
   if (sym->assoc && sym->assoc->target)
     tgt_expr = sym->assoc->target;
 
+  inferred_type = IS_INFERRED_TYPE (primary);
+
+  /* SELECT TYPE and SELECT RANK temporaries within an ASSOCIATE block, whose
+     selector has not been parsed, can generate errors with array and component
+     refs.. Use 'inferred_type' as a flag to suppress these errors.  */
+  if (!inferred_type
+      && (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
+      && !sym->attr.codimension
+      && sym->attr.select_type_temporary
+      && !sym->attr.select_rank_temporary)
+    inferred_type = true;
+
   /* For associate names, we may not yet know whether they are arrays or not.
      If the selector expression is unambiguously an array; eg. a full array
      or an array section, then the associate name must be an array and we can
@@ -2136,7 +2172,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	sym->ts.u.derived = tgt_expr->ts.u.derived;
     }
 
-  if ((equiv_flag && gfc_peek_ascii_char () == '(')
+  if ((inferred_type && !sym->as && gfc_peek_ascii_char () == '(')
+      || (equiv_flag && gfc_peek_ascii_char () == '(')
       || gfc_peek_ascii_char () == '[' || sym->attr.codimension
       || (sym->attr.dimension && sym->ts.type != BT_CLASS
 	  && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
@@ -2194,41 +2231,100 @@ 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 || inferred_type))
     {
       match mm;
       old_loc = gfc_current_locus;
       mm = gfc_match_name (name);
-      if (mm == MATCH_YES && is_inquiry_ref (name, &tmp))
+      /* This is a usable inquiry reference, if the symbol is already known
+	 to have a type or no derived types with a component of this name
+	 can be found.  If this was an inquiry reference with the same name
+	 as a derived component and the associate-name type is not derived
+	 or class, this is fixed up in 'gfc_fixup_inferred_type_refs'.  */
+      if (mm == MATCH_YES && is_inquiry_ref (name, &tmp)
+	  && !(sym->ts.type == BT_UNKNOWN
+		&& gfc_find_derived_types (sym, gfc_current_ns, name)))
 	inquiry = true;
       gfc_current_locus = old_loc;
     }
 
+  /* Use the default type if there is one.  */
   if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES
       && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
     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)
+  /* See if the type can be determined by resolution of the selector expression,
+     if allowable now, or inferred from references.  */
+  if ((sym->ts.type == BT_UNKNOWN || inferred_type)
+      && m == MATCH_YES)
     {
-      bool permissible;
-
-      /* These target expressions can be resolved at any time.  */
-      permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
-		    && (tgt_expr->symtree->n.sym->attr.use_assoc
-			|| tgt_expr->symtree->n.sym->attr.host_assoc
-			|| tgt_expr->symtree->n.sym->attr.if_source
-								== IFSRC_DECL);
-      permissible = permissible
-		    || (tgt_expr && tgt_expr->expr_type == EXPR_OP);
-
-      if (permissible)
+      bool sym_present, resolved = false;
+      gfc_symbol *tgt_sym;
+
+      sym_present = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym;
+      tgt_sym = sym_present ? tgt_expr->symtree->n.sym : NULL;
+
+      /* These target expressions can be resolved at any time:
+	 (i) With a declared symbol or intrinsic function; or
+	 (ii) An operator expression,
+	 just as long as (iii) all the functions in the expression have been
+	 declared or are intrinsic.  */
+      if (((sym_present						      // (i)
+	    && (tgt_sym->attr.use_assoc
+		|| tgt_sym->attr.host_assoc
+		|| tgt_sym->attr.if_source == IFSRC_DECL
+		|| tgt_sym->attr.proc == PROC_INTRINSIC
+		|| gfc_is_intrinsic (tgt_sym, 0, tgt_expr->where)))
+	   || (tgt_expr && tgt_expr->expr_type == EXPR_OP))	      // (ii)
+	  && !gfc_traverse_expr (tgt_expr, NULL, resolvable_fcns, 0)  // (iii)
+	  && gfc_resolve_expr (tgt_expr))
 	{
-	  gfc_resolve_expr (tgt_expr);
 	  sym->ts = tgt_expr->ts;
+	  primary->ts = sym->ts;
+	  resolved = true;
 	}
 
-      if (sym->ts.type == BT_UNKNOWN)
+      /* If this hasn't done the trick and the target expression is a function,
+	 or an unresolved operator expression, then this must be a derived type
+	 if 'name' matches an accessible type both in this namespace and in the
+	 as yet unparsed contained function. In principle, the type could have
+	 already been inferred to be complex and yet a derived type with a
+	 component name 're' or 'im' could be found.  */
+      if (tgt_expr
+	  && (tgt_expr->expr_type == EXPR_FUNCTION
+	      || (!resolved && tgt_expr->expr_type == EXPR_OP))
+	  && (sym->ts.type == BT_UNKNOWN
+	      || (inferred_type && sym->ts.type != BT_COMPLEX))
+	  && gfc_find_derived_types (sym, gfc_current_ns, name, true))
+	{
+	  sym->assoc->inferred_type = 1;
+	  /* The first returned type is as good as any at this stage. The final
+	     determination is made in 'gfc_fixup_inferred_type_refs'*/
+	  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;
+	  primary->ts = sym->ts;
+	  /* Delete the dt list 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 there is a usable inquiry reference not there are no matching
+	 derived types, force the inquiry reference by setting unknown the
+	 type of the primary expression.  */
+      else if (inquiry && (sym->ts.type == BT_DERIVED && inferred_type)
+	       && !gfc_find_derived_types (sym, gfc_current_ns, name))
+	primary->ts.type = BT_UNKNOWN;
+
+      /* An inquiry reference might determine the type, otherwise we have an
+	 error.  */
+      if (sym->ts.type == BT_UNKNOWN && !inquiry)
 	{
 	  gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
 	  return MATCH_ERROR;
@@ -2273,6 +2369,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	    {
 	      if (tmp)
 		{
+		  gfc_symbol *s;
 		  switch (tmp->u.i)
 		    {
 		    case INQUIRY_RE:
@@ -2294,6 +2391,39 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 		      break;
 		    }
 
+		  /* If necessary, infer the type of the primary expression
+		     and the associate-name using the the inquiry ref..  */
+		  s = primary->symtree ? primary->symtree->n.sym : NULL;
+		  if (s && s->assoc && s->assoc->target
+		      && (s->ts.type == BT_UNKNOWN
+			  || (primary->ts.type == BT_UNKNOWN
+			      && s->assoc->inferred_type
+			      && s->ts.type == BT_DERIVED)))
+		    {
+		      if (tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
+			{
+			  s->ts.type = BT_COMPLEX;
+			  s->ts.kind = gfc_default_real_kind;;
+			  s->assoc->inferred_type = 1;
+			  primary->ts = s->ts;
+			}
+		      else if (tmp->u.i == INQUIRY_LEN)
+			{
+			  s->ts.type = BT_CHARACTER;
+			  s->ts.kind = gfc_default_character_kind;;
+			  s->assoc->inferred_type = 1;
+			  primary->ts = s->ts;
+			}
+		      else if (s->ts.type == BT_UNKNOWN)
+			{
+			  /* KIND inquiry gives no clue as to symbol type.  */
+			  primary->ref = tmp;
+			  primary->ts.type = BT_INTEGER;
+			  primary->ts.kind = gfc_default_integer_kind;
+			  return MATCH_YES;
+			}
+		    }
+
 		  if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
 		      && primary->ts.type != BT_COMPLEX)
 		    {
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 02acc4aef31..2504fecea6e 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5866,6 +5866,18 @@ resolve_variable (gfc_expr *e)
       return false;
     }
 
+  /* Guessed type variables are associate_names whose selector had not been
+     parsed at the time that the construct was parsed. Now the namespace is
+     being resolved, the TKR of the selector will be available for fixup of
+     the associate_name.  */
+  if (IS_INFERRED_TYPE (e) && e->ref)
+    {
+      gfc_fixup_inferred_type_refs (e);
+      /* KIND inquiry ref returns the kind of the target.  */
+      if (e->expr_type == EXPR_CONSTANT)
+	return true;
+    }
+
   /* For variables that are used in an associate (target => object) where
      the object's basetype is array valued while the target is scalar,
      the ts' type of the component refs is still array valued, which
@@ -6171,6 +6183,159 @@ resolve_procedure:
 }
 
 
+/* 'sym' was initially guessed to be derived type but has been corrected
+   in resolve_assoc_var to be a class entity or the derived type correcting.
+   If a class entity it will certainly need the _data reference or the
+   reference derived type symbol correcting in the first component ref if
+   a derived type.  */
+
+void
+gfc_fixup_inferred_type_refs (gfc_expr *e)
+{
+  gfc_ref *ref, *new_ref;
+  gfc_symbol *sym, *derived;
+  gfc_expr *target;
+  sym = e->symtree->n.sym;
+
+  /* An associate_name whose selector is (i) a component ref of a selector
+     that is a inferred type associate_name; or (ii) an intrinsic type that
+     has been inferred from an inquiry ref.  */
+  if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+    {
+      sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
+      if (!sym->attr.dimension && e->ref->type == REF_ARRAY)
+	{
+	  ref = e->ref;
+	  /* A substring misidentified as an array section.  */
+	  if (sym->ts.type == BT_CHARACTER
+	      && ref->u.ar.start[0] && ref->u.ar.end[0]
+	      && !ref->u.ar.stride[0])
+	    {
+	      new_ref = gfc_get_ref ();
+	      new_ref->type = REF_SUBSTRING;
+	      new_ref->u.ss.start = ref->u.ar.start[0];
+	      new_ref->u.ss.end = ref->u.ar.end[0];
+	      new_ref->u.ss.length = sym->ts.u.cl;
+	      *ref = *new_ref;
+	      free (new_ref);
+	    }
+	  else
+	  {
+	    e->ref = ref->next;
+	    free (ref);
+	  }
+	}
+
+      /* It is possible for an inquiry reference to be mistaken for a
+	 component reference. Correct this now.  */
+      ref = e->ref;
+      if (ref && ref->type == REF_ARRAY)
+	ref = ref->next;
+      if (ref && ref->type == REF_COMPONENT
+	  && is_inquiry_ref (ref->u.c.component->name, &new_ref))
+	{
+	  e->symtree->n.sym = sym;
+	  *ref = *new_ref;
+	  gfc_free_ref_list (new_ref);
+	}
+
+      /* The kind of the associate name is best evaluated directly from the
+	 selector because of the guesses made in primary.cc, when the type
+	 is still unknown.  */
+      if (ref && ref->type == REF_INQUIRY && ref->u.i == INQUIRY_KIND)
+	{
+	  gfc_expr *ne = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
+					   sym->assoc->target->ts.kind);
+	  gfc_replace_expr (e, ne);
+	}
+
+      /* Now that the references are all sorted out, set the expression rank
+         and return.  */
+      gfc_expression_rank (e);
+      return;
+    }
+
+  derived = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->ts.u.derived
+				     : sym->ts.u.derived;
+
+  /* Ensure that class symbols have an array spec and ensure that there
+     is a _data field reference following class type references.  */
+  if (sym->ts.type == BT_CLASS
+      && sym->assoc->target->ts.type == BT_CLASS)
+    {
+      e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0;
+      sym->attr.dimension = 0;
+      CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0;
+      if (e->ref && (e->ref->type != REF_COMPONENT
+		     || e->ref->u.c.component->name[0] != '_'))
+	{
+	  ref = gfc_get_ref ();
+	  ref->type = REF_COMPONENT;
+	  ref->next = e->ref;
+	  e->ref = ref;
+	  ref->u.c.component = gfc_find_component (sym->ts.u.derived, "_data",
+						   true, true, NULL);
+	  ref->u.c.sym = sym->ts.u.derived;
+	}
+    }
+
+  /* Proceed as far as the first component reference and ensure that the
+     correct derived type is being used.  */
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      {
+	if (ref->u.c.component->name[0] != '_')
+	  ref->u.c.sym = derived;
+	else
+	  ref->u.c.sym = sym->ts.u.derived;
+	break;
+      }
+
+  /* Verify that the type inferrence mechanism has not introduced a spurious
+     array reference.  This can happen with an associate name, whose selector
+     is an element of another inferred type.  */
+  target = e->symtree->n.sym->assoc->target;
+  if (!(sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as)
+      && e != target && !target->rank)
+    {
+      /* First case: array ref after the scalar class or derived
+         associate_name.  */
+      if (e->ref && e->ref->type == REF_ARRAY
+	  && e->ref->u.ar.type != AR_ELEMENT)
+	{
+	  ref = e->ref;
+	  e->ref = ref->next;
+	  free (ref);
+
+	  /* If it hasn't a ref to the '_data' field supply one.  */
+	  if (sym->ts.type == BT_CLASS
+	      && !(e->ref->type == REF_COMPONENT
+		   && strcmp (e->ref->u.c.component->name, "_data")))
+	    {
+	      gfc_ref *new_ref;
+	      gfc_find_component (e->symtree->n.sym->ts.u.derived,
+				  "_data", true, true, &new_ref);
+	      new_ref->next = e->ref;
+	      e->ref = new_ref;
+	    }
+	}
+      /* 2nd case: a ref to the '_data' field followed by an array ref.  */
+      else if (e->ref && e->ref->type == REF_COMPONENT
+	       && strcmp (e->ref->u.c.component->name, "_data") == 0
+	       && e->ref->next && e->ref->next->type == REF_ARRAY
+	       && e->ref->next->u.ar.type != AR_ELEMENT)
+	{
+	  ref = e->ref->next;
+	  e->ref->next = e->ref->next->next;
+	  free (ref);
+	}
+    }
+
+  /* Now that all the references are OK, get the expression rank.  */
+  gfc_expression_rank (e);
+}
+
+
 /* Checks to see that the correct symbol has been host associated.
    The only situations where this arises are:
 	(i)  That in which a twice contained function is parsed after
@@ -9263,6 +9428,53 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
       return;
     }
 
+  if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target))
+    {
+      /* By now, the type of the target has been fixed up.  */
+      symbol_attribute attr;
+
+      if (sym->ts.type == BT_DERIVED
+	  && target->ts.type == BT_CLASS
+	  && !UNLIMITED_POLY (target))
+	{
+	  /* Inferred to be derived type but the target has type class.  */
+	  sym->ts = CLASS_DATA (target)->ts;
+	  if (!sym->as)
+	    sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as);
+	  attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
+	  sym->attr.dimension = target->rank ? 1 : 0;
+	  gfc_change_class (&sym->ts, &attr, sym->as,
+			    target->rank, gfc_get_corank (target));
+	  sym->as = NULL;
+	}
+      else if (target->ts.type == BT_DERIVED
+	       && target->symtree && target->symtree->n.sym
+	       && target->symtree->n.sym->ts.type == BT_CLASS
+	       && IS_INFERRED_TYPE (target)
+	       && target->ref && target->ref->next
+	       && target->ref->next->type == REF_ARRAY
+	       && !target->ref->next->next)
+	{
+	  /* A inferred type selector whose symbol has been determined to be
+	     a class array but which only has an array reference. Change the
+	     associate name and the selector to class type.  */
+	  sym->ts = target->ts;
+	  attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
+	  sym->attr.dimension = target->rank ? 1 : 0;
+	  gfc_change_class (&sym->ts, &attr, sym->as,
+			    target->rank, gfc_get_corank (target));
+	  sym->as = NULL;
+	  target->ts = sym->ts;
+	}
+      else if ((target->ts.type == BT_DERIVED)
+	       || (sym->ts.type == BT_CLASS && target->ts.type == BT_CLASS
+		   && CLASS_DATA (target)->as && !CLASS_DATA (sym)->as))
+	/* Confirmed to be either a derived type or misidentified to be a
+	   scalar class object, when the selector is a class array.  */
+	sym->ts = target->ts;
+    }
+
+
   if (target->expr_type == EXPR_NULL)
     {
       gfc_error ("Selector at %L cannot be NULL()", &target->where);
@@ -9289,15 +9501,50 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 			  || gfc_is_ptr_fcn (target));
 
   /* Finally resolve if this is an array or not.  */
+  if (target->expr_type == EXPR_FUNCTION
+      && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
+    {
+      gfc_expression_rank (target);
+      if (target->ts.type == BT_DERIVED
+	  && !sym->as
+	  && target->symtree->n.sym->as)
+	{
+	  sym->as = gfc_copy_array_spec (target->symtree->n.sym->as);
+	  sym->attr.dimension = 1;
+	}
+      else if (target->ts.type == BT_CLASS
+	       && CLASS_DATA (target)->as)
+	{
+	  target->rank = CLASS_DATA (target)->as->rank;
+	  if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
+	    {
+	      sym->ts = target->ts;
+	      sym->attr.dimension = 0;
+	    }
+	}
+    }
+
+
   if (sym->attr.dimension && target->rank == 0)
     {
       /* primary.cc makes the assumption that a reference to an associate
 	 name followed by a left parenthesis is an array reference.  */
-      if (sym->ts.type != BT_CHARACTER)
-	gfc_error ("Associate-name %qs at %L is used as array",
-		   sym->name, &sym->declared_at);
-      sym->attr.dimension = 0;
-      return;
+      if (sym->assoc->inferred_type && sym->ts.type != BT_CLASS)
+	{
+	  gfc_expression_rank (sym->assoc->target);
+	  sym->attr.dimension = sym->assoc->target->rank ? 1 : 0;
+	  if (!sym->attr.dimension && sym->as)
+	    sym->as = NULL;
+	}
+
+      if (sym->attr.dimension && target->rank == 0)
+	{
+	  if (sym->ts.type != BT_CHARACTER)
+	    gfc_error ("Associate-name %qs at %L is used as array",
+		       sym->name, &sym->declared_at);
+	  sym->attr.dimension = 0;
+	  return;
+	}
     }
 
   /* We cannot deal with class selectors that need temporaries.  */
@@ -9356,7 +9603,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	     correct this now.  */
 	  gfc_typespec *ts = &target->ts;
 	  gfc_ref *ref;
-	  gfc_component *c;
+
 	  for (ref = target->ref; ref != NULL; ref = ref->next)
 	    {
 	      switch (ref->type)
@@ -9374,32 +9621,15 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	    }
 	  /* Create a scalar instance of the current class type.  Because the
 	     rank of a class array goes into its name, the type has to be
-	     rebuild.  The alternative of (re-)setting just the attributes
+	     rebuilt.  The alternative of (re-)setting just the attributes
 	     and as in the current type, destroys the type also in other
 	     places.  */
 	  as = NULL;
 	  sym->ts = *ts;
 	  sym->ts.type = BT_CLASS;
 	  attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
-	  attr.class_ok = 0;
-	  attr.associate_var = 1;
-	  attr.dimension = attr.codimension = 0;
-	  attr.class_pointer = 1;
-	  if (!gfc_build_class_symbol (&sym->ts, &attr, &as))
-	    gcc_unreachable ();
-	  /* Make sure the _vptr is set.  */
-	  c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL);
-	  if (c->ts.u.derived == NULL)
-	    c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived);
-	  CLASS_DATA (sym)->attr.pointer = 1;
-	  CLASS_DATA (sym)->attr.class_pointer = 1;
-	  gfc_set_sym_referenced (sym->ts.u.derived);
-	  gfc_commit_symbol (sym->ts.u.derived);
-	  /* _vptr now has the _vtab in it, change it to the _vtype.  */
-	  if (c->ts.u.derived->attr.vtab)
-	    c->ts.u.derived = c->ts.u.derived->ts.u.derived;
-	  c->ts.u.derived->ns->types_resolved = 0;
-	  resolve_types (c->ts.u.derived->ns);
+	  gfc_change_class (&sym->ts, &attr, as, 0, 0);
+	  sym->as = NULL;
 	}
     }
 
@@ -9443,6 +9673,14 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	}
     }
 
+  if (sym->ts.type == BT_CLASS
+      && IS_INFERRED_TYPE (target)
+      && target->ts.type == BT_DERIVED
+      && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived
+      && target->ref && target->ref->next && !target->ref->next->next
+      && target->ref->next->type == REF_ARRAY)
+    target->ts = target->symtree->n.sym->ts;
+
   /* If the target is a good class object, so is the associate variable.  */
   if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok)
     sym->attr.class_ok = 1;
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 5d9852c79e0..16adb2a7efb 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -291,6 +291,19 @@ bool
 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
 {
   gfc_typespec *ts;
+  gfc_expr *e;
+
+  /* Check to see if a function selector of unknown type can be resolved.  */
+  if (sym->assoc
+      && (e = sym->assoc->target)
+      && e->expr_type == EXPR_FUNCTION)
+    {
+      if (e->ts.type == BT_UNKNOWN)
+	gfc_resolve_expr (e);
+      sym->ts = e->ts;
+      if (sym->ts.type != BT_UNKNOWN)
+	return true;
+    }
 
   if (sym->ts.type != BT_UNKNOWN)
     gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
@@ -307,7 +320,7 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
 		       "; did you mean %qs?",
 		       sym->name, &sym->declared_at, guessed);
 	  else
-	    gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+	    gfc_error ("Symbol %qs at %L has no IMPLICIT type(symbol)",
 		       sym->name, &sym->declared_at);
 	  sym->attr.untyped = 1; /* Ensure we only give an error once.  */
 	}
@@ -2402,6 +2415,67 @@ 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 infer 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, bool stash)
+{
+  if (st->n.sym && st->n.sym->attr.flavor == FL_DERIVED
+      && !st->n.sym->attr.is_class
+      && ((contained && st->n.sym->attr.use_assoc) || !contained)
+      && gfc_find_component (st->n.sym, name, true, true, NULL))
+    {
+      /* Do the stashing, if required.  */
+      cts++;
+      if (stash)
+	{
+	  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, stash);
+
+  if (st->right)
+    find_derived_types (sym, st->right, name, contained, stash);
+}
+
+int
+gfc_find_derived_types (gfc_symbol *sym, gfc_namespace *ns,
+			const char *name, bool stash)
+{
+  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;
+    }
+
+  /* Search the top level namespace first.  */
+  find_derived_types (sym, ns->sym_root, name, false, stash);
+
+  /* Then the encompassing namespace.  */
+  if (encompassing && encompassing != ns)
+    find_derived_types (sym, encompassing->sym_root, name, true, stash);
+
+  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
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d63c304661a..bd14ce99ed6 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -3142,6 +3142,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
       gcc_assert (se->string_length);
     }
 
+  /* Some expressions leak through that haven't been fixed up.  */
+  if (IS_INFERRED_TYPE (expr) && expr->ref)
+    gfc_fixup_inferred_type_refs (expr);
+
   gfc_typespec *ts = &sym->ts;
   while (ref)
     {
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index e09828e218b..1ec76f9778c 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1747,9 +1747,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   e = sym->assoc->target;
 
   class_target = (e->expr_type == EXPR_VARIABLE)
-		    && e->ts.type == BT_CLASS
-		    && (gfc_is_class_scalar_expr (e)
-			|| gfc_is_class_array_ref (e, NULL));
+		  && e->ts.type == BT_CLASS
+		  && (gfc_is_class_scalar_expr (e)
+		      || gfc_is_class_array_ref (e, NULL));
 
   unlimited = UNLIMITED_POLY (e);
 
@@ -2043,6 +2043,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	{
 	  gfc_conv_expr (&se, e);
 	  se.expr = gfc_evaluate_now (se.expr, &se.pre);
+	  /* Finalize the expression and free if it is allocatable.  */
+	  gfc_finalize_tree_expr (&se, NULL, gfc_expr_attr (e), e->rank);
+	  gfc_add_block_to_block (&se.post, &se.finalblock);
+	  need_len_assign = false;
 	}
       else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
 	{
@@ -2157,26 +2161,36 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	    {
 	      tree stmp;
 	      tree dtmp;
+	      tree ctmp;
 
-	      se.expr = ctree;
+	      ctmp = ctree;
 	      dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl));
 	      ctree = gfc_create_var (dtmp, "class");
 
-	      stmp = gfc_class_data_get (se.expr);
+	      if (IS_INFERRED_TYPE (e)
+		  && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
+		stmp = se.expr;
+	      else
+		stmp = gfc_class_data_get (ctmp);
+
 	      /* Coarray scalar component expressions can emerge from
 		 the front end as array elements of the _data field.  */
 	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp)))
 		stmp = gfc_conv_descriptor_data_get (stmp);
+
+	      if (!POINTER_TYPE_P (TREE_TYPE (stmp)))
+		stmp = gfc_build_addr_expr (NULL, stmp);
+
 	      dtmp = gfc_class_data_get (ctree);
 	      stmp = fold_convert (TREE_TYPE (dtmp), stmp);
 	      gfc_add_modify (&se.pre, dtmp, stmp);
-	      stmp = gfc_class_vptr_get (se.expr);
+	      stmp = gfc_class_vptr_get (ctmp);
 	      dtmp = gfc_class_vptr_get (ctree);
 	      stmp = fold_convert (TREE_TYPE (dtmp), stmp);
 	      gfc_add_modify (&se.pre, dtmp, stmp);
 	      if (UNLIMITED_POLY (sym))
 		{
-		  stmp = gfc_class_len_get (se.expr);
+		  stmp = gfc_class_len_get (ctmp);
 		  dtmp = gfc_class_len_get (ctree);
 		  stmp = fold_convert (TREE_TYPE (dtmp), stmp);
 		  gfc_add_modify (&se.pre, dtmp, stmp);

[-- Attachment #3: associate_64.f90 --]
[-- Type: text/x-fortran, Size: 9124 bytes --]

! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! Tests the fix for PR89645 and 99065, in which derived type or class functions,
! used as associate selectors and which were parsed after the containing scope
! of the associate statement, caused "no IMPLICIT type" and "Syntax" errors.
!
! Contributed by Ian Harvey  <ian_harvey@bigpond.com>
!
module m
  implicit none
  type t
    integer :: i = 0
  end type t
  integer :: i = 0
  type(t), parameter :: test_array (2) = [t(42),t(84)], &
                        test_scalar = t(99)
end module m

! DERIVED TYPE VERSION OF THE PROBLEM, AS REPORTED IN THE PRs
module type_selectors
  use m
  implicit none
  private
  public foo1
contains
! Since these functions are parsed first, the symbols are available for
! parsing in 'foo'.
  function bar1() result(res) ! The array version caused syntax errors in foo
    type(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end
  function bar2() result(res) ! Scalar class functions were OK - test anyway
    type(t), allocatable :: res
    allocate (res, source = test_scalar)
  end
  subroutine foo1()
! First the array selector
    associate (var1 => bar1())
      if (any (var1%i .ne. test_array%i)) stop 1
      if (var1(2)%i .ne. test_array(2)%i) stop 2
    end associate
! Now the scalar selector
    associate (var2 => bar2())
      if (var2%i .ne. test_scalar%i) stop 3
    end associate

! Now the array selector that needed fixing up because the function follows....
    associate (var1 => bar3())
      if (any (var1%i .ne. test_array%i)) stop 4
      if (var1(2)%i .ne. test_array(2)%i) stop 5
    end associate
! ....and equivalent scalar selector
    associate (var2 => bar4())
      if (var2%i .ne. test_scalar%i) stop 6
    end associate
  end subroutine foo1

! These functions are parsed after 'foo' so the symbols were not available
! for the selectors and the fixup, tested here, was necessary.
  function bar3() result(res)
    class(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end

  function bar4() result(res)
    class(t), allocatable :: res
    allocate (res, source = t(99))
  end
end module type_selectors

! CLASS VERSION OF THE PROBLEM, WHICH REQUIRED MOST OF THE WORK!
module class_selectors
  use m
  implicit none
  private
  public foo2
contains

! Since these functions are parsed first, the symbols are available for
! parsing in 'foo'.
  function bar1() result(res) ! The array version caused syntax errors in foo
    class(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end

  function bar2() result(res) ! Scalar class functions were OK - test anyway
    class(t), allocatable :: res
    allocate (res, source = t(99))
  end

  subroutine foo2()
! First the array selector
    associate (var1 => bar1())
      if (any (var1%i .ne. test_array%i)) stop 7
      if (var1(2)%i .ne. test_array(2)%i) stop 8
      select type (x => var1)
        type is (t)
          if (any (x%i .ne. test_array%i)) stop 9
          if (x(1)%i .ne. test_array(1)%i) stop 10
        class default
          stop 11
      end select
    end associate

! Now scalar selector
    associate (var2 => bar2())
      select type (z => var2)
        type is (t)
          if (z%i .ne. test_scalar%i) stop 12
        class default
          stop 13
      end select
    end associate

! This is the array selector that needed the fixup.
    associate (var1 => bar3())
      if (any (var1%i .ne. test_array%i)) stop 14
      if (var1(2)%i .ne. test_array(2)%i) stop 15
      select type (x => var1)
        type is (t)
          if (any (x%i .ne. test_array%i)) stop 16
          if (x(1)%i .ne. test_array(1)%i) stop 17
        class default
          stop 18
      end select
    end associate

! Now the equivalent scalar selector
    associate (var2 => bar4())
      select type (z => var2)
        type is (t)
          if (z%i .ne. test_scalar%i) stop 19
        class default
          stop 20
      end select
    end associate

  end subroutine foo2

! These functions are parsed after 'foo' so the symbols were not available
! for the selectors and the fixup, tested here, was necessary.
  function bar3() result(res)
    class(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end

  function bar4() result(res)
    class(t), allocatable :: res
    allocate (res, source = t(99))
  end
end module class_selectors

! THESE TESTS CAUSED PROBLEMS DURING DEVELOPMENT FOR BOTH PARSING ORDERS.
module problem_selectors
  implicit none
  private
  public foo3, foo4
  type t
    integer :: i
  end type t
  type s
    integer :: i
    type(t) :: dt
  end type s
  type(t), parameter :: test_array (2) = [t(42),t(84)], &
                        test_scalar = t(99)
  type(s), parameter :: test_sarray (2) = [s(142,t(42)),s(184,t(84))]
contains

  subroutine foo3()
    integer :: i
    block
      associate (var1 => bar7())
        if (any (var1%i .ne. test_array%i)) stop 21
        if (var1(2)%i .ne. test_array(2)%i) stop 22
        associate (z => var1(1)%i)
           if (z .ne. 42) stop 23
        end associate
    end associate
    end block

    associate (var2 => bar8())
      i = var2(2)%i
      associate (var3 => var2%dt)
        if (any (var3%i .ne. test_sarray%dt%i)) stop 24
      end associate
      associate (var4 => var2(2))
        if (var4%i .ne. 184) stop 25
      end associate
    end associate
  end subroutine foo3

  function bar7() result(res)
    type(t), allocatable :: res(:)
    allocate (res, source = test_array)
  end

  function bar8() result(res)
    type(s), allocatable :: res(:)
    allocate (res, source = test_sarray)
  end

  subroutine foo4()
    integer :: i
    block
      associate (var1 => bar7())
        if (any (var1%i .ne. test_array%i)) stop 26
        if (var1(2)%i .ne. test_array(2)%i) stop 27
        associate (z => var1(1)%i)
           if (z .ne. 42) stop 28
        end associate
    end associate
    end block

    associate (var2 => bar8())
      i = var2(2)%i
      associate (var3 => var2%dt)
        if (any (var3%i .ne. test_sarray%dt%i)) stop 29
      end associate
      associate (var4 => var2(2))
        if (var4%i .ne. 184) stop 30
      end associate
    end associate
  end subroutine foo4

end module problem_selectors

module more_problem_selectors
  implicit none
  private
  public foo5, foo6
  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 foo5()
    associate (var3 => bar3())
      if (var3%i .ne. 42) stop 31
      if (var3%dt%i .ne. 84) stop 32
    end associate

! Repeat with class version
    associate (var4 => bar4())
      if (var4%i .ne. 84) stop 33
      if (var4%dt%i .ne. 168) stop 34
      select type (x => var4)
        type is (s)
          if (x%i .ne. var4%i) stop 35
          if (x%dt%i .ne. var4%dt%i) stop 36
        class default
          stop 37
      end select
    end associate

! Ditto with no type component clues for select type
    associate (var5 => bar4())
      select type (z => var5)
        type is (s)
          if (z%i .ne. 84) stop 38
          if (z%dt%i .ne. 168) stop 39
        class default
          stop 40
      end select
    end associate
  end subroutine foo5

! Now the array versions
  subroutine foo6()
    class(s), allocatable :: elem
    associate (var6 => bar5())
      if (var6(1)%i .ne. 42) stop 41
      if (any (var6%dt%i .ne. [84])) stop 42
    end associate

! Class version with an assignment to a named variable
    associate (var7 => bar6())
      elem = var7(2)
      if (any (var7%i .ne. [84, 168])) stop 43
      if (any (var7%dt%i .ne. [168, 336])) stop 44
    end associate
    if (elem%i .ne. 168) stop 45
    if (elem%dt%i .ne. 336) stop 46

    select type (z => elem)
      type is (s)
        if (z%i .ne. 168) stop 47
        if (z%dt%i .ne. 336) stop 48
      class default
        stop 49
    end select

! Array version without type clues before select type
    associate (var8 => bar6())
      select type (z => var8)
        type is (s)
          if (any (z%i .ne. [84,168])) stop 50
          if (any (z%dt%i .ne. [168,336])) stop 51
        class default
          stop 52
      end select
    end associate
  end subroutine foo6

  type(s) function bar3()
    bar3= s(42, t(84))
  end

  function bar4() result(res)
    class(s), allocatable :: res
    res = s(84, t(168))
  end

  function bar5() result (res)
    type(s), allocatable :: res(:)
    res = [s(42, t(84))]
  end

  function bar6() result (res)
    class(s), allocatable :: res(:)
    res = [s(84, t(168)),s(168, t(336))]
  end

end module more_problem_selectors

program test
  use type_selectors
  use class_selectors
  use problem_selectors
  use more_problem_selectors
  call foo1()
  call foo2()
  call foo3()
  call foo4()
  call foo5()
  call foo6()
end program test
! { dg-final { scan-tree-dump-times "__builtin_free" 18 "original" } }

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

! { dg-do run }
! Test fix for PR114141
! Contributed by Steve Kargl  <sgk@troutmask.apl.washington.edu>
program foo
   implicit none
   real :: y = 0.0
   associate (x => log(cmplx(-1,0)))
      y = x%im  ! Gave 'Symbol ‘x’ at (1) has no IMPLICIT type'
      if (int(100*y)-314 /= 0) stop 1
   end associate

! Check wrinkle in comment 1 (parentheses around selector) of the PR is fixed.
   associate (x => ((log(cmplx(-1,1)))))
      y = x%im  ! Gave 'The RE or IM part_ref at (1) must be applied to a
                ! COMPLEX expression'
      if (int(100*y)-235 /= 0) stop 2
   end associate

! Check that more complex(pun intended!) expressions are OK.
   associate (x => exp (log(cmplx(-1,0))+cmplx(0,0.5)))
      y = x%re  ! Gave 'Symbol ‘x’ at (1) has no IMPLICIT type'
      if (int(1000*y)+877 /= 0) stop 3
   end associate

! Make sure that AIMAG intrinsic is OK.
   associate (x => ((log(cmplx(-1,0.5)))))
      y = aimag (x)
      if (int(100*y)-267 /= 0) stop 4
   end associate
end program

[-- Attachment #5: associate_66.f90 --]
[-- Type: text/x-fortran, Size: 1210 bytes --]

! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! Tests unlimited polymorphic function selectors in ASSOCIATE.
!
! Contributed by Harald Anlauf  <anlauf@gmx.de> in
! https://gcc.gnu.org/pipermail/fortran/2024-January/060098.html
!
program p
   implicit none
!             scalar             array
   associate (var1 => foo1(),    var2 => foo2())
    call prt (var1);   call prt (var2)
   end associate
contains
! Scalar value
   function foo1() result(res)
     class(*), allocatable :: res
     res = 42.0
   end function foo1
! Array value
   function foo2() result(res)
     class(*), allocatable :: res(:)
     res = [42, 84]
   end function foo2
! Test the associate-name value
   subroutine prt (x)
     class(*), intent(in) :: x(..)
     logical :: ok = .false.
     select rank(x)
       rank (0)
         select type (x)
           type is (real)
           if (int(x*10) .eq. 420) ok = .true.
         end select
       rank (1)
         select type (x)
           type is (integer)
           if (all (x .eq. [42, 84])) ok = .true.
         end select
     end select
     if (.not.ok) stop 1
   end subroutine prt
end
! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } }

[-- Attachment #6: associate_67.f90 --]
[-- Type: text/x-fortran, Size: 1036 bytes --]

! { dg-do run }
!
! Tests pointer function selectors in ASSOCIATE.
!
! Contributed by Harald Anlauf  <anlauf@gmx.de> in
! https://gcc.gnu.org/pipermail/fortran/2024-March/060294.html
program paul
  implicit none
  type t
     integer :: i
  end type t
  type(t), pointer :: p(:)
  integer :: j
  allocate (p(-3:3))
  p% i = [(j,j=-3,3)]

  associate (q => p)
    print *, lbound (q), ubound (q) ! Should print -3 3 (OK)
    print *, q% i
  end associate

  associate (q => set_ptr())
    print *, lbound (q), ubound (q) ! Should print -3 3 (OK)
    print *, q(:)% i                ! <<< ... has no IMPLICIT type
  end associate

  associate (q => (p))
    print *, lbound (q), ubound (q) ! Should print 1 7 (OK)
    print *, q% i
  end associate

  associate (q => (set_ptr()))
    print *, lbound (q), ubound (q) ! Should print 1 7 (OK)
    print *, q(:)% i                ! <<< ... has no IMPLICIT type
  end associate
contains
  function set_ptr () result (res)
    type(t), pointer :: res(:)
    res => p
  end function set_ptr
end

[-- Attachment #7: associate_68.f90 --]
[-- Type: text/x-fortran, Size: 2293 bytes --]

! { dg-do run }
! Test the fix for PR114280 in which inquiry references of associate names
! of as yet unparsed function selectors failed.
! Contributed by Steve Kargl  <>
program paul2
  implicit none
  type t
     real :: re
  end type t
  real :: comp = 1, repart = 10, impart =100
  call foo
contains
  subroutine foo ()
    associate (x => bar1())
! 'x' identified as complex from outset
      if (int(x%im) .ne. 100) stop 1         ! Has no IMPLICIT type
      if (int(x%re) .ne. 10) stop 2
    end associate

    associate (x => bar1())
! 'x' identified as derived then corrected to complex
      if (int(x%re) .ne. 11) stop 3          ! Has no IMPLICIT type
      if (int(x%im) .ne. 101) stop 4
      if (x%kind .ne. kind(1.0)) stop 5
    end associate

    associate (x => bar1())
      if (x%kind .ne. kind(1.0)) stop 6      ! Invalid character in name
    end associate

    associate (x => bar2())
      if (int(x%re) .ne. 1) stop 7           ! Invalid character in name
    end associate

    associate (xx => bar3())
      if (xx%len .ne. 8) stop 8               ! Has no IMPLICIT type
      if (trim (xx) .ne. "Nice one") stop 9
      if (xx(6:8) .ne. "one") stop 10
    end associate

! Now check the array versions
    associate (x => bar4())
      if (any (int(abs (x(:) + 2.0)) .ne. [104,105])) stop 0
      if (int(x(2)%re) .ne. 14) stop 11
      if (any (int(x%im) .ne. [103,104])) stop 12
      if (any (int(abs(x)) .ne. [103,104])) stop 13
    end associate

    associate (x => bar5())
      if (x(:)%kind .ne. kind("A")) stop 14
      if (x(2)%len .ne. 4) stop 15
      if (x%len .ne. 4) stop 16
      if (x(2)(1:3) .ne. "two") stop 17
      if (any(x .ne. ["one ", "two "])) stop 18
    end associate
  end
  complex function bar1 ()
    bar1 = cmplx(repart, impart)
    repart = repart + 1
    impart = impart + 1
  end
  type(t) function bar2 ()
    bar2% re = comp
    comp = comp + 1
  end
  character(8) function bar3 ()
    bar3 = "Nice one!"
  end
  function bar4 () result (res)
    complex, allocatable, dimension(:) :: res
    res = [cmplx(repart, impart),cmplx(repart+1, impart+1)]
    repart = repart + 2
    impart = impart + 2
  end
  function bar5 () result (res)
    character(4), allocatable, dimension(:) :: res
    res = ["one ", "two "]
  end
end

^ permalink raw reply	[flat|nested] 7+ messages in thread

* Re: [Patch, fortran PR89645/99065 No IMPLICIT type error with: ASSOCIATE( X => function() )
  2024-03-12 14:54       ` Paul Richard Thomas
@ 2024-03-12 21:07         ` Harald Anlauf
  2024-03-12 21:28           ` Paul Richard Thomas
  0 siblings, 1 reply; 7+ messages in thread
From: Harald Anlauf @ 2024-03-12 21:07 UTC (permalink / raw)
  To: Paul Richard Thomas, fortran, gcc-patches; +Cc: Steve Kargl, Damian Rouson

Hi Paul,

On 3/12/24 15:54, Paul Richard Thomas wrote:
> Hi All,
>
> This is the last posting of this patch before I push it. Harald is OK with
> it on the grounds that the inferred_type flag guards the whole lot,
> except for the chunks in trans-stmt.cc.
>
> In spite of Harald's off-list admonition not to try to fix everything at
> once, this version fixes most of the inquiry reference bugs
> (associate_68.f90) with the exception of character(kind=4) function
> selectors. The reason for this is that I have some housekeeping to do
> before release on finalization and then I want to replace this patch in
> 15-branch with two pass parsing. My first attempts at the latter were a
> partial success.

you wouldn't stop trying to fix everything, would you?  ;-)

> It regtests OK on x86_64. Unless there are objections, I will commit on
> Thursday evening.

No objections, just one wish: could you improve the text of the
following comments so that mere mortals understand them?

diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 12e7bf3c873..0ab69bb9dce 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
[...]
+      /* If there is a usable inquiry reference not there are no matching
+	 derived types, force the inquiry reference by setting unknown the
+	 type of the primary expression.  */


I have a hard time parsing the first part of that sentence.

diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 5d9852c79e0..16adb2a7efb 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
[...]
+/* 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.


"a component" too much?

Thanks,
Harald

> Cheers
>
> Paul


^ permalink raw reply	[flat|nested] 7+ messages in thread

* Re: [Patch, fortran PR89645/99065 No IMPLICIT type error with: ASSOCIATE( X => function() )
  2024-03-12 21:07         ` Harald Anlauf
@ 2024-03-12 21:28           ` Paul Richard Thomas
  0 siblings, 0 replies; 7+ messages in thread
From: Paul Richard Thomas @ 2024-03-12 21:28 UTC (permalink / raw)
  To: Harald Anlauf; +Cc: fortran, gcc-patches, Steve Kargl, Damian Rouson

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

Hi Harald,

Roger that about the comments. The major part of my recent efforts has been
to maximise comments - apparently not always successfully!

The main reason that I want to "fix everything" is that this is it; I will
not work on this approach anymore. The gfortran/g95 founder's approach was
very clever but has found it's limit with the associate construct. The sad
thing is that this is the only blocker that I know of.

Thanks

Paul


On Tue, 12 Mar 2024 at 21:07, Harald Anlauf <anlauf@gmx.de> wrote:

> Hi Paul,
>
> On 3/12/24 15:54, Paul Richard Thomas wrote:
> > Hi All,
> >
> > This is the last posting of this patch before I push it. Harald is OK
> with
> > it on the grounds that the inferred_type flag guards the whole lot,
> > except for the chunks in trans-stmt.cc.
> >
> > In spite of Harald's off-list admonition not to try to fix everything at
> > once, this version fixes most of the inquiry reference bugs
> > (associate_68.f90) with the exception of character(kind=4) function
> > selectors. The reason for this is that I have some housekeeping to do
> > before release on finalization and then I want to replace this patch in
> > 15-branch with two pass parsing. My first attempts at the latter were a
> > partial success.
>
> you wouldn't stop trying to fix everything, would you?  ;-)
>
> > It regtests OK on x86_64. Unless there are objections, I will commit on
> > Thursday evening.
>
> No objections, just one wish: could you improve the text of the
> following comments so that mere mortals understand them?
>
> diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
> index 12e7bf3c873..0ab69bb9dce 100644
> --- a/gcc/fortran/primary.cc
> +++ b/gcc/fortran/primary.cc
> [...]
> +      /* If there is a usable inquiry reference not there are no matching
> +        derived types, force the inquiry reference by setting unknown the
> +        type of the primary expression.  */
>
>
> I have a hard time parsing the first part of that sentence.
>
> diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
> index 5d9852c79e0..16adb2a7efb 100644
> --- a/gcc/fortran/symbol.cc
> +++ b/gcc/fortran/symbol.cc
> [...]
> +/* 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.
>
>
> "a component" too much?
>
> Thanks,
> Harald
>
> > Cheers
> >
> > Paul
>
>

^ permalink raw reply	[flat|nested] 7+ messages in thread

end of thread, other threads:[~2024-03-12 21:28 UTC | newest]

Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-01-06 17:26 [Patch, fortran PR89645/99065 No IMPLICIT type error with: ASSOCIATE( X => function() ) Paul Richard Thomas
2024-01-08 21:53 ` Harald Anlauf
2024-03-03 16:04   ` Paul Richard Thomas
2024-03-03 20:20     ` Harald Anlauf
2024-03-12 14:54       ` Paul Richard Thomas
2024-03-12 21:07         ` Harald Anlauf
2024-03-12 21:28           ` Paul Richard Thomas

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).