OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/64324 (Deferred character specific functions not permitted in generic operator interface)

Browse Source 
2016-01-15  Paul Thomas  <pault@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.
	(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-15  Paul Thomas  <pault@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

From-SVN: r232450
This commit is contained in:
Paul Thomas 2016-01-15 20:33:58 +00:00
parent f474299175
commit afbc5ae887
17 changed files with 495 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
gcc/fortran/ChangeLog
View File

@ -1,3 +1,45 @@
2016-01-15 Paul Thomas <pault@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.
(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 <tkoenig@gcc.gnu.org>
PR fortran/69154

6
gcc/fortran/resolve.c
View File

@ -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);

18
gcc/fortran/trans-array.c
View File

@ -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. */
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)
{

30
gcc/fortran/trans-decl.c
View File

@ -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)

33
gcc/fortran/trans-expr.c
View File

@ -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

26
gcc/fortran/trans-stmt.c
View File

@ -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);

2
gcc/fortran/trans-types.c
View File

@ -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);
}

12
gcc/fortran/trans.c
View File

@ -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)

22
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,25 @@
2016-01-15 Paul Thomas <pault@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
2016-01-15 Vladimir Makarov <vmakarov@redhat.com>
PR rtl-optimization/69030

23
gcc/testsuite/gfortran.dg/allocate_error_5.f90 Normal file
View File

@ -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 <burnus@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

52
gcc/testsuite/gfortran.dg/deferred_character_10.f90 Normal file
View File

@ -0,0 +1,52 @@
! { dg-do run }
!
! Checks that PR60593 is fixed (Revision: 214757)
!
! Contributed by Steve Kargl <kargl@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

39
gcc/testsuite/gfortran.dg/deferred_character_11.f90 Normal file
View File

@ -0,0 +1,39 @@
! { dg-do run }
!
! Test the fix for PR61147.
!
! Contributed by Thomas Clune <Thomas.L.Clune@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

37
gcc/testsuite/gfortran.dg/deferred_character_12.f90 Normal file
View File

@ -0,0 +1,37 @@
! { dg-do run }
!
! Tests the fix for PR63232
!
! Contributed by Balint Aradi <baradi09@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

34
gcc/testsuite/gfortran.dg/deferred_character_13.f90 Normal file
View File

@ -0,0 +1,34 @@
! { dg-do run }
!
! Tests the fix for PR49630 comment #3.
!
! Contributed by Janus Weil <janus@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

30
gcc/testsuite/gfortran.dg/deferred_character_14.f90 Normal file
View File

@ -0,0 +1,30 @@
! { dg-do run }
!
! Test fix for PR60795 comments #1 and #4
!
! Contributed by Kergonath <kergonath@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

84
gcc/testsuite/gfortran.dg/deferred_character_8.f90 Normal file
View File

@ -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 <burnus@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)
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

28
gcc/testsuite/gfortran.dg/deferred_character_9.f90 Normal file
View File

@ -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 <ian_harvey@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