https://gcc.gnu.org/g:9713ce4f550fdbc3bf23132bc208831a8d71d862
commit r17-4394-g9713ce4f550fdbc3bf23132bc208831a8d71d862 Author: Paul Thomas <[email protected]> Date: Wed Sep 16 16:50:27 2026 +0100 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. * trans-io.cc (gfc_trans_transfer): PDT string arrays must be scalarized. gcc/testsuite PR fortran/125690 * gfortran.dg/pdt_95.f03: New test. Diff: --- 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(-) diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 3eb660a93d47..01b6109940c5 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -4591,6 +4591,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 3a747aa5512b..60c5610bba45 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 3e3e88012efd..bbd50aa2ab47 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 94a782f3af76..48fdaa5e7335 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 000000000000..da3b2f128043 --- /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
