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

re PR fortran/50221 (Allocatable string length fails with array assignment)

Browse Source 
2015-11-15  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/50221
	PR fortran/68216
	PR fortran/63932
	PR fortran/66408
	* trans_array.c (gfc_conv_scalarized_array_ref): Pass the
	symbol decl for deferred character length array references.
	* trans-stmt.c (gfc_trans_allocate): Keep the string lengths
	to update deferred length character string lengths.
	* trans-types.c (gfc_get_dtype_rank_type); Use the string
	length of deferred character types for the dtype size.
	* trans.c (gfc_build_array_ref): For references to deferred
	character arrays, use the domain max value, if it is a variable
	to set the 'span' and use pointer arithmetic for acces to the
	element.
	(trans_code): Set gfc_current_locus for diagnostic purposes.

	PR fortran/67674
	* trans-expr.c (gfc_conv_procedure_call): Do not fix deferred
	string lengths of components.

	PR fortran/49954
	* resolve.c (deferred_op_assign): New function.
	(gfc_resolve_code): Call it.
	* trans-array.c (concat_str_length): New function.
	(gfc_alloc_allocatable_for_assignment): Jump directly to alloc/
	realloc blocks for deferred character length arrays because the
	string length might change, even if the shape is the same. Call
	concat_str_length to obtain the string length for concatenation
	since it is needed to compute the lhs string length.
	Set the descriptor dtype appropriately for the new string
	length.
	* trans-expr.c (gfc_trans_assignment_1): Use the rse string
	length for all characters, other than deferred types. For
	concatenation operators, push the rse.pre block to the inner
	most loop so that the temporary pointer and the assignments
	are properly placed.

2015-11-15  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/50221
	* gfortran.dg/deferred_character_1.f90: New test.
	* gfortran.dg/deferred_character_4.f90: New test for comment
	#4 of the PR.

	PR fortran/68216
	* gfortran.dg/deferred_character_2.f90: New test.

	PR fortran/67674
	* gfortran.dg/deferred_character_3.f90: New test.

	PR fortran/63932
	* gfortran.dg/deferred_character_5.f90: New test.

	PR fortran/66408
	* gfortran.dg/deferred_character_6.f90: New test.

	PR fortran/49954
	* gfortran.dg/deferred_character_7.f90: New test.

From-SVN: r230396
This commit is contained in:
Paul Thomas 2015-11-15 14:07:52 +00:00
parent 356510acd9
commit 78ab5260a1
14 changed files with 598 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
gcc/fortran/ChangeLog
View File

@ -1,3 +1,42 @@
2015-11-15 Paul Thomas <pault@gcc.gnu.org>
PR fortran/50221
PR fortran/68216
PR fortran/63932
PR fortran/66408
* trans_array.c (gfc_conv_scalarized_array_ref): Pass the
symbol decl for deferred character length array references.
* trans-stmt.c (gfc_trans_allocate): Keep the string lengths
to update deferred length character string lengths.
* trans-types.c (gfc_get_dtype_rank_type); Use the string
length of deferred character types for the dtype size.
* trans.c (gfc_build_array_ref): For references to deferred
character arrays, use the domain max value, if it is a variable
to set the 'span' and use pointer arithmetic for acces to the
element.
(trans_code): Set gfc_current_locus for diagnostic purposes.
PR fortran/67674
* trans-expr.c (gfc_conv_procedure_call): Do not fix deferred
string lengths of components.
PR fortran/49954
* resolve.c (deferred_op_assign): New function.
(gfc_resolve_code): Call it.
* trans-array.c (concat_str_length): New function.
(gfc_alloc_allocatable_for_assignment): Jump directly to alloc/
realloc blocks for deferred character length arrays because the
string length might change, even if the shape is the same. Call
concat_str_length to obtain the string length for concatenation
since it is needed to compute the lhs string length.
Set the descriptor dtype appropriately for the new string
length.
* trans-expr.c (gfc_trans_assignment_1): Use the rse string
length for all characters, other than deferred types. For
concatenation operators, push the rse.pre block to the inner
most loop so that the temporary pointer and the assignments
are properly placed.
2015-11-14 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/67803

