Fortran: Implement PDT constructors with syntax variants [PR114815]

2025-09-18  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/114815
	* decl.cc (gfc_get_pdt_instance): Copy the contents of 'tb' and
	not the pointer.
	* primary.cc (gfc_match_rvalue): If there is only one actual
	argument list, use if for the type spec parameter values. If
	this fails try the default type specification values and use
	the actual arguments for the component values.
	* resolve.cc (build_init_assign): Don't initialize implicit PDT
	function results.

gcc/testsuite/
	PR fortran/114815
	* gfortran.dg/pdt_3.f03: Add missing deallocation of 'matrix'.
	* gfortran.dg/pdt_17.f03: Change dg-error text.
	* gfortran.dg/pdt_47.f03: New test.

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 9fe697cd5498467df2600fe878956e8050a28adb..99644939056371b1b3b73ebc31cbde4d88b21e7b 100644 (file)
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -4092,7 +4092,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
       if (c1->tb)
        {
          c2->tb = gfc_get_tbp ();
-         c2->tb = c1->tb;
+         *c2->tb = *c1->tb;
        }
 
       /* The order of declaration of the type_specs might not be the

diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 2cb930d83b8ce4111798ccdf3adb9df5fd5bb930..638018bcce37cd05fee7719b42596f99380f6eba 100644 (file)
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -4059,7 +4059,7 @@ gfc_match_rvalue (gfc_expr **result)
 
       /* Check to see if this is a PDT constructor.  The format of these
         constructors is rather unusual:
-               name (type_params)(component_values)
+               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.  */
@@ -4074,7 +4074,15 @@ gfc_match_rvalue (gfc_expr **result)
          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)
            {
+             bool type_spec_list = false;
              pdt_sym = pdt_st->n.sym;
+             gfc_gobble_whitespace ();
+             /* Look for a second actual arglist. If present, try the first
+                for the type parameters. Otherwise, or if there is no match,
+                depend on default values by setting the type parameters to
+                NULL.  */
+             if (gfc_peek_ascii_char() == '(')
+               type_spec_list = true;
 
              /* Generate this instance using the type parameters from the
                 first argument list and return the parameter list in
@@ -4082,15 +4090,27 @@ gfc_match_rvalue (gfc_expr **result)
              m = gfc_get_pdt_instance (actual_arglist, &pdt_sym, &ctr_arglist);
              if (m != MATCH_YES)
                {
-                 m = MATCH_ERROR;
-                 break;
+                 if (ctr_arglist)
+                   gfc_free_actual_arglist (ctr_arglist);
+                 /* See if all the type parameters have default values.  */
+                 m = gfc_get_pdt_instance (NULL, &pdt_sym, &ctr_arglist);
+                 if (m != MATCH_YES)
+                   {
+                     m = MATCH_NO;
+                     break;
+                   }
                }
-             /* Now match the component_values.  */
-             m = gfc_match_actual_arglist (0, &actual_arglist);
-             if (m != MATCH_YES)
+
+             /* Now match the component_values if the type parameters were
+                present.  */
+             if (type_spec_list)
                {
-                 m = MATCH_ERROR;
-                 break;
+                 m = gfc_match_actual_arglist (0, &actual_arglist);
+                 if (m != MATCH_YES)
+                   {
+                     m = MATCH_ERROR;
+                     break;
+                   }
                }
 
              /* Make sure that the component names are in place so that this
@@ -4104,13 +4124,18 @@ gfc_match_rvalue (gfc_expr **result)
                  tmp = tmp->next;
                }
 
-             gfc_get_ha_sym_tree (gfc_dt_lower_string (pdt_sym->name) ,
-                                  &symtree);
-             symtree->n.sym = pdt_sym;
-             symtree->n.sym->ts.u.derived = pdt_sym;
-             symtree->n.sym->ts.type = BT_DERIVED;
+             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) ,
+                                      &symtree);
+                 symtree->n.sym = pdt_sym;
+                 symtree->n.sym->ts.u.derived = pdt_sym;
+                 symtree->n.sym->ts.type = BT_DERIVED;
+               }
 
-             /* Do the appending.  */
+             /* Append the type_params and the component_values.  */
              for (tmp = ctr_arglist; tmp && tmp->next;)
                tmp = tmp->next;
              tmp->next = actual_arglist;

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index b83961fe6f10c17b3876ea3a0371e7934838646d..daff3b3e33bac10771210887c49fb38e9178f307 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -14613,6 +14613,13 @@ build_init_assign (gfc_symbol *sym, gfc_expr *init)
   gfc_code *init_st;
   gfc_namespace *ns = sym->ns;
 
