Fortran: Use specific PDT constructors from a generic list [PR122452]

2025-10-31  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/122452
	* primary.cc (gfc_match_rvalue): Give priority to specific
	procedures in a generic interface with the same name as a
	PDT template. If found, use as the procedure instead of the
	constructor generated from the PDT template.

gcc/testsuite/
	PR fortran/122452
	* gfortran.dg/pdt_65.f03: New test.

diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 0722c76d9e5db857c77d4a7c039b1ce446b6b73f..1dcb1c3b5614ce9832e7688644617d5b906fe77b 100644 (file)
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -3835,6 +3835,9 @@ gfc_match_rvalue (gfc_expr **result)
   gfc_typespec *ts;
   bool implicit_char;
   gfc_ref *ref;
+  gfc_symtree *pdt_st;
+  gfc_symbol *found_specific = NULL;
+
 
   m = gfc_match ("%%loc");
   if (m == MATCH_YES)
@@ -4082,22 +4085,36 @@ 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)
+      if (sym->attr.generic && pdt_st != NULL && found_specific == NULL)
        {
-         gfc_symtree *pdt_st;
          gfc_symbol *pdt_sym;
          gfc_actual_arglist *ctr_arglist = NULL, *tmp;
          gfc_component *c;
 
-         /* Obtain the template.  */
-         gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st);
-         if (pdt_st && pdt_st->n.sym && pdt_st->n.sym->attr.pdt_template)
+         /* Use the template.  */
+         if (pdt_st->n.sym && pdt_st->n.sym->attr.pdt_template)
            {
              bool type_spec_list = false;
              pdt_sym = pdt_st->n.sym;
@@ -4155,8 +4172,12 @@ gfc_match_rvalue (gfc_expr **result)
                  tmp = tmp->next;
                }
 
-             gfc_find_sym_tree (gfc_dt_lower_string (pdt_sym->name),
-                                NULL, 1, &symtree);
+             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);
              if (!symtree)
                {
                  gfc_get_ha_sym_tree (gfc_dt_lower_string (pdt_sym->name) ,

diff --git a/gcc/testsuite/gfortran.dg/pdt_65.f03 b/gcc/testsuite/gfortran.dg/pdt_65.f03
new file mode 100644 (file)
index 0000000..d5e45c2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_65.f03
@@ -0,0 +1,135 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test fix for PR122452
+!
+! Contributed by Damian Rouson  <damian@archaeologic.codes>
+!
+module kind_parameters_m
+  integer, parameter :: default_real = kind(1e0)
+  integer, parameter :: double_precision = kind(1d0)
+end module
+
+module tensor_m
+  use kind_parameters_m, only : default_real, double_precision
+  implicit none
+
+  private
+  public :: tensor_t
+
+  type tensor_t(k)
+    integer, kind :: k = default_real 
+    real(k), allocatable, private :: values_(:)
+  contains
+    generic   :: values => default_real_values, double_precision_values
+    procedure, private, non_overridable ::  default_real_values, double_precision_values
+    generic :: num_components => default_real_num_components, double_precision_num_components
+    procedure, private ::        default_real_num_components, double_precision_num_components
+  end type
+
+  interface tensor_t
+
+    pure module function construct_default_real(values) result(tensor)
+      implicit none
+      real, intent(in) :: values(:)
+      type(tensor_t) tensor
+    end function
+
+    pure module function construct_double_precision(values) result(tensor)
+      implicit none
+      double precision, intent(in) :: values(:)
+      type(tensor_t(double_precision)) tensor
+    end function
+
+  end interface
+
+  interface
+
+    pure module function default_real_values(self) result(tensor_values)
+      implicit none
+      class(tensor_t), intent(in) :: self
+      real, allocatable :: tensor_values(:)
+    end function
+
+    pure module function double_precision_values(self) result(tensor_values)
+      implicit none
+      class(tensor_t(double_precision)), intent(in) :: self
+      double precision, allocatable :: tensor_values(:)
+    end function
+
+    pure module function default_real_num_components(self) result(n)
+      implicit none
+      class(tensor_t), intent(in) :: self
+      integer n
+    end function
+
+    pure module function double_precision_num_components(self) result(n)
+      implicit none
+      class(tensor_t(double_precision)), intent(in) :: self
+      integer n
+    end function
+
+  end interface
+
+end module tensor_m
+
+submodule(tensor_m) tensor_s
+contains
+
+    pure module function construct_default_real(values) result(tensor)
+      implicit none
+      real, intent(in) :: values(:)
+      type(tensor_t) tensor
+      tensor = tensor_t ()(values)
+    end function
+
+    pure module function construct_double_precision(values) result(tensor)
+      implicit none
+      double precision, intent(in) :: values(:)
+      type(tensor_t(double_precision)) tensor
+      tensor = tensor_t (double_precision)(values)
+    end function
+
+    pure module function default_real_values(self) result(tensor_values)
+      implicit none
+      class(tensor_t), intent(in) :: self
+      real, allocatable :: tensor_values(:)
+      tensor_values = self%values_
+    end function
+
+    pure module function double_precision_values(self) result(tensor_values)
+      implicit none
+      class(tensor_t(double_precision)), intent(in) :: self
+      double precision, allocatable :: tensor_values(:)
+      tensor_values = self%values_
+    end function
+
+
+    pure module function default_real_num_components(self) result(n)
+      implicit none
+      class(tensor_t), intent(in) :: self
+      integer n
+      n = default_real
+    end function
+
+    pure module function double_precision_num_components(self) result(n)
+      implicit none
+      class(tensor_t(double_precision)), intent(in) :: self
+      integer n
+      n = double_precision
+    end function
+
+end submodule tensor_s
+
+
+  use tensor_m
+  type(tensor_t(kind(0e0))) :: a
+  type(tensor_t(kind(0D0))) :: b
+  a = tensor_t ([1e0,2e0])
+  print *, a%num_components (), a%values ()
+  b = tensor_t ([3d0,4d0])
+  print *, b%num_components (), b%values ()
+end
+! { dg-final { scan-tree-dump-times "construct_" 4 "original" } }
+! { dg-final { scan-tree-dump-times "_components" 4 "original" } }
+! { dg-final { scan-tree-dump-times "_values" 4 "original" } }