Hello All, The fix for this PR turned into a catch-all for parameterized string components:
Apart from the third chunk, the patch recognises fully that pdt_strings are represented by descriptors. The third chunk corrects an incorrect fail, when gfc_dep_compare_expr returns -3 for unlike variables. This is overly restrictive and should be subject to a runtime check. The test, pdt_95.f03, grew like Topsy but clearly identifies the original report from wrinkles that have been fixed. It passes regression testing on FC44/x86_64 - OK for mainline and after a decent interval, 16-branch? Regards Paul
From 7bf41a50b6493cf0ce339982cc7e2a18e3f0a6fe Mon Sep 17 00:00:00 2001 From: Paul Thomas <[email protected]> Date: Wed, 16 Sep 2026 16:50:27 +0100 Subject: [PATCH] Fortran: Fix a number of issues with parameterized strings [PR125690] 2026-09-16 Paul Thomas <[email protected]> gcc/fortran PR fortran/125690 * decl.cc (gfc_get_pdt_instance): PDT strings with explicit array specifications are also PDT arrays. If the component is allocatable, the typespec must be marked deferred. * resolve.cc (resolve_structure_cons): Skip the string length check for PDT types. (resolve_allocate_expr): Initialize cmp to 0. Do not emit error if cmp = -3 since different variable could have the same value. * trans-array.cc (gfc_conv_scalarized_array_ref): Force pointer arithmetic by setting 'decl' for PDT strings. (gfc_conv_array_ref): Likewise. (structure_alloc_comps ): Move the declaraion of 'strlen' up. Evaluate the bounds and offset for pdt_strings as well as pdt arrays. If non-null, use strlen to obtain the size for malloc. Set the span to strlen. If the component type is a descriptor, rather than just a PDT array, use its data forboth the non-null condition and setting to null. * tran-io.cc (gfc_trans_transfer): PDT string arrays must be scalarized. gcc/testsuite PR fortran/125690 * gfortran.dg/pdt_95.f03: New test. --- gcc/fortran/decl.cc | 4 + gcc/fortran/resolve.cc | 8 +- gcc/fortran/trans-array.cc | 41 ++++--- gcc/fortran/trans-io.cc | 3 + gcc/testsuite/gfortran.dg/pdt_95.f03 | 170 +++++++++++++++++++++++++++ 5 files changed, 206 insertions(+), 20 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pdt_95.f03 diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 4871737458e..8bf6a8ecc52 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -4586,6 +4586,10 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, gfc_free_expr (e); if (c2->ts.u.cl->length->expr_type != EXPR_CONSTANT) c2->attr.pdt_string = 1; + if (c1->as && c1->as->type == AS_EXPLICIT) + c2->attr.pdt_array = 1; + else if (c1->attr.allocatable) + c2->ts.deferred = 1; } /* Recurse into this function for PDT components. */ diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 3a747aa5512..60c5610bba4 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -1435,8 +1435,8 @@ resolve_structure_cons (gfc_expr *expr, int init) /* For strings, the length of the constructor should be the same as the one of the structure, ensure this if the lengths are known at compile time and when we are dealing with PARAMETER or structure - constructors. */ - if (cons->expr->ts.type == BT_CHARACTER + constructors. Skip for PDT types which have type parameters. */ + if (!IS_PDT (expr) && cons->expr->ts.type == BT_CHARACTER && comp->ts.type == BT_CHARACTER && comp->ts.u.cl && comp->ts.u.cl->length && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT @@ -9531,14 +9531,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred && !UNLIMITED_POLY (e)) { - int cmp; + int cmp = 0; if (!e->ts.u.cl->length) goto failure; cmp = gfc_dep_compare_expr (e->ts.u.cl->length, code->ext.alloc.ts.u.cl->length); - if (cmp == 1 || cmp == -1 || cmp == -3) + if (cmp == 1 || cmp == -1) { gfc_error ("Allocating %s at %L with type-spec requires the same " "character-length parameter as in the declaration", diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 3e3e88012ef..bbd50aa2ab4 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -4064,8 +4064,9 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar, the descriptor, mark the resulting variable decl and pass it to gfc_build_array_ref. */ if (span_addressed_array (info->descriptor) - || (expr && expr->ts.deferred && info->descriptor - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))) + || (expr && ((expr->ts.deferred && info->descriptor + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))) + || (expr && gfc_expr_attr (expr).pdt_string)))) { if (TREE_CODE (info->descriptor) == COMPONENT_REF) decl = info->descriptor; @@ -4325,16 +4326,14 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, } else if (expr->ts.deferred || (sym->ts.type == BT_CHARACTER - && sym->attr.select_type_temporary)) + && sym->attr.select_type_temporary) + || (expr->ts.type == BT_CHARACTER + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)) + && gfc_expr_attr (expr).pdt_string)) { - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) - { - decl = se->expr; - if (INDIRECT_REF_P (decl)) - decl = TREE_OPERAND (decl, 0); - } - else - decl = sym->backend_decl; + decl = se->expr; + if (INDIRECT_REF_P (decl)) + decl = TREE_OPERAND (decl, 0); } else if (sym->ts.type == BT_CLASS) { @@ -10276,6 +10275,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, bool inside_wrapper = generating_copy_helper; bool is_pdt_type = IS_PDT (c); + tree strlen = NULL_TREE; cdecl = c->backend_decl; ctype = TREE_TYPE (cdecl); @@ -10699,7 +10699,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, else gfc_add_modify (&fnblock, comp, build_int_cst (TREE_TYPE (comp), 0)); - if (gfc_deferred_strlen (c, &comp)) + if (!c->attr.pdt_string && gfc_deferred_strlen (c, &comp)) { comp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (comp), @@ -11106,7 +11106,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, { gfc_se tse; gfc_init_se (&tse, NULL); - tree strlen = NULL_TREE; gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length); /* Convert the parameterized string length to its value. The string length is stored in a hidden field in the same way as @@ -11145,7 +11144,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, if (c->ts.type == BT_CLASS) comp = gfc_class_data_get (comp); - if (c->attr.pdt_array) + if (c->attr.pdt_array + || (c->attr.pdt_string + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))) { gfc_se tse; int i; @@ -11208,6 +11209,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, tmp = build_fold_indirect_ref_loc (input_location, tmp); tmp = gfc_vptr_size_get (tmp); } + else if (strlen != NULL_TREE) + tmp = strlen; else tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype)); tmp = fold_convert (gfc_array_index_type, tmp); @@ -11218,6 +11221,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, gfc_conv_descriptor_data_set (&fnblock, comp, tmp); gfc_conv_descriptor_dtype_set (&fnblock, comp, gfc_get_dtype (ctype)); + if (strlen != NULL_TREE) + { + tmp = gfc_conv_descriptor_elem_len_get (comp); + gfc_add_modify (&fnblock, tmp, fold_convert (TREE_TYPE (tmp), strlen)); + gfc_conv_descriptor_span_set (&fnblock, comp, strlen); + } if (c->initializer && c->initializer->rank) { @@ -11280,7 +11289,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, if (c->attr.pdt_array || c->attr.pdt_string) { tmp = comp; - if (c->attr.pdt_array) + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) tmp = gfc_conv_descriptor_data_get (comp); null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, @@ -11316,7 +11325,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, build_empty_stmt (input_location)); gfc_add_expr_to_block (&fnblock, tmp); - if (c->attr.pdt_array) + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); else { diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc index 94a782f3af7..48fdaa5e733 100644 --- a/gcc/fortran/trans-io.cc +++ b/gcc/fortran/trans-io.cc @@ -2655,6 +2655,9 @@ gfc_trans_transfer (gfc_code * code) && gfc_expr_attr (expr).target))) goto scalarize; + if (gfc_expr_attr (expr).pdt_string) + goto scalarize; + /* With array-bounds checking enabled, force scalarization in some situations, e.g., when an array index depends on a function evaluation or an expression and possibly has side-effects. */ diff --git a/gcc/testsuite/gfortran.dg/pdt_95.f03 b/gcc/testsuite/gfortran.dg/pdt_95.f03 new file mode 100644 index 00000000000..da3b2f12804 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_95.f03 @@ -0,0 +1,170 @@ +! { dg-do run } +! +! Test the fix for PR125690, where an ICE occurred on deallocating the +! PDT string components. +! +! Contributed by David Binderman <[email protected]> +! and Paul Thomas <[email protected]> for tests in comment #5. +! +module m + integer, parameter :: def_kind = selected_char_kind('ascii') + integer, parameter :: unicode_kind = selected_char_kind('ISO_10646') + character(kind = unicode_kind,len = 7) :: cc1(5) = ['a','b','c','d','e'] + character(kind = def_kind, len = 5) :: str(3) = ['abcde','fghij','klmno'] +end module + +module m5 +! Declarations for comment #5 + type ux(l,m) + integer, len :: l,m + character(len=l) :: x(m) + integer :: tag + end type + type uy(l) + integer, len :: l + character(len=l) :: x(3) + integer :: tag + end type + type uz(l) + integer, len :: l + character(len=l), allocatable :: x(:) + integer :: tag + end type + integer :: n = 5 +end module + +program p + use m + use m5 + call sub1(cc1) ! Check ascii kind + call sub2(cc1) ! Check unicode kind +! Tests from comment #5 + block + type(uy(n)) :: obj + obj%tag = 42 + obj%x(1) = 'aaaaa' + obj%x(2) = 'bbbbb' + obj%x(3) = 'ccccc' + if (len(obj%x) /= 5) stop 101 + if (size(obj%x) /= 3) stop 102 + if (obj%x(1) /= 'aaaaa') stop 103 + if (obj%x(2) /= 'bbbbb') stop 104 + if (obj%x(3) /= 'ccccc') stop 105 + if (obj%tag /= 42) stop 106 + end block + call foo(n) + call bar(n,3) + call foobar(n) +contains + subroutine sub1(cc1) + character(kind = 4,len = 7)::cc1(5) + Type ty(k1) + Integer,kind :: k1 + character(kind= k1,len = len(cc1)+k1) :: ch(len(cc1)-5) + character(kind= k1,len = 2+len(cc1)+k1) :: c(len(cc1)*5) + character(kind= k1,len = kind(cc1)+k1) :: ch1(len(cc1)) + character(kind= k1,len = kind(cc1)+2) :: c2(kind(cc1)) + character(kind= k1,len = len(cc1)+2) :: ch2(kind(cc1)) + End type + Type(ty(def_kind)) :: obj + if(len(obj%ch) .ne. len(cc1) + def_kind) stop 1 + if(len(obj%c) .ne. 2 + len(cc1) + def_kind) stop 2 + if(len(obj%ch1) .ne. kind(cc1) + def_kind) stop 3 + if(len(obj%c2) .ne. 6) stop 4 + if(len(obj%ch2) .ne. 9) stop 5 + if(ubound(obj%ch,1) .ne. 2) stop 6 + if(ubound(obj%ch1,1) .ne. 7) stop 7 + if(ubound(obj%c,1) .ne. 35) stop 8 + if(ubound(obj%ch2,1) .ne. 4) stop 9 + if(ubound(obj%c2,1) .ne. 4) stop 10 + end subroutine + subroutine sub2(cc1) + character(kind = 4,len = 7)::cc1(5) + Type ty(k1) + Integer,kind :: k1 + character(kind= k1,len = len(cc1)+k1) :: ch(len(cc1)-5) + character(kind= k1,len = 2+len(cc1)+k1) :: c(len(cc1)*5) + character(kind= k1,len = kind(cc1)+k1) :: ch1(len(cc1)) + character(kind= k1,len = kind(cc1)+2) :: c2(kind(cc1)) + character(kind= k1,len = len(cc1)+2) :: ch2(kind(cc1)) + End type + Type(ty(unicode_kind)) :: obj + if(len(obj%ch) .ne. len(cc1) + unicode_kind) stop 11 + if(len(obj%c) .ne. 2 + len(cc1) + unicode_kind) stop 12 + if(len(obj%ch1) .ne. kind(cc1) + unicode_kind) stop 13 + if(len(obj%c2) .ne. 6) stop 14 + if(len(obj%ch2) .ne. 9) stop 15 + if(ubound(obj%ch,1) .ne. 2) stop 16 + if(ubound(obj%ch1,1) .ne. 7) stop 17 + if(ubound(obj%c,1) .ne. 35) stop 18 + if(ubound(obj%ch2,1) .ne. 4) stop 19 + if(ubound(obj%c2,1) .ne. 4) stop 20 + end subroutine + +! Comment #5 tests + subroutine foo(i) + integer :: i + character(kind = def_kind, len = 3 * i) :: buffer + type(uy(i)) :: obj + obj%tag = 42 + obj%x(1) = 'aaaaa' + obj%x(2) = 'bbbbb' + obj%x(3) = 'ccccc' + if (len(obj%x) /= 5) stop 111 + if (size(obj%x) /= 3) stop 112 + if (obj%x(1) /= 'aaaaa') stop 113 + if (obj%x(2) /= 'bbbbb') stop 114 + if (obj%x(3) /= 'ccccc') stop 115 + if (obj%tag /= 42) stop 116 +! It was noticed, while verifying the patch for this PR, that these PDT string +! components were not scalarizing correctly nor were they transferring to IO. + obj%x = str + if (any (obj%x /= str)) stop 117 + write (buffer, '(3a5)') obj%x + if (buffer /= 'abcdefghijklmno') stop 118 + end + subroutine bar(i,j) + integer :: i, j + character(kind = def_kind, len = j * i) :: buffer + type(ux(i, j)) :: obj + obj%tag = 42 + obj%x(1) = 'aaaaa' + obj%x(2) = 'bbbbb' + obj%x(3) = 'ccccc' + if (len(obj%x) /= 5) stop 121 + if (size(obj%x) /= 3) stop 122 + if (obj%x(1) /= 'aaaaa') stop 123 + if (obj%x(2) /= 'bbbbb') stop 124 + if (obj%x(3) /= 'ccccc') stop 125 + if (obj%tag /= 42) stop 126 +! It was noticed, while verifying the patch for this PR, that these PDT string +! components were not scalarizing correctly nor were they transferring to IO. + obj%x = str + if (any (obj%x /= str)) stop 127 + write (buffer, '(3a5)') obj%x + if (buffer /= 'abcdefghijklmno') stop 128 + end + subroutine foobar(i) + integer :: i + character(kind = def_kind, len = 3 * i) :: buffer +! Note that, with the present patch, the declaration produces +! obj.x.data = 0B; twice because it is allocatable and a PDT string. + type(uz(i)) :: obj + allocate (character(len=i) :: obj%x(3)) + obj%tag = 42 + obj%x(1) = 'aaaaa' + obj%x(2) = 'bbbbb' + obj%x(3) = 'ccccc' + if (len(obj%x) /= 5) stop 131 + if (size(obj%x) /= 3) stop 132 + if (obj%x(1) /= 'aaaaa') stop 133 + if (obj%x(2) /= 'bbbbb') stop 134 + if (obj%x(3) /= 'ccccc') stop 135 + if (obj%tag /= 42) stop 136 + obj%x = str +! Allocatable pdt_string components were OK for scalariztion and IO. + if (any (obj%x /= str)) stop 137 + write (buffer, '(3a5)') obj%x + if (buffer /= 'abcdefghijklmno') stop 138 + end +End -- 2.55.0
