diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 051c6ede82c..5ad05ce6e7f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,45 @@ +2016-01-15 Paul Thomas + + PR fortran/64324 + * resolve.c (check_uop_procedure): Prevent deferred length + characters from being trapped by assumed length error. + + PR fortran/49630 + PR fortran/54070 + PR fortran/60593 + PR fortran/60795 + PR fortran/61147 + PR fortran/64324 + * trans-array.c (gfc_conv_scalarized_array_ref): Pass decl for + function as well as variable expressions. + (gfc_array_init_size): Add 'expr' as an argument. Use this to + correctly set the descriptor dtype for deferred characters. + (gfc_array_allocate): Add 'expr' to the call to + 'gfc_array_init_size'. + * trans.c (gfc_build_array_ref): Expand logic for setting span + to include indirect references to character lengths. + * trans-decl.c (gfc_get_symbol_decl): Ensure that deferred + result char lengths that are PARM_DECLs are indirectly + referenced both for directly passed and by reference. + (create_function_arglist): If the length type is a pointer type + then store the length as the 'passed_length' and make the char + length an indirect reference to it. + (gfc_trans_deferred_vars): If a character length has escaped + being set as an indirect reference, return it via the 'passed + length'. + * trans-expr.c (gfc_conv_procedure_call): The length of + deferred character length results is set TREE_STATIC and set to + zero. + (gfc_trans_assignment_1): Do not fix the rse string_length if + it is a variable, a parameter or an indirect reference. Add the + code to trap assignment of scalars to unallocated arrays. + * trans-stmt.c (gfc_trans_allocate): Remove 'def_str_len' and + all references to it. Instead, replicate the code to obtain a + explicitly defined string length and provide a value before + array allocation so that the dtype is correctly set. + trans-types.c (gfc_get_character_type): If the character length + is a pointer, use the indirect reference. + 2016-01-10 Thomas Koenig PR fortran/69154 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2c839f94df8..64d59ceef17 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -15320,9 +15320,9 @@ check_uop_procedure (gfc_symbol *sym, locus where) } if (sym->ts.type == BT_CHARACTER - && !(sym->ts.u.cl && sym->ts.u.cl->length) - && !(sym->result && sym->result->ts.u.cl - && sym->result->ts.u.cl->length)) + && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred) + && !(sym->result && ((sym->result->ts.u.cl + && sym->result->ts.u.cl->length) || sym->result->ts.deferred))) { gfc_error ("User operator procedure %qs at %L cannot be assumed " "character length", sym->name, &where); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index a46f1034777..eeb688c9b91 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3165,7 +3165,8 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) index, info->offset); if (expr && (is_subref_array (expr) - || (expr->ts.deferred && expr->expr_type == EXPR_VARIABLE))) + || (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE + || expr->expr_type == EXPR_FUNCTION)))) decl = expr->symtree->n.sym->backend_decl; tmp = build_fold_indirect_ref_loc (input_location, info->data); @@ -5038,7 +5039,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, stmtblock_t * descriptor_block, tree * overflow, tree expr3_elem_size, tree *nelems, gfc_expr *expr3, - tree expr3_desc, bool e3_is_array_constr) + tree expr3_desc, bool e3_is_array_constr, gfc_expr *expr) { tree type; tree tmp; @@ -5063,8 +5064,19 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, offset = gfc_index_zero_node; /* Set the dtype. */ - tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (type)); + if (expr->ts.type == BT_CHARACTER && expr->ts.deferred + && TREE_CODE (expr->ts.u.cl->backend_decl) == VAR_DECL) + { + type = gfc_typenode_for_spec (&expr->ts); + tmp = gfc_conv_descriptor_dtype (descriptor); + gfc_add_modify (descriptor_block, tmp, + gfc_get_dtype_rank_type (rank, type)); + } + else + { + tmp = gfc_conv_descriptor_dtype (descriptor); + gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (type)); + } or_expr = boolean_false_node; @@ -5446,7 +5458,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, ref->u.ar.as->corank, &offset, lower, upper, &se->pre, &set_descriptor_block, &overflow, expr3_elem_size, nelems, expr3, e3_arr_desc, - e3_is_array_constr); + e3_is_array_constr, expr); if (dimension) { diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 929cbda14f9..a0305a69706 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1377,8 +1377,8 @@ gfc_get_symbol_decl (gfc_symbol * sym) && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL) { sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; - sym->ts.u.cl->backend_decl = NULL_TREE; - length = gfc_create_string_length (sym); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length))); + sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl); } fun_or_res = byref && (sym->attr.result @@ -1420,9 +1420,12 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* We need to insert a indirect ref for param decls. */ if (sym->ts.u.cl->backend_decl && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL) + { + sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl); } + } /* For all other parameters make sure, that they are copied so that the value and any modifications are local to the routine by generating a temporary variable. */ @@ -1431,6 +1434,10 @@ gfc_get_symbol_decl (gfc_symbol * sym) && sym->ts.u.cl->backend_decl) { sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; + if (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length))) + sym->ts.u.cl->backend_decl + = build_fold_indirect_ref (sym->ts.u.cl->backend_decl); + else sym->ts.u.cl->backend_decl = NULL_TREE; } } @@ -2264,6 +2271,13 @@ create_function_arglist (gfc_symbol * sym) type = gfc_sym_type (arg); arg->backend_decl = backend_decl; type = build_reference_type (type); + + if (POINTER_TYPE_P (len_type)) + { + sym->ts.u.cl->passed_length = length; + sym->ts.u.cl->backend_decl = + build_fold_indirect_ref_loc (input_location, length); + } } } @@ -2347,7 +2361,10 @@ create_function_arglist (gfc_symbol * sym) if (f->sym->ts.u.cl->backend_decl == NULL || f->sym->ts.u.cl->backend_decl == length) { - if (f->sym->ts.u.cl->backend_decl == NULL) + if (POINTER_TYPE_P (len_type)) + f->sym->ts.u.cl->backend_decl = + build_fold_indirect_ref_loc (input_location, length); + else if (f->sym->ts.u.cl->backend_decl == NULL) gfc_create_string_length (f->sym); /* Make sure PARM_DECL type doesn't point to incomplete type. */ @@ -3975,12 +3992,19 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_restore_backend_locus (&loc); /* Pass back the string length on exit. */ + tmp = proc_sym->ts.u.cl->backend_decl; + if (TREE_CODE (tmp) != INDIRECT_REF) + { tmp = proc_sym->ts.u.cl->passed_length; tmp = build_fold_indirect_ref_loc (input_location, tmp); tmp = fold_convert (gfc_charlen_type_node, tmp); tmp = fold_build2_loc (input_location, MODIFY_EXPR, gfc_charlen_type_node, tmp, proc_sym->ts.u.cl->backend_decl); + } + else + tmp = NULL_TREE; + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); } else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1a6b7344877..863e2aab878 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5942,6 +5942,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = len; if (TREE_CODE (tmp) != VAR_DECL) tmp = gfc_evaluate_now (len, &se->pre); + TREE_STATIC (tmp) = 1; + gfc_add_modify (&se->pre, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); tmp = gfc_build_addr_expr (NULL_TREE, tmp); vec_safe_push (retargs, tmp); } @@ -9263,7 +9266,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, } /* Stabilize a string length for temporaries. */ - if (expr2->ts.type == BT_CHARACTER && !expr2->ts.deferred) + if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred + && !(TREE_CODE (rse.string_length) == VAR_DECL + || TREE_CODE (rse.string_length) == PARM_DECL + || TREE_CODE (rse.string_length) == INDIRECT_REF)) string_length = gfc_evaluate_now (rse.string_length, &rse.pre); else if (expr2->ts.type == BT_CHARACTER) string_length = rse.string_length; @@ -9277,7 +9283,32 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, lse.string_length = string_length; } else + { gfc_conv_expr (&lse, expr1); + if (gfc_option.rtcheck & GFC_RTCHECK_MEM + && gfc_expr_attr (expr1).allocatable + && expr1->rank + && !expr2->rank) + { + tree cond; + const char* msg; + + tmp = expr1->symtree->n.sym->backend_decl; + if (POINTER_TYPE_P (TREE_TYPE (tmp))) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_conv_descriptor_data_get (tmp); + else + tmp = TREE_OPERAND (lse.expr, 0); + + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), 0)); + msg = _("Assignment of scalar to unallocated array"); + gfc_trans_runtime_check (true, false, cond, &loop.pre, + &expr1->where, msg); + } + } /* Assignments of scalar derived types with allocatable components to arrays must be done with a deep copy and the rhs temporary diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 70a61cc5c86..310d2cdb917 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1437,7 +1437,7 @@ gfc_trans_critical (gfc_code *code) tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); ASM_VOLATILE_P (tmp) = 1; - + gfc_add_expr_to_block (&block, tmp); } @@ -5298,7 +5298,6 @@ gfc_trans_allocate (gfc_code * code) tree label_finish; tree memsz; tree al_vptr, al_len; - tree def_str_len = NULL_TREE; /* If an expr3 is present, then store the tree for accessing its _vptr, and _len components in the variables, respectively. The element size, i.e. _vptr%size, is stored in expr3_esize. Any of @@ -5688,7 +5687,6 @@ gfc_trans_allocate (gfc_code * code) expr3_esize = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (se_sz.expr), tmp, se_sz.expr); - def_str_len = gfc_evaluate_now (se_sz.expr, &block); } } @@ -5741,16 +5739,6 @@ gfc_trans_allocate (gfc_code * code) se.want_pointer = 1; se.descriptor_only = 1; - if (expr->ts.type == BT_CHARACTER - && expr->ts.deferred - && TREE_CODE (expr->ts.u.cl->backend_decl) == VAR_DECL - && def_str_len != NULL_TREE) - { - tmp = expr->ts.u.cl->backend_decl; - gfc_add_modify (&block, tmp, - fold_convert (TREE_TYPE (tmp), def_str_len)); - } - gfc_conv_expr (&se, expr); if (expr->ts.type == BT_CHARACTER && expr->ts.deferred) /* se.string_length now stores the .string_length variable of expr @@ -5888,6 +5876,20 @@ gfc_trans_allocate (gfc_code * code) /* Prevent setting the length twice. */ al_len_needs_set = false; } + else if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE + && code->ext.alloc.ts.u.cl->length) + { + /* Cover the cases where a string length is explicitly + specified by a type spec for deferred length character + arrays or unlimited polymorphic objects without a + source= or mold= expression. */ + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); + gfc_add_modify (&block, al_len, + fold_convert (TREE_TYPE (al_len), + se_sz.expr)); + al_len_needs_set = false; + } } gfc_add_block_to_block (&block, &se.pre); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 12cce4d5955..f3d084194de 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1045,6 +1045,8 @@ gfc_get_character_type (int kind, gfc_charlen * cl) tree len; len = (cl == NULL) ? NULL_TREE : cl->backend_decl; + if (len && POINTER_TYPE_P (TREE_TYPE (len))) + len = build_fold_indirect_ref (len); return gfc_get_character_type_len (kind, len); } diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 44b85e855fe..e71430baeb8 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -335,10 +335,13 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) references. */ if (type && TREE_CODE (type) == ARRAY_TYPE && TYPE_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE - && TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == VAR_DECL + && (TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == VAR_DECL + || TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF) && decl - && DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type))) - == DECL_CONTEXT (decl)) + && (TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF + || TREE_CODE (decl) == FUNCTION_DECL + || DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type))) + == DECL_CONTEXT (decl))) span = TYPE_MAXVAL (TYPE_DOMAIN (type)); else span = NULL_TREE; @@ -354,7 +357,8 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) and reference the element with pointer arithmetic. */ if ((decl && (TREE_CODE (decl) == FIELD_DECL || TREE_CODE (decl) == VAR_DECL - || TREE_CODE (decl) == PARM_DECL) + || TREE_CODE (decl) == PARM_DECL + || TREE_CODE (decl) == FUNCTION_DECL) && ((GFC_DECL_SUBREF_ARRAY_P (decl) && !integer_zerop (GFC_DECL_SPAN (decl))) || GFC_DECL_CLASS (decl) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0a4e6e737bc..29291a2012b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,25 @@ +2016-01-15 Paul Thomas + + PR fortran/49630 + * gfortran.dg/deferred_character_13.f90: New test for the fix + of comment 3 of the PR. + + PR fortran/54070 + * gfortran.dg/deferred_character_8.f90: New test + * gfortran.dg/allocate_error_5.f90: New test + + PR fortran/60593 + * gfortran.dg/deferred_character_10.f90: New test + + PR fortran/60795 + * gfortran.dg/deferred_character_14.f90: New test + + PR fortran/61147 + * gfortran.dg/deferred_character_11.f90: New test + + PR fortran/64324 + * gfortran.dg/deferred_character_9.f90: New test + 2016-01-15 Vladimir Makarov PR rtl-optimization/69030 diff --git a/gcc/testsuite/gfortran.dg/allocate_error_5.f90 b/gcc/testsuite/gfortran.dg/allocate_error_5.f90 new file mode 100644 index 00000000000..4e5f4bd3b30 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_error_5.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=mem" } +! { dg-shouldfail "Fortran runtime error: Assignment of scalar to unallocated array" } +! +! This omission was encountered in the course of fixing PR54070. Whilst this is a +! very specific case, others such as allocatable components have been tested. +! +! Contributed by Tobias Burnus +! +function g(a) result (res) + character(len=*) :: a + character(len=:),allocatable :: res(:) + res = a ! Since 'res' is not allocated, a runtime error should occur. +end function + + interface + function g(a) result(res) + character(len=*) :: a + character(len=:),allocatable :: res(:) + end function + end interface + print *, g("ABC") +end diff --git a/gcc/testsuite/gfortran.dg/deferred_character_10.f90 b/gcc/testsuite/gfortran.dg/deferred_character_10.f90 new file mode 100644 index 00000000000..6a3674150a1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_10.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Checks that PR60593 is fixed (Revision: 214757) +! +! Contributed by Steve Kargl +! +! Main program added for this test. +! +module stringhelper_m + + implicit none + + type :: string_t + character(:), allocatable :: string + end type + + interface len + function strlen(s) bind(c,name='strlen') + use iso_c_binding + implicit none + type(c_ptr), intent(in), value :: s + integer(c_size_t) :: strlen + end function + end interface + + contains + + function C2FChar(c_charptr) result(res) + use iso_c_binding + type(c_ptr), intent(in) :: c_charptr + character(:), allocatable :: res + character(kind=c_char,len=1), pointer :: string_p(:) + integer i, c_str_len + c_str_len = int(len(c_charptr)) + call c_f_pointer(c_charptr, string_p, [c_str_len]) + allocate(character(c_str_len) :: res) + forall (i = 1:c_str_len) res(i:i) = string_p(i) + end function + +end module + + use stringhelper_m + use iso_c_binding + implicit none + type(c_ptr) :: cptr + character(20), target :: str + + str = "abcdefghij"//char(0) + cptr = c_loc (str) + if (len (C2FChar (cptr)) .ne. 10) call abort + if (C2FChar (cptr) .ne. "abcdefghij") call abort +end diff --git a/gcc/testsuite/gfortran.dg/deferred_character_11.f90 b/gcc/testsuite/gfortran.dg/deferred_character_11.f90 new file mode 100644 index 00000000000..454cf47e1b1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_11.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! Test the fix for PR61147. +! +! Contributed by Thomas Clune +! +module B_mod + + type :: B + character(:), allocatable :: string + end type B + +contains + + function toPointer(this) result(ptr) + character(:), pointer :: ptr + class (B), intent(in), target :: this + + ptr => this%string + + end function toPointer + +end module B_mod + +program main + use B_mod + + type (B) :: obj + character(:), pointer :: p + + obj%string = 'foo' + p => toPointer(obj) + + If (len (p) .ne. 3) call abort + If (p .ne. "foo") call abort + +end program main + + diff --git a/gcc/testsuite/gfortran.dg/deferred_character_12.f90 b/gcc/testsuite/gfortran.dg/deferred_character_12.f90 new file mode 100644 index 00000000000..cdb6c893756 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_12.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! Tests the fix for PR63232 +! +! Contributed by Balint Aradi +! +module mymod + implicit none + + type :: wrapper + character(:), allocatable :: string + end type wrapper + +contains + + + subroutine sub2(mystring) + character(:), allocatable, intent(out) :: mystring + + mystring = "test" + + end subroutine sub2 + +end module mymod + + +program test + use mymod + implicit none + + type(wrapper) :: mywrapper + + call sub2(mywrapper%string) + if (.not. allocated(mywrapper%string)) call abort + if (trim(mywrapper%string) .ne. "test") call abort + +end program test diff --git a/gcc/testsuite/gfortran.dg/deferred_character_13.f90 b/gcc/testsuite/gfortran.dg/deferred_character_13.f90 new file mode 100644 index 00000000000..822cc5de3a8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_13.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! Tests the fix for PR49630 comment #3. +! +! Contributed by Janus Weil +! +module abc + implicit none + + type::abc_type + contains + procedure::abc_function + end type abc_type + +contains + + function abc_function(this) + class(abc_type),intent(in)::this + character(:),allocatable::abc_function + allocate(abc_function,source="hello") + end function abc_function + + subroutine do_something(this) + class(abc_type),intent(in)::this + if (this%abc_function() .ne. "hello") call abort + end subroutine do_something + +end module abc + + + use abc + type(abc_type) :: a + call do_something(a) +end diff --git a/gcc/testsuite/gfortran.dg/deferred_character_14.f90 b/gcc/testsuite/gfortran.dg/deferred_character_14.f90 new file mode 100644 index 00000000000..3c4163ee7ac --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_14.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! Test fix for PR60795 comments #1 and #4 +! +! Contributed by Kergonath +! +module m +contains + subroutine allocate_array(s_array) + character(:), dimension(:), allocatable, intent(out) :: s_array + + allocate(character(2) :: s_array(2)) + s_array = ["ab","cd"] + end subroutine +end module + +program stringtest + use m + character(:), dimension(:), allocatable :: s4 + character(:), dimension(:), allocatable :: s +! Comment #1 + allocate(character(1) :: s(10)) + if (size (s) .ne. 10) call abort + if (len (s) .ne. 1) call abort +! Comment #4 + call allocate_array(s4) + if (size (s4) .ne. 2) call abort + if (len (s4) .ne. 2) call abort + if (any (s4 .ne. ["ab", "cd"])) call abort + end program diff --git a/gcc/testsuite/gfortran.dg/deferred_character_8.f90 b/gcc/testsuite/gfortran.dg/deferred_character_8.f90 new file mode 100644 index 00000000000..009acc1d290 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_8.f90 @@ -0,0 +1,84 @@ +! { dg-do run } +! +! Test the fix for all the remaining issues in PR54070. These were all +! concerned with deferred length characters being returned as function results, +! except for comment #23 where the descriptor dtype was not correctly set and +! array IO failed in consequence. +! +! Contributed by Tobias Burnus +! +! The original comment #1 with an allocate statement. +! Allocatable, deferred length scalar resul. +function f() + character(len=:),allocatable :: f + allocate (f, source = "abc") + f ="ABC" +end function +! +! Allocatable, deferred length, explicit, array result +function g(a) result (res) + character(len=*) :: a(:) + character(len (a)) :: b(size (a)) + character(len=:),allocatable :: res(:) + integer :: i + allocate (character(len(a)) :: res(2*size(a))) + do i = 1, len (a) + b(:)(i:i) = char (ichar (a(:)(i:i)) + 4) + end do + res = [a, b] +end function +! +! Allocatable, deferred length, array result +function h(a) + character(len=*) :: a(:) + character(len(a)) :: b (size(a)) + character(len=:),allocatable :: h(:) + integer :: i + allocate (character(len(a)) :: h(size(a))) + do i = 1, len (a) + b(:)(i:i) = char (ichar (a(:)(i:i)) + 32) + end do + h = b +end function + +module deferred_length_char_array +contains + function return_string(argument) + character(*) :: argument + character(:), dimension(:), allocatable :: return_string + allocate (character (len(argument)) :: return_string(2)) + return_string = argument + end function +end module + + use deferred_length_char_array + character(len=3) :: chr(3) + character(:), pointer :: s(:) + character(6) :: buffer + interface + function f() + character(len=:),allocatable :: f + end function + function g(a) result(res) + character(len=*) :: a(:) + character(len=:),allocatable :: res(:) + end function + function h(a) + character(len=*) :: a(:) + character(len=:),allocatable :: h(:) + end function + end interface + + if (f () .ne. "ABC") call abort + if (any (g (["ab","cd"]) .ne. ["ab","cd","ef","gh"])) call abort + chr = h (["ABC","DEF","GHI"]) + if (any (chr .ne. ["abc","def","ghi"])) call abort + if (any (return_string ("abcdefg") .ne. ["abcdefg","abcdefg"])) call abort + +! Comment #23 + allocate(character(3)::s(2)) + s(1) = 'foo' + s(2) = 'bar' + write (buffer, '(2A3)') s + if (buffer .ne. 'foobar') call abort +end diff --git a/gcc/testsuite/gfortran.dg/deferred_character_9.f90 b/gcc/testsuite/gfortran.dg/deferred_character_9.f90 new file mode 100644 index 00000000000..f88de7a4ad5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_9.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! Test the fix for PR64324 in which deferred length user ops +! were being mistaken as assumed length and so rejected. +! +! Contributed by Ian Harvey +! +MODULE m + IMPLICIT NONE + INTERFACE OPERATOR(.ToString.) + MODULE PROCEDURE tostring + END INTERFACE OPERATOR(.ToString.) +CONTAINS + FUNCTION tostring(arg) + INTEGER, INTENT(IN) :: arg + CHARACTER(:), ALLOCATABLE :: tostring + allocate (character(5) :: tostring) + write (tostring, "(I5)") arg + END FUNCTION tostring +END MODULE m + + use m + character(:), allocatable :: str + integer :: i = 999 + str = .ToString. i + if (str .ne. " 999") call abort +end +