Hi All, The recent change of PDT constructors to allow "structure-constructor is type-name [ ( type-param-spec-list ) ]( [ component-spec-list ] )" missed the possibility that the (type-param-spec-list) is optional, if default values are available. This patch permits this by looking for a left hand bracket after the first list has been read. If present, the full constructor is used. Otherwise, the actual arglist is tried as the type_param_spec_list. If this does not match, a NULL type-parameter-spec-list is used and gfc_get_pdt_instance will return an error if any default values are missing.
The chunk in resolve.cc removes the default initialization of the function itself, rather than the result, for the case of PDT functions with an implicit result. pdt_33.f03 needed a bit of a white space tidy up and the missed deallocation in pdt_3.f03 was noted in the course of working up this fix. Unfortunately, pdt_3.f03 still leaks memory (PR121972). Regtests with FC42/x86_64. OK for mainline? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 9fe697cd549..99644939056 100644
--- 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 2cb930d83b8..638018bcce3 100644
--- 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 b83961fe6f1..daff3b3e33b 100644
--- 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/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index f423dd728aa..a7762010d88 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4831,7 +4831,6 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
}
-
/* Initialize the INTENT(OUT) derived type dummy arguments. This
should be done here so that the offsets and lbounds of arrays
are available. */
diff --git a/gcc/testsuite/gfortran.dg/pdt_17.f03 b/gcc/testsuite/gfortran.dg/pdt_17.f03
index 1b0a30dca4c..d03e2d139a0 100644
--- 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 cd48364b153..68007689aec 100644
--- 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_33.f03 b/gcc/testsuite/gfortran.dg/pdt_33.f03
index 3b2fe72431d..48f21047983 100644
--- a/gcc/testsuite/gfortran.dg/pdt_33.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_33.f03
@@ -10,8 +10,8 @@ program pr102003
character(len=n) :: c
end type pdt
type(pdt(42)) :: p
- integer, parameter :: m = len (p% c)
- integer, parameter :: lm = p% c% len
+ integer, parameter :: m = len (p%c)
+ integer, parameter :: lm = p%c%len
if (m /= 42) stop 1
if (len (p% c) /= 42) stop 2
diff --git a/gcc/testsuite/gfortran.dg/pdt_47.f03 b/gcc/testsuite/gfortran.dg/pdt_47.f03
new file mode 100644
index 00000000000..f3b77d9555f
--- /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
