Dear All,
This is a further instalment of deferred character length fixes. I
have listed the status of all the deferred length PRs that I know of
in an attachment. As far as I can see, there are five left that are
really concerned with deferred character length functionality.
In terms of the number of PRs fixed, this patch is rather less
impressive than it looks. Essentially four things have been fixed:
(i) Deferred character length results are passed by reference and so,
within the procedure itself, they are consistently indirectly
referenced;
(ii) The deferred character types are made correctly by indirectly
referencing the character length;
(iii) Array references to deferred character arrays use pointer arithmetic; and
(iv) Scalar assignments to unallocated arrays are trapped at runtime
with -fcheck=mem.
A minor tweak was required to fix PR64324 because deferred length
characters were being misidentified as assumed length.
The ChangeLog is clear as to what has been done. The only point on
which I am uncertain is that of making the length parameter of
deferred character length procedure results TREE_STATIC. This was
required to make the patch function correctly at any level of
optimization. Is this the best and/or only way of doing this?
Bootstrapped and regtested on FC21/x86_64 - OK for trunk and, after a
decent interval, 5 branch?
Cheers
Paul
2016-01-09 Paul Thomas <pa...@gcc.gnu.org>
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.
* 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-09 Paul Thomas <pa...@gcc.gnu.org>
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
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 <ka...@gcc.gnu.org>
+ !
+ ! 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 <thomas.l.cl...@nasa.gov>
+ !
+ 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 <barad...@gmail.com>
+ !
+ 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 <ja...@gcc.gnu.org>
+ !
+ 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 <kergon...@me.com>
+ !
+ 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 <bur...@gcc.gnu.org>
+ !
+ ! 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 <ian_har...@bigpond.com>
+ !
+ 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 <bur...@gcc.gnu.org>
+ !
+ 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
54070 [4.9/5/6 Regression] Wrong code with allocatable deferred-length
(array) function results
Working patch, original problem now fixed.
deferred_character_8.f90
and allocate_error_5.f90
66408 deferred-length character & overloaded assignment
Assigned to me and fixed on trunk. Part of first commit - apply
to 5-branch
46299 Diagnose specification expressions involving host-associated vars with
deferred bounds
NOT YET FIXED Off subject but picked up because of "deferred"
49630 [OOP] ICE on obsolescent deferred-length type bound character function
Check that the test in comment #3 works -
deferred_character_13.f90
49954 ICE assigning concat expression to an array deferred-length string
(realloc on assignment)
Assigned to me and fixed on trunk. Part of first commit - apply
to 5-branch
55735 ICE with deferred-length strings in COMMON
NOT YET FIXED This should be fixable relatively easily. Will need
pointer/descriptor + string_length combination.
57910 ICE (segfault) with deferred-length strings 2015-11-06
NOT YET FIXED A vicious looking thing involving a mixtire of ISO-C-Binding and
deferred length characters
Still fails.
60458 Error message on associate: deferred type parameter and requires
either the pointer or allocatable attribute
NOT YET FIXED Worth fixing if possible. Needs work in trans-decl.c
60593 ICE with deferred length variable in FORALL
See comment #2 for simplified testcase -
deferred_character_10.f90
61147 Incorrect behavior using function that returns deferred length
character pointer
Should have been fixed - deferred_character_11.f90
63232 Deferred length character field of derived type looses its value when
used in subroutine call
High priority - deferred_character_12.f90
63667 ICE with DEFERRED procedure
NOT YET FIXED Fixed???? No. Correct error then ICE. Adding pointer attribute
allows compilation
64324 Deferred character specific functions not permitted in generic
operator interface
Should be fixable - deferred_character_9.f90
65677 Incomplete assignment on deferred-length character variable
NOT YET FIXED Problem with ADJUSTL? Post workarounds
67674 Incorrect result or ICE for deferred-length character component
Assigned to me and fixed on trunk. Part of first commit - apply
to 5-branch
68216 [F2003] IO problem with allocatable, deferred character length arrays
Assigned to me and fixed on trunk. Part of first commit - apply
to 5-branch
68241 [meta-bug] Deferred-length character 2015-11-06
17 bugs found. In addition, PR68241 contains:
50221 Allocatable string length fails with array assignment
Assigned to me and fixed on trunk. Part of first commit - apply
to 5-branch
63932 posible problem with allocatable character(:)
Assigned to me and fixed on trunk. Part of first commit - apply
to 5-branch
