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.

diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 1dcb1c3b5614ce9832e7688644617d5b906fe77b..496ee45294e41c81f4b911ea7fc0c9d53a7916c2 100644 (file)
--- a/gcc/fortran/primary.cc
+++ b/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) ,

diff --git a/gcc/testsuite/gfortran.dg/pdt_66.f03 b/gcc/testsuite/gfortran.dg/pdt_66.f03
new file mode 100644 (file)
index 0000000..269f6b4
--- /dev/null
+++ b/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" } }

diff --git a/gcc/testsuite/gfortran.dg/pdt_67.f03 b/gcc/testsuite/gfortran.dg/pdt_67.f03
new file mode 100644 (file)
index 0000000..b59d201
--- /dev/null
+++ b/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