+  if (sym->attr.function && sym->result == sym
+      && sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
+    {
+      gfc_free_expr (init);
+      return;
+    }
+
   /* Search for the function namespace if this is a contained
      function without an explicit result.  */
   if (sym->attr.function && sym == sym->result

diff --git a/gcc/testsuite/gfortran.dg/pdt_17.f03 b/gcc/testsuite/gfortran.dg/pdt_17.f03
index 1b0a30dca4cb2cca1e802579bf70015838b5ac10..d03e2d139a023d90ef25c76425a43bca9972f64e 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pdt_17.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_17.f03
@@ -6,6 +6,6 @@
 !
 program p
    type t(a)                   ! { dg-error "does not have a component" }
-      integer(kind=t()) :: x   ! { dg-error "used before it is defined" }
+      integer(kind=t()) :: x   ! { dg-error "Expected initialization expression" }
    end type
 end

diff --git a/gcc/testsuite/gfortran.dg/pdt_3.f03 b/gcc/testsuite/gfortran.dg/pdt_3.f03
index cd48364b1534eaa016f6cd2c50c529a3870b5224..68007689aec336ac02b2ad99e31831adb7b334f2 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pdt_3.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_3.f03
@@ -76,4 +76,5 @@ end module
   end select
 
   deallocate (cz)
+  deallocate (matrix)
 end

diff --git a/gcc/testsuite/gfortran.dg/pdt_47.f03 b/gcc/testsuite/gfortran.dg/pdt_47.f03
new file mode 100644 (file)
index 0000000..f3b77d9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_47.f03
@@ -0,0 +1,50 @@
+! { dg-do run }
+!
+! Test the fix for PR121948, in which the PDT constructor expressions without
+! the type specification list, ie. relying on default values, failed. The fix
+! also required that the incorrect initialization of functions with implicit
+! function result be eliminated.
+!
+! Contributed by Damian Rouson  <damian@archaeologic.codes>
+!
+  implicit none
+
+  integer, parameter :: dp = kind(1d0)
+  real, parameter :: ap = 42.0
+  real(dp), parameter :: ap_d = 42.0d0
+
+  type operands_t(k)
+    integer, kind :: k = kind(1.)
+    real(k) :: actual, expected 
+  end type
+
+  type(operands_t) :: x
+  type(operands_t(dp)) :: y
+
+  x = operands (ap, 10 * ap)
+  if (abs (x%actual - ap) >1e-5) stop 1
+  if (abs (x%expected - 10 * ap) > 1e-5) stop 2
+
+
+  y = operands_dp (ap_d, 10d0 * ap_d)
+  if (abs (y%actual - ap_d) > 1d-10) stop 3
+  if (abs (y%expected - 10d0 * ap_d) > 1d-10) stop 4
+  if (kind (y%actual) /= dp) stop 5
+  if (kind (y%expected) /= dp) stop 6
+
+contains
+
+  function operands(actual, expected)                    ! Use the default 'k'
+    real actual, expected
+    type(operands_t) :: operands
+    operands = operands_t(actual, expected)
+  end function
+
+
+  function operands_dp(actual, expected)                 ! Override the default
+    real(dp) actual, expected
+    type(operands_t(dp)) :: operands_dp
+    operands_dp = operands_t(dp)(actual, expected) 
+  end function
+
+end