This patch corrects the form of PDT constructors so that they are standard conforming:
structure-constructor is type-name [ ( type-param-spec-list ) ] ( [ component-spec-list ] ) At present, the type-param-spec-list for PDTs is rolled into the component-spec-list. The patch separates the type-param-spec-list in the chunk in primary.cc. The chunks in decl.cc and trans-array.cc implement default initialization for PDT components that are not type parameters or parameterized components. Array component default initialization will await the change of PDT representation needed to fix PR82649. This change requires some experimentation as to how best to do it but is high on my TODO list. Finally, the chunk in trans-io.cc suppresses the output of type parameters. The changes needed in pdt_22.f03, pdt_23.f03 and pdt_03.f03 are sufficient but the testcase in the PR does now compile and run correctly. With the patch applied, gfortran behaves in the same way as the other brands and regtests on FC42/x86_64. OK for mainline? Regards Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 5146731d454..1e91b57aa96 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 f0e1fef6812..3cffb43783f 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 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 using 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 7e6437bbdf7..193bac51240 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 824f232988c..df2fef70172 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 929f398635d..23feb8c84c7 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 b2156b9ce6e..c0cec9afe0f 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 e364eeae6df..cd48364b153 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
