Fortran: Fix PDT constructors in associate [PR122501, PR122524]

2025-11-05  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/122501
	PR fortran/122524
	* primary.cc (gfc_convert_to_structure_constructor): Correct
	whitespace issue.
	(gfc_match_rvalue): Remove the attempt to match specific procs
	before filling out PDT constructor. Instead, defer this until
	resolution with the condition that there not be a following
	arglist and more than one procedure in the generic interface.

gcc/testsuite/
	PR fortran/122501
	* gfortran.dg/pdt_66.f03: New test.

	PR fortran/122524
	* gfortran.dg/pdt_67.f03: New test.

Author: Paul Thomas

gcc/fortran/primary.cc

@@ -3543,7 +3543,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
 	}
 
       /* Find the current component in the structure definition and check
-	     its access is not private.  */
+	 its access is not private.  */
       if (comp)
 	this_comp = gfc_find_component (sym, comp->name, false, false, NULL);
       else
@@ -3836,8 +3836,6 @@ gfc_match_rvalue (gfc_expr **result)
   bool implicit_char;
   gfc_ref *ref;
   gfc_symtree *pdt_st;
-  gfc_symbol *found_specific = NULL;
-
 
   m = gfc_match ("%%loc");
   if (m == MATCH_YES)
@@ -4085,29 +4083,21 @@ gfc_match_rvalue (gfc_expr **result)
 	  break;
 	}
 
-      gfc_gobble_whitespace ();
-      found_specific = NULL;
-
-      /* Even if 'name' is that of a PDT template, priority has to be given to
-	 possible specific procedures in the generic interface.  */
-      gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st);
-      if (sym->generic && sym->generic->next
-	  && gfc_peek_ascii_char() != '(')
-	{
-	  gfc_actual_arglist *arg = actual_arglist;
-	  for (; arg && pdt_st; arg = arg->next)
-	    gfc_resolve_expr (arg->expr);
-	  found_specific = gfc_search_interface (sym->generic, 0,
-						 &actual_arglist);
-	}
-
       /* Check to see if this is a PDT constructor.  The format of these
 	 constructors is rather unusual:
 		name [(type_params)](component_values)
 	 where, component_values excludes the type_params. With the present
 	 gfortran representation this is rather awkward because the two are not
-	 distinguished, other than by their attributes.  */
-      if (sym->attr.generic && pdt_st != NULL && found_specific == NULL)
+	 distinguished, other than by their attributes.
+
+	 Even if 'name' is that of a PDT template, priority has to be given to
+	 specific procedures, other than the constructor, in the generic
+	 interface.  */
+
+      gfc_gobble_whitespace ();
+      gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st);
+      if (sym->attr.generic && pdt_st != NULL
+	  && !(sym->generic->next && gfc_peek_ascii_char() != '('))
 	{
 	  gfc_symbol *pdt_sym;
 	  gfc_actual_arglist *ctr_arglist = NULL, *tmp;
@@ -4172,12 +4162,8 @@ gfc_match_rvalue (gfc_expr **result)
 		  tmp = tmp->next;
 		}
 
-	      if (found_specific)
-		gfc_find_sym_tree (found_specific->name,
-				   NULL, 1, &symtree);
-	      else
-		gfc_find_sym_tree (gfc_dt_lower_string (pdt_sym->name),
-				   NULL, 1, &symtree);
+	      gfc_find_sym_tree (gfc_dt_lower_string (pdt_sym->name),
+				 NULL, 1, &symtree);
 	      if (!symtree)
 		{
 		  gfc_get_ha_sym_tree (gfc_dt_lower_string (pdt_sym->name) ,

gcc/testsuite/gfortran.dg/pdt_66.f03

@@ -0,0 +1,54 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Check the fix for PR122501.
+!
+! Contributed by Damian Rouson  <damian@archaeologic.codes>
+!
+module tensor_m
+  implicit none
+
+  type tensor_t(k)
+    integer, kind :: k = kind(1.)
+    real(k), allocatable, private :: values_(:)
+  contains
+    procedure default_real_values
+  end type
+
+  interface tensor_t
+    type(tensor_t) module function construct_default_real(values)
+      implicit none
+      real values(:)
+    end function
+  end interface
+
+  interface
+    module function default_real_values(self) result(tensor_values)
+      implicit none
+      class(tensor_t) self
+      real, allocatable :: tensor_values(:)
+    end function
+  end interface
+end module 
+
+  use tensor_m
+  implicit none
+contains
+  function copy(tensor)
+    type(tensor_t) tensor, copy, norm_copy
+    associate(tensor_values => tensor%default_real_values())
+
+! This gave: "Component ‘values_’ at (1) is a PRIVATE component of ‘tensor_t’"
+      copy = tensor_t(tensor_values)
+
+    end associate
+
+! Make sure that the fix really works :-)
+    associate(f => tensor%default_real_values())
+      associate(tensor_values => tensor%default_real_values())
+        norm_copy = tensor_t(tensor_values/maxval(f))
+      end associate
+    end associate
+  end function
+end
+! { dg-final { scan-tree-dump-times "default_real_values" 3 "original" } }

gcc/testsuite/gfortran.dg/pdt_67.f03

@@ -0,0 +1,36 @@
+! { dg-do compile }
+!
+! Check the fix for PR122524.
+!
+! Contributed by Damian Rouson  <damian@archaeologic.codes>
+!
+module tensor_map_m
+  implicit none
+
+  type tensor_t(k)
+    integer, kind :: k = kind(1.)
+    real(k), allocatable :: values_(:)
+  end type
+
+  interface tensor_t
+    module function tensor(values)
+      implicit none
+      double precision values(:)
+      type(tensor_t(kind(0D0))) tensor
+    end function
+  end interface
+
+  type tensor_map_t(k)
+    integer, kind :: k = kind(1.)
+    real(k) slope_
+  end type
+
+contains
+  function unnormalized_tensor(self, tensor)
+    type(tensor_map_t(kind(0D0))) self
+    type(tensor_t(kind(0D0))) tensor, unnormalized_tensor
+    associate(unnormalized_values => tensor%values_*self%slope_)
+      unnormalized_tensor = tensor_t(unnormalized_values)   ! Caused an ICE.
+    end associate
+  end function
+end module