Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 232163) --- gcc/fortran/resolve.c (working copy) *************** check_uop_procedure (gfc_symbol *sym, lo *** 15320,15328 **** } 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)) { gfc_error ("User operator procedure %qs at %L cannot be assumed " "character length", sym->name, &where); --- 15320,15328 ---- } if (sym->ts.type == BT_CHARACTER ! && !((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); Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 232163) --- gcc/fortran/trans-array.c (working copy) *************** gfc_conv_scalarized_array_ref (gfc_se * *** 3165,3171 **** index, info->offset); if (expr && (is_subref_array (expr) ! || (expr->ts.deferred && expr->expr_type == EXPR_VARIABLE))) decl = expr->symtree->n.sym->backend_decl; tmp = build_fold_indirect_ref_loc (input_location, info->data); --- 3165,3172 ---- index, info->offset); if (expr && (is_subref_array (expr) ! || (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); Index: gcc/fortran/trans.c =================================================================== *** gcc/fortran/trans.c (revision 232163) --- gcc/fortran/trans.c (working copy) *************** gfc_build_array_ref (tree base, tree off *** 335,344 **** references. */ if (type && TREE_CODE (type) == ARRAY_TYPE && TYPE_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE ! && TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == VAR_DECL && decl ! && DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type))) ! == DECL_CONTEXT (decl)) span = TYPE_MAXVAL (TYPE_DOMAIN (type)); else span = NULL_TREE; --- 335,347 ---- 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))) == INDIRECT_REF) && 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; *************** gfc_build_array_ref (tree base, tree off *** 354,360 **** and reference the element with pointer arithmetic. */ if ((decl && (TREE_CODE (decl) == FIELD_DECL || TREE_CODE (decl) == VAR_DECL ! || TREE_CODE (decl) == PARM_DECL) && ((GFC_DECL_SUBREF_ARRAY_P (decl) && !integer_zerop (GFC_DECL_SPAN (decl))) || GFC_DECL_CLASS (decl) --- 357,364 ---- 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) == FUNCTION_DECL) && ((GFC_DECL_SUBREF_ARRAY_P (decl) && !integer_zerop (GFC_DECL_SPAN (decl))) || GFC_DECL_CLASS (decl) Index: gcc/fortran/trans-decl.c =================================================================== *** gcc/fortran/trans-decl.c (revision 232163) --- gcc/fortran/trans-decl.c (working copy) *************** gfc_get_symbol_decl (gfc_symbol * sym) *** 1377,1384 **** && 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); } fun_or_res = byref && (sym->attr.result --- 1377,1384 ---- && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL) { sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; ! 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 *************** gfc_get_symbol_decl (gfc_symbol * sym) *** 1420,1428 **** --- 1420,1431 ---- /* 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. */ *************** gfc_get_symbol_decl (gfc_symbol * sym) *** 1431,1436 **** --- 1434,1443 ---- && 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; } } *************** create_function_arglist (gfc_symbol * sy *** 2264,2269 **** --- 2271,2283 ---- 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); + } } } *************** create_function_arglist (gfc_symbol * sy *** 2347,2353 **** 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) gfc_create_string_length (f->sym); /* Make sure PARM_DECL type doesn't point to incomplete type. */ --- 2361,2370 ---- if (f->sym->ts.u.cl->backend_decl == NULL || f->sym->ts.u.cl->backend_decl == length) { ! 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. */ *************** gfc_trans_deferred_vars (gfc_symbol * pr *** 3975,3986 **** --- 3992,4010 ---- 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) Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 232163) --- gcc/fortran/trans-expr.c (working copy) *************** gfc_conv_procedure_call (gfc_se * se, gf *** 5942,5947 **** --- 5942,5950 ---- 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); } *************** gfc_trans_assignment_1 (gfc_expr * expr1 *** 9263,9269 **** } /* Stabilize a string length for temporaries. */ ! if (expr2->ts.type == BT_CHARACTER && !expr2->ts.deferred) string_length = gfc_evaluate_now (rse.string_length, &rse.pre); else if (expr2->ts.type == BT_CHARACTER) string_length = rse.string_length; --- 9266,9275 ---- } /* Stabilize a string length for temporaries. */ ! 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; *************** gfc_trans_assignment_1 (gfc_expr * expr1 *** 9277,9283 **** --- 9283,9314 ---- 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 Index: gcc/fortran/trans-stmt.c =================================================================== *** gcc/fortran/trans-stmt.c (revision 232163) --- gcc/fortran/trans-stmt.c (working copy) *************** gfc_trans_allocate (gfc_code * code) *** 5298,5304 **** 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 --- 5298,5303 ---- *************** gfc_trans_allocate (gfc_code * code) *** 5688,5694 **** 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); } } --- 5687,5692 ---- *************** gfc_trans_allocate (gfc_code * code) *** 5741,5756 **** 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 --- 5739,5744 ---- *************** gfc_trans_allocate (gfc_code * code) *** 5888,5893 **** --- 5876,5895 ---- /* 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); Index: gcc/fortran/trans-types.c =================================================================== *** gcc/fortran/trans-types.c (revision 232163) --- gcc/fortran/trans-types.c (working copy) *************** gfc_get_character_type (int kind, gfc_ch *** 1045,1050 **** --- 1045,1052 ---- 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); } Index: gcc/testsuite/gfortran.dg/deferred_character_10.f90 =================================================================== *** gcc/testsuite/gfortran.dg/deferred_character_10.f90 (revision 0) --- gcc/testsuite/gfortran.dg/deferred_character_10.f90 (working copy) *************** *** 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 Index: gcc/testsuite/gfortran.dg/deferred_character_11.f90 =================================================================== *** gcc/testsuite/gfortran.dg/deferred_character_11.f90 (revision 0) --- gcc/testsuite/gfortran.dg/deferred_character_11.f90 (working copy) *************** *** 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 + + Index: gcc/testsuite/gfortran.dg/deferred_character_12.f90 =================================================================== *** gcc/testsuite/gfortran.dg/deferred_character_12.f90 (revision 0) --- gcc/testsuite/gfortran.dg/deferred_character_12.f90 (working copy) *************** *** 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 Index: gcc/testsuite/gfortran.dg/deferred_character_13.f90 =================================================================== *** gcc/testsuite/gfortran.dg/deferred_character_13.f90 (revision 0) --- gcc/testsuite/gfortran.dg/deferred_character_13.f90 (working copy) *************** *** 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 Index: gcc/testsuite/gfortran.dg/deferred_character_14.f90 =================================================================== *** gcc/testsuite/gfortran.dg/deferred_character_14.f90 (revision 0) --- gcc/testsuite/gfortran.dg/deferred_character_14.f90 (working copy) *************** *** 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 Index: gcc/testsuite/gfortran.dg/deferred_character_8.f90 =================================================================== *** gcc/testsuite/gfortran.dg/deferred_character_8.f90 (revision 0) --- gcc/testsuite/gfortran.dg/deferred_character_8.f90 (working copy) *************** *** 0 **** --- 1,73 ---- + ! { 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. + ! + ! 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) + 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 + end Index: gcc/testsuite/gfortran.dg/deferred_character_9.f90 =================================================================== *** gcc/testsuite/gfortran.dg/deferred_character_9.f90 (revision 0) --- gcc/testsuite/gfortran.dg/deferred_character_9.f90 (working copy) *************** *** 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 + Index: gcc/testsuite/gfortran.dg/allocate_error_5.f90 =================================================================== *** gcc/testsuite/gfortran.dg/allocate_error_5.f90 (revision 0) --- gcc/testsuite/gfortran.dg/allocate_error_5.f90 (working copy) *************** *** 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