https://gcc.gnu.org/g:68700cafd15691802325340d9cf9c1e31ff5abe4
commit r16-3423-g68700cafd15691802325340d9cf9c1e31ff5abe4
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Thu Aug 28 08:10:04 2025 +0100
Fortran: Implement correct form of PDT constructors [PR82205]
2025-08-28 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/82205
* decl.cc (gfc_get_pdt_instance): Copy the default initializer
for components that are not PDT parameters or parameterized. If
any component is a pointer or allocatable set the attributes
'pointer_comp' or 'alloc_comp' of the new PDT instance.
* primary.cc (gfc_match_rvalue): Implement the correct form of
PDT constructors with 'name (type parms)(component values)'.
* trans-array.cc (structure_alloc_comps): Apply scalar default
initializers. Array initializers await the coming change in PDT
representation.
* trans-io.cc (transfer_expr): Do not output the type parms of
a PDT in list directed output.
gcc/testsuite/
PR fortran/82205
* gfortran.dg/pdt_22.f03: Use the correct for PDT constructors.
* gfortran.dg/pdt_23.f03: Likewise.
* gfortran.dg/pdt_3.f03: Likewise.
Diff:
---
gcc/fortran/decl.cc | 17 ++++++++++
gcc/fortran/primary.cc | 61 ++++++++++++++++++++++++++++++++++++
gcc/fortran/trans-array.cc | 10 ++++++
gcc/fortran/trans-io.cc | 3 +-
gcc/testsuite/gfortran.dg/pdt_22.f03 | 11 +++++--
gcc/testsuite/gfortran.dg/pdt_23.f03 | 14 ++++-----
gcc/testsuite/gfortran.dg/pdt_3.f03 | 12 +++----
7 files changed, 111 insertions(+), 17 deletions(-)
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 5146731d454e..1e91b57aa96d 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -3870,6 +3870,8 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list,
gfc_symbol **sym,
bool assumed_seen = false;
bool deferred_seen = false;
bool spec_error = false;
+ bool alloc_seen = false;
+ bool ptr_seen = false;
int kind_value, i;
gfc_expr *kind_expr;
gfc_component *c1, *c2;
@@ -4201,6 +4203,12 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list,
gfc_symbol **sym,
if (c1->ts.type == BT_CLASS)
CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
+ if (c1->attr.allocatable)
+ alloc_seen = true;
+
+ if (c1->attr.pointer)
+ ptr_seen = true;
+
/* Determine if an array spec is parameterized. If so, substitute
in the parameter expressions for the bounds and set the pdt_array
attribute. Notice that this attribute must be unconditionally set
@@ -4271,8 +4279,17 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list,
gfc_symbol **sym,
if (c2->attr.allocatable)
instance->attr.alloc_comp = 1;
}
+ else if (!(c2->attr.pdt_kind || c2->attr.pdt_len || c2->attr.pdt_string
+ || c2->attr.pdt_array) && c1->initializer)
+ c2->initializer = gfc_copy_expr (c1->initializer);
}
+ if (alloc_seen)
+ instance->attr.alloc_comp = 1;
+ if (ptr_seen)
+ instance->attr.pointer_comp = 1;
+
+
gfc_commit_symbol (instance);
if (ext_param_list)
*ext_param_list = type_param_spec_list;
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index f0e1fef6812e..6df95558bb15 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -4055,6 +4055,67 @@ gfc_match_rvalue (gfc_expr **result)
break;
}
+ /* 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)
+ {
+ gfc_symtree *pdt_st;
+ gfc_symbol *pdt_sym;
+ gfc_actual_arglist *ctr_arglist, *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)
+ {
+ pdt_sym = pdt_st->n.sym;
+
+ /* Generate this instance using the type parameters from the
+ first argument list and return the parameter list in
+ ctr_arglist. */
+ m = gfc_get_pdt_instance (actual_arglist, &pdt_sym, &ctr_arglist);
+ if (m != MATCH_YES)
+ {
+ m = MATCH_ERROR;
+ break;
+ }
+ /* Now match the component_values. */
+ 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
+ list can be safely appended to the type parameters. */
+ tmp = actual_arglist;
+ for (c = pdt_sym->components; c && tmp; c = c->next)
+ {
+ if (c->attr.pdt_kind || c->attr.pdt_len)
+ continue;
+ tmp->name = c->name;
+ 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;
+
+ /* Do the appending. */
+ for (tmp = ctr_arglist; tmp && tmp->next;)
+ tmp = tmp->next;
+ tmp->next = actual_arglist;
+ actual_arglist = ctr_arglist;
+ }
+ }
+
gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
sym = symtree->n.sym;
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7e6437bbdf7e..193bac512402 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -10896,6 +10896,16 @@ structure_alloc_comps (gfc_symbol * der_type, tree
decl, tree dest,
gfc_add_modify (&fnblock, comp, tse.expr);
}
}
+ else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array
+ && !c->as && !(c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.pdt_type)) /* Take
care of arrays. */
+ {
+ gfc_se tse;
+ gfc_expr *c_expr;
+ c_expr = c->initializer;
+ gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp));
+ gfc_add_modify (&fnblock, comp, tse.expr);
+ }
if (c->attr.pdt_string)
{
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index 824f232988c2..df2fef70172a 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2499,7 +2499,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree
addr_expr,
for (c = ts->u.derived->components; c; c = c->next)
{
/* Ignore hidden string lengths. */
- if (c->name[0] == '_')
+ if (c->name[0] == '_'
+ || c->attr.pdt_kind || c->attr.pdt_len)
continue;
field = c->backend_decl;
diff --git a/gcc/testsuite/gfortran.dg/pdt_22.f03
b/gcc/testsuite/gfortran.dg/pdt_22.f03
index 929f398635d8..23feb8c84c70 100644
--- a/gcc/testsuite/gfortran.dg/pdt_22.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_22.f03
@@ -8,9 +8,10 @@
!
program p
character(120) :: buffer
- integer :: i(4)
+ integer :: i(3)
type t(a)
integer, len :: a
+ integer :: z = 4
end type
type t2(b)
integer, len :: b
@@ -18,6 +19,10 @@ program p
end type
type(t2(3)) :: x
write (buffer,*) x
- read (buffer,*) i
- if (any (i .ne. [3,1,1,1])) STOP 1
+ read (buffer, *) i
+ if (any (i .ne. [4,4,4])) stop 1
+ x%r = [t(1)(3),t(1)(2),t(1)(1)]
+ write (buffer,*) x
+ read (buffer, *) i
+ if (any (i .ne. [3,2,1])) stop 2
end
diff --git a/gcc/testsuite/gfortran.dg/pdt_23.f03
b/gcc/testsuite/gfortran.dg/pdt_23.f03
index b2156b9ce6ee..c0cec9afe0fe 100644
--- a/gcc/testsuite/gfortran.dg/pdt_23.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_23.f03
@@ -15,19 +15,19 @@ program p
type(t(:)), allocatable :: x
allocate (t(2) :: x)
- x = t(2,'ab')
+ x = t(2)('ab')
write (buffer, *) x%c ! Tests the fix for PR82720
read (buffer, *) chr
if (trim (chr) .ne. 'ab') STOP 1
- x = t(3,'xyz')
+ x = t(3)('xyz')
if (len (x%c) .ne. 3) STOP 2
- write (buffer, *) x ! Tests the fix for PR82719
- read (buffer, *) i, chr
- if (i .ne. 3) STOP 3
+ write (buffer, *) x ! Tests the fix for PR82719. PDT IO was incorrect
(PRs 84143/84432).
+ read (buffer, *) chr
+! if (i .ne. 3) STOP 3
if (chr .ne. 'xyz') STOP 4
- buffer = " 3 lmn"
- read (buffer, *) x ! Some thought will be needed for PDT reads.
+ buffer = "lmn"
+ read (buffer, *) x ! PDT IO was incorrect (PRs 84143/84432).
if (x%c .ne. 'lmn') STOP 5
end
diff --git a/gcc/testsuite/gfortran.dg/pdt_3.f03
b/gcc/testsuite/gfortran.dg/pdt_3.f03
index e364eeae6dfc..cd48364b1534 100644
--- a/gcc/testsuite/gfortran.dg/pdt_3.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_3.f03
@@ -5,7 +5,7 @@
module vars
integer :: d_dim = 4
integer :: mat_dim = 256
- integer, parameter :: ftype = kind(0.0d0)
+ integer, parameter :: ftype = kind(0.0)
end module
use vars
@@ -34,7 +34,7 @@ end module
real, allocatable :: matrix (:,:)
type(thytype(ftype, 4, 4)) :: w
- type(x(8,4,256)) :: q
+ type(x(ftype,ftype,256)) :: q
class(mytype(ftype, :)), allocatable :: cz
w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim])
@@ -57,21 +57,21 @@ end module
matrix = w%d
! TODO - for some reason, using w%d directly in the source causes a seg fault.
- allocate (cz, source = mytype(ftype, d_dim, 0, matrix))
+ allocate (cz, source = mytype(ftype, d_dim)( 0, matrix))
select type (cz)
type is (mytype(ftype, *))
if (int (sum (cz%d)) .ne. 136) STOP 11
- type is (thytype(ftype, *, 8))
+ type is (thytype(ftype, *, ftype))
STOP 12
end select
deallocate (cz)
- allocate (thytype(ftype, d_dim*2, 8) :: cz)
+ allocate (thytype(ftype, d_dim*2, ftype) :: cz)
cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b])
select type (cz)
type is (mytype(ftype, *))
STOP 13
- type is (thytype(ftype, *, 8))
+ type is (thytype(ftype, *, ftype))
if (int (sum (cz%d)) .ne. 20800) STOP 14
end select
