Fortran: Fix some bugs in associate [PR87477]

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

gcc/fortran
	PR fortran/87477
	PR fortran/88688
	PR fortran/94380
	PR fortran/107900
	PR fortran/110224
	* decl.cc (char_len_param_value): Fix memory leak.
	(resolve_block_construct): Remove unnecessary static decls.
	* expr.cc (gfc_is_ptr_fcn): New function.
	(gfc_check_vardef_context): Use it to permit pointer function
	result selectors to be used for associate names in variable
	definition context.
	* gfortran.h: Prototype for gfc_is_ptr_fcn.
	* match.cc (build_associate_name): New function.
	(gfc_match_select_type): Use the new function to replace inline
	version and to build a new associate name for the case where
	the supplied associate name is already used for that purpose.
	* resolve.cc (resolve_assoc_var): Call gfc_is_ptr_fcn to allow
	associate names with pointer function targets to be used in
	variable definition context.
	* trans-decl.cc (gfc_get_symbol_decl): Unlimited polymorphic
	variables need deferred initialisation of the vptr.
	(gfc_trans_deferred_vars): Do the vptr initialisation.
	* trans-stmt.cc (trans_associate_var): Ensure that a pointer
	associate name points to the target of the selector and not
	the selector itself.

gcc/testsuite/
	PR fortran/87477
	PR fortran/107900
	* gfortran.dg/pr107900.f90 : New test

	PR fortran/110224
	* gfortran.dg/pr110224.f90 : New test

	PR fortran/88688
	* gfortran.dg/pr88688.f90 : New test

	PR fortran/94380
	* gfortran.dg/pr94380.f90 : New test

	PR fortran/95398
	* gfortran.dg/pr95398.f90 : Set -std=f2008, bump the line
	numbers in the error tests by two and change the text in two.

1 files changed, 33 insertions, 0 deletions

diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index e6a4337..18589e1 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -1875,6 +1875,15 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	  && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
     gfc_defer_symbol_init (sym);
 
+  /* Set the vptr of unlimited polymorphic pointer variables so that
+     they do not cause segfaults in select type, when the selector
+     is an intrinsic type.  Arrays are captured above.  */
+  if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym)
+      && CLASS_DATA (sym)->attr.class_pointer
+      && !CLASS_DATA (sym)->attr.dimension && !sym->attr.dummy
+      && sym->attr.flavor == FL_VARIABLE && !sym->assoc)
+    gfc_defer_symbol_init (sym);
+
   if (sym->ts.type == BT_CHARACTER
       && sym->attr.allocatable
       && !sym->attr.dimension
@@ -1906,6 +1915,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL);
     }
 
+
   gfc_finish_var_decl (decl, sym);
 
   if (sym->ts.type == BT_CHARACTER)
@@ -4652,6 +4662,29 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
       if (sym->assoc)
 	continue;
 
+      /* Set the vptr of unlimited polymorphic pointer variables so that
+	 they do not cause segfaults in select type, when the selector
+	 is an intrinsic type.  */
+      if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym)
+	  && sym->attr.flavor == FL_VARIABLE && !sym->assoc
+	  && !sym->attr.dummy && CLASS_DATA (sym)->attr.class_pointer)
+	{
+	  gfc_symbol *vtab;
+	  gfc_init_block (&tmpblock);
+	  vtab = gfc_find_vtab (&sym->ts);
+	  if (!vtab->backend_decl)
+	    {
+	      if (!vtab->attr.referenced)
+		gfc_set_sym_referenced (vtab);
+	      gfc_get_symbol_decl (vtab);
+	    }
+	  tmp = gfc_class_vptr_get (sym->backend_decl);
+	  gfc_add_modify (&tmpblock, tmp,
+			  gfc_build_addr_expr (TREE_TYPE (tmp),
+					       vtab->backend_decl));
+	  gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL);
+	}
+
       if (sym->ts.type == BT_DERIVED
 	  && sym->ts.u.derived
 	  && sym->ts.u.derived->attr.pdt_type)