51
gcc/fortran/resolve.c
View File

@ -10222,6 +10222,50 @@ resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
}
/* Deferred character length assignments from an operator expression
require a temporary because the character length of the lhs can
change in the course of the assignment. */
static bool
deferred_op_assign (gfc_code **code, gfc_namespace *ns)
{
gfc_expr *tmp_expr;
gfc_code *this_code;
if (!((*code)->expr1->ts.type == BT_CHARACTER
&& (*code)->expr1->ts.deferred && (*code)->expr1->rank
&& (*code)->expr2->expr_type == EXPR_OP))
return false;
if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
return false;
tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
tmp_expr->where = (*code)->loc;
/* A new charlen is required to ensure that the variable string
length is different to that of the original lhs. */
tmp_expr->ts.u.cl = gfc_get_charlen();
tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
(*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
tmp_expr->symtree->n.sym->ts.deferred = 1;
this_code = build_assignment (EXEC_ASSIGN,
(*code)->expr1,
gfc_copy_expr (tmp_expr),
NULL, NULL, (*code)->loc);
(*code)->expr1 = tmp_expr;
this_code->next = (*code)->next;
(*code)->next = this_code;
return true;
}
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
@ -10427,6 +10471,11 @@ start:
goto call;
}
/* Check for dependencies in deferred character length array
assignments and generate a temporary, if necessary. */
if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
break;
/* F03 7.4.1.3 for non-allocatable, non-pointer components. */
if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
&& code->expr1->ts.u.derived
@ -10801,7 +10850,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
sym->binding_label = NULL;
}
else if (sym->attr.flavor == FL_VARIABLE && module
else if (sym->attr.flavor == FL_VARIABLE && module
&& (strcmp (module, gsym->mod_name) != 0
|| strcmp (sym->name, gsym->sym_name) != 0))
{

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

@ -3164,7 +3164,8 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
index, info->offset);
if (expr && is_subref_array (expr))
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);
@ -8499,6 +8500,75 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
}
static tree
concat_str_length (gfc_expr* expr)
{
tree type;
tree len1;
tree len2;
gfc_se se;
type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
if (len1 == NULL_TREE)
{
if (expr->value.op.op1->expr_type == EXPR_OP)
len1 = concat_str_length (expr->value.op.op1);
else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
len1 = build_int_cst (gfc_charlen_type_node,
expr->value.op.op1->value.character.length);
else if (expr->value.op.op1->ts.u.cl->length)
{
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
len1 = se.expr;
}
else
{
/* Last resort! */
gfc_init_se (&se, NULL);
se.want_pointer = 1;
se.descriptor_only = 1;
gfc_conv_expr (&se, expr->value.op.op1);
len1 = se.string_length;
}
}
type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
if (len2 == NULL_TREE)
{
if (expr->value.op.op2->expr_type == EXPR_OP)
len2 = concat_str_length (expr->value.op.op2);
else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
len2 = build_int_cst (gfc_charlen_type_node,
expr->value.op.op2->value.character.length);
else if (expr->value.op.op2->ts.u.cl->length)
{
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
len2 = se.expr;
}
else
{
/* Last resort! */
gfc_init_se (&se, NULL);
se.want_pointer = 1;
se.descriptor_only = 1;
gfc_conv_expr (&se, expr->value.op.op2);
len2 = se.string_length;
}
}
gcc_assert(len1 && len2);
len1 = fold_convert (gfc_charlen_type_node, len1);
len2 = fold_convert (gfc_charlen_type_node, len2);
return fold_build2_loc (input_location, PLUS_EXPR,
gfc_charlen_type_node, len1, len2);
}
/* Allocate the lhs of an assignment to an allocatable array, otherwise
reallocate it. */
@ -8596,6 +8666,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
/* Allocate if data is NULL. */
cond_null = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
array1, build_int_cst (TREE_TYPE (array1), 0));
if (expr1->ts.deferred)
cond_null = gfc_evaluate_now (boolean_true_node, &fblock);
else
cond_null= gfc_evaluate_now (cond_null, &fblock);
tmp = build3_v (COND_EXPR, cond_null,
build1_v (GOTO_EXPR, jump_label1),
build_empty_stmt (input_location));
@ -8684,7 +8760,13 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
size1, size2);
neq_size = gfc_evaluate_now (cond, &fblock);
/* If the lhs is deferred length, assume that the element size
changes and force a reallocation. */
if (expr1->ts.deferred)
neq_size = gfc_evaluate_now (boolean_true_node, &fblock);
else
neq_size = gfc_evaluate_now (cond, &fblock);
/* Deallocation of allocatable components will have to occur on
reallocation. Fix the old descriptor now. */
@ -8789,6 +8871,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
else
{
tmp = expr2->ts.u.cl->backend_decl;
if (!tmp && expr2->expr_type == EXPR_OP
&& expr2->value.op.op == INTRINSIC_CONCAT)
{
tmp = concat_str_length (expr2);
expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
}
tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
}
@ -8816,6 +8904,22 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
size2, size_one_node);
size2 = gfc_evaluate_now (size2, &fblock);
/* For deferred character length, the 'size' field of the dtype might
have changed so set the dtype. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
&& expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
{
tree type;
tmp = gfc_conv_descriptor_dtype (desc);
if (expr2->ts.u.cl->backend_decl)
type = gfc_typenode_for_spec (&expr2->ts);
else
type = gfc_typenode_for_spec (&expr1->ts);
gfc_add_modify (&fblock, tmp,
gfc_get_dtype_rank_type (expr1->rank,type));
}
/* Realloc expression. Note that the scalarizer uses desc.data
in the array reference - (*desc.data)[<element>]. */
gfc_init_block (&realloc_block);
@ -8858,8 +8962,16 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
1, size2);
gfc_conv_descriptor_data_set (&alloc_block,
desc, tmp);
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
/* We already set the dtype in the case of deferred character
length arrays. */
if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
&& expr1->ts.type == BT_CHARACTER && expr1->ts.deferred))
{
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
}
if ((expr1->ts.type == BT_DERIVED)
&& expr1->ts.u.derived->attr.alloc_comp)
{

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

@ -5599,7 +5599,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else
{
tmp = parmse.string_length;
if (TREE_CODE (tmp) != VAR_DECL)
if (TREE_CODE (tmp) != VAR_DECL
&& TREE_CODE (tmp) != COMPONENT_REF)
tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
}
@ -9250,8 +9251,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)
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;
else
string_length = NULL_TREE;
@ -9285,8 +9288,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
the function call must happen before the (re)allocation of the lhs -
otherwise the character length of the result is not known.
NOTE: This relies on having the exact dependence of the length type
parameter available to the caller; gfortran saves it in the .mod files. */
if (flag_realloc_lhs && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred)
parameter available to the caller; gfortran saves it in the .mod files.
NOTE ALSO: The concatenation operation generates a temporary pointer,
whose allocation must go to the innermost loop. */
if (flag_realloc_lhs
&& expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
&& !(lss != gfc_ss_terminator
&& expr2->expr_type == EXPR_OP
&& expr2->value.op.op == INTRINSIC_CONCAT))
gfc_add_block_to_block (&block, &rse.pre);
/* Nullify the allocatable components corresponding to those of the lhs

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

@ -5086,6 +5086,7 @@ 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
@ -5463,6 +5464,7 @@ 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);
}
}
@ -5514,6 +5516,17 @@ 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

20
gcc/fortran/trans.c
View File

@ -331,6 +331,18 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
type = TREE_TYPE (type);
/* Use pointer arithmetic for deferred character length array
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;
if (DECL_P (base))
TREE_ADDRESSABLE (base) = 1;
@ -345,8 +357,9 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
|| TREE_CODE (decl) == PARM_DECL)
&& ((GFC_DECL_SUBREF_ARRAY_P (decl)
&& !integer_zerop (GFC_DECL_SPAN (decl)))
|| GFC_DECL_CLASS (decl)))
|| vptr)
|| GFC_DECL_CLASS (decl)
|| span != NULL_TREE))
|| vptr != NULL_TREE)
{
if (decl)
{
@ -376,6 +389,8 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
}
else if (GFC_DECL_SUBREF_ARRAY_P (decl))
span = GFC_DECL_SPAN (decl);
else if (span)
span = fold_convert (gfc_array_index_type, span);
else
gcc_unreachable ();
}
@ -1620,6 +1635,7 @@ trans_code (gfc_code * code, tree cond)
gfc_add_expr_to_block (&block, res);
}
gfc_current_locus = code->loc;
gfc_set_backend_locus (&code->loc);
switch (code->op)

24
gcc/testsuite/ChangeLog
View File

@ -1,5 +1,27 @@
2015-11-15 Paul Thomas <pault@gcc.gnu.org>
PR fortran/50221
* gfortran.dg/deferred_character_1.f90: New test.
* gfortran.dg/deferred_character_4.f90: New test for comment
#4 of the PR.
PR fortran/68216
* gfortran.dg/deferred_character_2.f90: New test.
PR fortran/67674
* gfortran.dg/deferred_character_3.f90: New test.
PR fortran/63932
* gfortran.dg/deferred_character_5.f90: New test.
PR fortran/66408
* gfortran.dg/deferred_character_6.f90: New test.
PR fortran/49954
* gfortran.dg/deferred_character_7.f90: New test.
2015-11-14 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/67803
* gfortran.dg/pr67803.f90: New test.

40
gcc/testsuite/gfortran.dg/deferred_character_1.f90 Normal file
View File

@ -0,0 +1,40 @@
! { dg-do run }
!
! Tests the fix for PR50221
!
! Contributed by Clive Page <clivegpage@gmail.com>
! and Tobias Burnus <burnus@gcc.gnu.org>
!
! This is from comment #2 by Tobias Burnus.
!
module m
character(len=:), save, allocatable :: str(:)
character(len=2), parameter :: const(3) = ["a1", "b2", "c3"]
end
use m
call test()
if(allocated(str)) deallocate(str)
call foo
contains
subroutine test()
call doit()
! print *, 'strlen=',len(str),' / array size =',size(str)
! print '(3a)', '>',str(1),'<'
! print '(3a)', '>',str(2),'<'
! print '(3a)', '>',str(3),'<'
if (any (str .ne. const)) call abort
end subroutine test
subroutine doit()
str = const
end subroutine doit
subroutine foo
!
! This is the original PR from Clive Page
!
character(:), allocatable, dimension(:) :: array
array = (/'xx', 'yy', 'zz'/)
! print *, 'array=', array, len(array(1)), size(array)
if (any (array .ne. ["xx", "yy", "zz"])) call abort
end subroutine
end

85
gcc/testsuite/gfortran.dg/deferred_character_2.f90 Normal file
View File

@ -0,0 +1,85 @@
! { dg-do run }
!
! Tests the fix for PR68216
!
! Reported on clf: https://groups.google.com/forum/#!topic/comp.lang.fortran/eWQTKfqKLZc
!
PROGRAM hello
!
! This is based on the first testcase, from Francisco (Ayyy LMAO). Original
! lines are commented out. The second testcase from this thread is acalled
! at the end of the program.
!
IMPLICIT NONE
CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_lineas
CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_copia
character (3), dimension (2) :: array_fijo = ["abc","def"]
character (100) :: buffer
INTEGER :: largo , cant_lineas , i
write (buffer, "(2a3)") array_fijo
! WRITE(*,*) ' Escriba un numero para el largo de cada linea'
! READ(*,*) largo
largo = LEN (array_fijo)
! WRITE(*,*) ' Escriba la cantidad de lineas'
! READ(*,*) cant_lineas
cant_lineas = size (array_fijo, 1)
ALLOCATE(CHARACTER(LEN=largo) :: array_lineas(cant_lineas))
! WRITE(*,*) 'Escriba el array', len(array_lineas), size(array_lineas)
READ(buffer,"(2a3)") (array_lineas(i),i=1,cant_lineas)
! WRITE(*,*) 'Array guardado: '
! DO i=1,cant_lineas
! WRITE(*,*) array_lineas(i)
! ENDDO
if (any (array_lineas .ne. array_fijo)) call abort
! The following are additional tests beyond that of the original.
!
! Check that allocation with source = another deferred length is OK
allocate (array_copia, source = array_lineas)
if (any (array_copia .ne. array_fijo)) call abort
deallocate (array_lineas, array_copia)
! Check that allocation with source = a non-deferred length is OK
allocate (array_lineas, source = array_fijo)
if (any (array_lineas .ne. array_fijo)) call abort
deallocate (array_lineas)
! Check that allocation with MOLD = a non-deferred length is OK
allocate (array_copia, mold = [array_fijo(:)(1:2), array_fijo(:)(1:2)])
if (size (array_copia, 1) .ne. 4) call abort
if (LEN (array_copia, 1) .ne. 2) call abort
! Check that allocation with MOLD = another deferred length is OK
allocate (array_lineas, mold = array_copia)
if (size (array_copia, 1) .ne. 4) call abort
if (LEN (array_copia, 1) .ne. 2) call abort
deallocate (array_lineas, array_copia)
! READ(*,*)
call testdefchar
contains
subroutine testdefchar
!
! This is the testcase in the above thread from Blokbuster
!
implicit none
character(:), allocatable :: test(:)
allocate(character(3) :: test(2))
test(1) = 'abc'
test(2) = 'def'
if (any (test .ne. ['abc', 'def'])) call abort
test = ['aa','bb','cc']
if (any (test .ne. ['aa', 'bb', 'cc'])) call abort
end subroutine testdefchar
END PROGRAM

46
gcc/testsuite/gfortran.dg/deferred_character_3.f90 Normal file
View File

@ -0,0 +1,46 @@
! {dg_do run }
!
! Tests the fix for PR67674
!
! Contributed by Kristopher Kuhlman <kristopher.kuhlman@gmail.com>
!
program test
implicit none
type string_type
character(len=:), allocatable :: name
end type string_type
type(string_type), allocatable :: my_string_type
allocate(my_string_type)
allocate(character(len=0) :: my_string_type%name)
! print *, 'length main program before',len(my_string_type%name)
call inputreadword1(my_string_type%name)
! print *, 'length main program after',len(my_string_type%name)
! print *, 'final result:',my_string_type%name
if (my_string_type%name .ne. 'here the word is finally set') call abort
contains
subroutine inputreadword1(word_intermediate)
character(len=:), allocatable :: word_intermediate
! print *, 'length intermediate before',len(word_intermediate)
call inputreadword2(word_intermediate)
! print *, 'length intermediate after',len(word_intermediate)
! print *, word_intermediate
end subroutine inputreadword1
subroutine inputreadword2(word)
character(len=:), allocatable :: word
! print *, 'length inner before',len(word)
word = 'here the word is finally set' ! want automatic reallocation to happen here
! print *, 'length inner after',len(word)
! print *, word
end subroutine inputreadword2
end program test

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

@ -0,0 +1,30 @@
! { dg-do run }
!
! Check that PR50221 comment #4 is fixed.
!
! Contributed by Arjen Makus <arjen.markus895@gmail.com>
!
program chk_alloc_string
implicit none
character(len=:), dimension(:), allocatable :: strings
character(20) :: buffer
integer :: i
allocate( character(10):: strings(1:3) )
strings = [ "A ", "C ", "ABCD", "V " ]
if (len(strings) .ne. 4) call abort
if (size(strings, 1) .ne. 4) call abort
if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V"])) call abort
strings = [character(len=4) :: "A", "C", "ABCDE", "V", "zzzz"]
if (len(strings) .ne. 4) call abort
if (size(strings, 1) .ne. 5) call abort
if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V", "zzzz"])) call abort
write (buffer, "(5a4)") strings
if (buffer .ne. "A C ABCDV zzzz") call abort
end program chk_alloc_string

32
gcc/testsuite/gfortran.dg/deferred_character_5.f90 Normal file
View File

@ -0,0 +1,32 @@
! { dg-do run }
!
! Tests that PR63932 stays fixed.
!
! Contributed by Valery Weber <valeryweber@hotmail.com>
!
module mod
type :: t
character(:), allocatable :: c
integer :: i
contains
procedure, pass :: get
end type t
type :: u
character(:), allocatable :: c
end type u
contains
subroutine get(this, a)
class(t), intent(in) :: this
character(:), allocatable, intent(out), optional :: a
if (present (a)) a = this%c
end subroutine get
end module mod
program test
use mod
type(t) :: a
type(u) :: b
a%c = 'something'
call a%get (a = b%c)
if (b%c .ne. 'something') call abort
end program test

54
gcc/testsuite/gfortran.dg/deferred_character_6.f90 Normal file
View File

@ -0,0 +1,54 @@
! { dg-do run }
!
! Tests that PR66408 stays fixed.
!
! Contributed by <werner.blokbuster@gmail.com>
!
module mytest
implicit none
type vary
character(:), allocatable :: string
end type vary
interface assignment(=)
module procedure char_eq_vary
end interface assignment(=)
contains
subroutine char_eq_vary(my_char,my_vary)
character(:), allocatable, intent(out) :: my_char
type(vary), intent(in) :: my_vary
my_char = my_vary%string
end subroutine char_eq_vary
end module mytest
program thistest
use mytest, only: vary, assignment(=)
implicit none
character(:), allocatable :: test_char
character(14), parameter :: str = 'example string'
type(vary) :: test_vary
type(vary) :: my_stuff
test_vary%string = str
if (test_vary%string .ne. str) call abort
! This previously gave a blank string.
my_stuff%string = test_vary
if (my_stuff%string .ne. str) call abort
test_char = test_vary
if (test_char .ne. str) call abort
my_stuff = test_vary
if (my_stuff%string .ne. str) call abort
end program thistest

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

@ -0,0 +1,39 @@
! { dg-do run }
!
! Tests the fix for pr49954, in which concatenation to deferred length character
! arrays, at best, did not work correctly.
!
!
!
implicit none
character(len=:), allocatable :: a1(:)
character(len=:), allocatable :: a2(:), a3(:)
character(len=:), allocatable :: b1
character(len=:), allocatable :: b2
character(8) :: chr = "IJKLMNOP"
character(48) :: buffer
a1 = ["ABCDEFGH","abcdefgh"]
a2 = "_"//a1//chr//"_"
if (any (a2 .ne. ["_ABCDEFGHIJKLMNOP_","_abcdefghIJKLMNOP_"])) call abort
! Check that the descriptor dtype is OK - the array write needs it.
write (buffer, "(2a18)") a2
if (trim (buffer) .ne. "_ABCDEFGHIJKLMNOP__abcdefghIJKLMNOP_") call abort
! Make sure scalars survived the fix!
b1 = "ABCDEFGH"
b2 = "_"//b1//chr//"_"
if (b2 .ne. "_ABCDEFGHIJKLMNOP_") call abort
! Check the dependency is detected and dealt with by generation of a temporary.
a1 = "?"//a1//"?"
if (any (a1 .ne. ["?ABCDEFGH?","?abcdefgh?"])) call abort
! With an array reference...
a1 = "?"//a1(1:2)//"?"
if (any (a1 .ne. ["??ABCDEFGH??","??abcdefgh??"])) call abort
!... together with a substring.
a1 = "?"//a1(1:1)(2:4)//"?"
if (any (a1 .ne. ["??AB?"])) call abort
contains
end