Fortran: [PDT] Unresolved component and generic binding [PR122578]

2025-12-06  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/122578
	* primary.cc (gfc_match_varspec): Try to resolve a typebound
	generic procedure selector expression to provide the associate
	name with a type. Also, resolve component calls. In both cases,
	make a copy of the selector expression to guard against changes
	made by gfc_resolve_expr.

gcc/testsuite
	PR fortran/122578
	* gfortran.dg/pdt_72.f03: New test.

diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 729e3b523fa4f0876e26635a33089a181e45dd25..e5e84e897ffacb5deda883950095595452ccd553 100644 (file)
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2261,6 +2261,32 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
       && !sym->attr.select_rank_temporary)
     inferred_type = true;
 
+  /* Try to resolve a typebound generic procedure so that the associate name
+     has a chance to get a type before being used in a second, nested associate
+     statement. Note that a copy is used for resolution so that failure does
+     not result in a mutilated selector expression further down the line.  */
+  if (tgt_expr && !sym->assoc->dangling
+      && tgt_expr->ts.type == BT_UNKNOWN
+      && tgt_expr->symtree
+      && tgt_expr->symtree->n.sym
+      && gfc_expr_attr (tgt_expr).generic
+      && ((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_template)
+         || (sym->ts.type == BT_CLASS
+             && CLASS_DATA (sym)->ts.u.derived->attr.pdt_template)))
+    {
+       gfc_expr *cpy = gfc_copy_expr (tgt_expr);
+       if (gfc_resolve_expr (cpy)
+           && cpy->ts.type != BT_UNKNOWN)
+         {
+           gfc_replace_expr (tgt_expr, cpy);
+           sym->ts = tgt_expr->ts;
+         }
+       else
+         gfc_free_expr (cpy);
+       if (gfc_expr_attr (tgt_expr).generic)
+         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
@@ -2493,6 +2519,20 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
               && !gfc_find_derived_types (sym, gfc_current_ns, name))
        primary->ts.type = BT_UNKNOWN;
 
+      /* Otherwise try resolving a copy of a component call. If it succeeds,
+        use that for the selector expression.  */
+      else if (tgt_expr && tgt_expr->expr_type == EXPR_COMPCALL)
+         {
+            gfc_expr *cpy = gfc_copy_expr (tgt_expr);
+            if (gfc_resolve_expr (cpy))
+               {
+                 gfc_replace_expr (tgt_expr, cpy);
+                 sym->ts = tgt_expr->ts;
+               }
+             else
+               gfc_free_expr (cpy);
+         }
+
       /* An inquiry reference might determine the type, otherwise we have an
         error.  */
       if (sym->ts.type == BT_UNKNOWN && !inquiry)

diff --git a/gcc/testsuite/gfortran.dg/pdt_72.f03 b/gcc/testsuite/gfortran.dg/pdt_72.f03
new file mode 100644 (file)
index 0000000..57640bd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_72.f03
@@ -0,0 +1,110 @@
+! { dg-do compile }
+!
+! Tests the fix for pr122578, which failed in compilation with the errors
+! shown below.
+!
+! Contributed by Damian Rouson  <damian@archaeologic.codes>
+!
+module tensor_map_m
+  use iso_c_binding, only :  c_int
+  implicit none
+
+  type tensor_t(k)
+    integer, kind :: k = kind(1.)
+    real(k), allocatable :: values_(:) ! Error: Cannot convert REAL(0) to REAL(4) at (1)
+  contains
+    generic   :: values => default_real_values
+    procedure default_real_values
+  end type
+
+  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
+  end interface
+
+  type tensor_map_t(k)
+    integer, kind :: k = kind(1.)
+    real(k), dimension(:), allocatable :: intercept_, slope_
+  contains
+    generic :: map_to_training_range    => default_real_map_to_training_range
+    procedure :: default_real_map_to_training_range
+    generic :: map_from_training_range  => default_real_map_from_training_range
+    procedure :: default_real_map_from_training_range
+  end type
+
+  interface
+    elemental module function default_real_map_to_training_range(self, tensor) result(normalized_tensor)
+      implicit none
+      class(tensor_map_t), intent(in) :: self
+      type(tensor_t), intent(in) :: tensor
+      type(tensor_t) normalized_tensor
+    end function
+
+    elemental module function default_real_map_from_training_range(self, tensor) result(unnormalized_tensor)
+      implicit none
+      class(tensor_map_t), intent(in) :: self
+      type(tensor_t), intent(in) :: tensor
+      type(tensor_t) unnormalized_tensor
+    end function
+  end interface
+
+  type activation_t
+    integer(c_int) :: selection_
+  contains
+    generic :: evaluate => default_real_evaluate
+    procedure default_real_evaluate
+  end type
+
+  interface
+    elemental module function default_real_evaluate(self, x) result(y)
+      implicit none
+      class(activation_t), intent(in) :: self
+      real, intent(in) :: x 
+      real y 
+    end function
+  end interface
+
+  type neural_network_t(k)
+    integer, kind :: k = kind(1.)
+    type(tensor_map_t(k)) input_map_, output_map_
+    real(k), allocatable :: weights_(:,:,:), biases_(:,:)
+    integer, allocatable :: nodes_(:)
+    type(activation_t) :: activation_
+  contains
+    generic :: infer => default_real_infer
+    procedure default_real_infer
+  end type
+
+  integer, parameter :: input_layer = 0 
+contains
+  elemental function default_real_infer(self, inputs) result(outputs)
+    class(neural_network_t), intent(in) :: self
+    type(tensor_t), intent(in) :: inputs
+    type(tensor_t) outputs
+    real, allocatable :: a(:,:)
+    integer l
+    associate(w => self%weights_, b => self%biases_, n => self%nodes_, output_layer => ubound(self%nodes_,1))
+      allocate(a(maxval(n), input_layer:output_layer))
+      associate(normalized_inputs => self%input_map_%map_to_training_range(inputs))
+        a(1:n(input_layer),input_layer) = normalized_inputs%values() ! Error: Symbol ‘normalized_inputs’
+                                                                     ! at (1) has no IMPLICIT type
+
+      end associate
+      feed_forward: &
+      do l = input_layer+1, output_layer
+        associate(z => matmul(w(1:n(l),1:n(l-1),l), a(1:n(l-1),l-1)) + b(1:n(l),l))
+          a(1:n(l),l) = self%activation_%evaluate(z)
+        end associate
+      end do feed_forward
+      associate(normalized_outputs => tensor_t(a(1:n(output_layer), output_layer)))
+        outputs = self%output_map_%map_from_training_range(normalized_outputs) ! Error: Found no matching specific
+                                                                               ! binding for the call to the GENERIC
+                                                                               ! ‘map_from_training_range’ at (1)
+
+      end associate
+    end associate
+  end function
+end module