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.

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

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;

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

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

gcc/testsuite/gfortran.dg/pdt_3.f03

@@ -76,4 +76,5 @@ end module
   end select
 
   deallocate (cz)
+  deallocate (matrix)
 end

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