FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/87151 (allocating array of character)

Browse source 
2018-10-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/87151
	* trans-array.c (gfc_get_array_span): Deal with deferred char
	array components having a TYPE_MAX_VALUE of zero.
	(gfc_array_init_size): Use the hidden string length component
	to build the descriptor dtype.
	(gfc_array_allocate): Remove the erroneous replacement of the
	charlen backend decl with a temporary.
	(gfc_conv_expr_descriptor): Use the ss_info string length in
	the case of deferred character components.
	(gfc_alloc_allocatable_for_assignment): Actually compare the
	string lengths for deferred characters. Make sure that kind > 1
	is handled correctly. Set the span field of the descriptor.
	* trans-intrinsic.c (gfc_conv_intrinsic_len): Remove the stupid
	comment.

	PR fortran/80931
	* trans-array.c (gfc_array_allocate): Set the span field for
	variable length character arrays.


2018-10-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/87151
	* gfortran.dg/deferred_type_component_3.f90: New test.

	PR fortran/80931
	* gfortran.dg/deferred_character_28.f90: New test.
	* gfortran.dg/deferred_character_29.f90: New test (note that
	this test appears in PR83196 comment #4 by mistake).

From-SVN: r264949
This commit is contained in:
Paul Thomas 2018-10-09 07:46:48 +00:00
parent 6d52096313
commit 9d44426f78
7 changed files with 429 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
gcc/fortran/ChangeLog
View file

@ -1,3 +1,24 @@
2018-10-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/87151
* trans-array.c (gfc_get_array_span): Deal with deferred char
array components having a TYPE_MAX_VALUE of zero.
(gfc_array_init_size): Use the hidden string length component
to build the descriptor dtype.
(gfc_array_allocate): Remove the erroneous replacement of the
charlen backend decl with a temporary.
(gfc_conv_expr_descriptor): Use the ss_info string length in
the case of deferred character components.
(gfc_alloc_allocatable_for_assignment): Actually compare the
string lengths for deferred characters. Make sure that kind > 1
is handled correctly. Set the span field of the descriptor.
* trans-intrinsic.c (gfc_conv_intrinsic_len): Remove the stupid
comment.
PR fortran/80931
* trans-array.c (gfc_array_allocate): Set the span field for
variable length character arrays.
2018-10-08 Cesar Philippidis <cesar@codesourcery.com>
* expr.c (gfc_check_pointer_assign): Demote "Assignment to

90
gcc/fortran/trans-array.c
View file

@ -853,7 +853,8 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
types if possible. Otherwise, return NULL_TREE. */
tmp = gfc_get_element_type (TREE_TYPE (desc));
if (tmp && TREE_CODE (tmp) == ARRAY_TYPE
&& TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE)
&& (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE
|| integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)))))
{
if (expr->expr_type == EXPR_VARIABLE
&& expr->ts.type == BT_CHARACTER)
@ -5366,6 +5367,28 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
}
else if (expr->ts.type == BT_CHARACTER
&& expr->ts.deferred
&& TREE_CODE (descriptor) == COMPONENT_REF)
{
/* Deferred character components have their string length tucked away
in a hidden field of the derived type. Obtain that and use it to
set the dtype. The charlen backend decl is zero because the field
type is zero length. */
gfc_ref *ref;
tmp = NULL_TREE;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT
&& gfc_deferred_strlen (ref->u.c.component, &tmp))
break;
gcc_assert (tmp != NULL_TREE);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
tmp = fold_convert (gfc_charlen_type_node, tmp);
type = gfc_get_character_type_len (expr->ts.kind, tmp);
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
}
else
{
tmp = gfc_conv_descriptor_dtype (descriptor);
@ -5774,16 +5797,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
if (expr->ts.type == BT_CHARACTER
&& TREE_CODE (se->string_length) == COMPONENT_REF
&& expr->ts.u.cl->backend_decl != se->string_length)
{
if (VAR_P (expr->ts.u.cl->backend_decl))
gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
se->string_length));
else
expr->ts.u.cl->backend_decl = gfc_evaluate_now (se->string_length,
&se->pre);
}
&& expr->ts.u.cl->backend_decl != se->string_length
&& VAR_P (expr->ts.u.cl->backend_decl))
gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
se->string_length));
gfc_init_block (&set_descriptor_block);
/* Take the corank only from the actual ref and not from the coref. The
@ -5871,17 +5889,19 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
if (dimension)
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
/* Pointer arrays need the span field to be set. */
if (is_pointer_array (se->expr)
|| (expr->ts.type == BT_CLASS
&& CLASS_DATA (expr)->attr.class_pointer)
/* Set the span field for pointer and deferred length character arrays. */
if ((is_pointer_array (se->expr)
|| (expr->ts.type == BT_CLASS && CLASS_DATA (expr)->attr.class_pointer)
|| (expr->ts.type == BT_CHARACTER && TREE_CODE (se->string_length)
== COMPONENT_REF))
|| (expr->ts.type == BT_CHARACTER
&& TREE_CODE (se->string_length) == COMPONENT_REF))
&& (expr->ts.deferred || VAR_P (expr->ts.u.cl->backend_decl))))
{
if (expr3 && expr3_elem_size != NULL_TREE)
tmp = expr3_elem_size;
else if (se->string_length
&& TREE_CODE (se->string_length) == COMPONENT_REF)
&& (TREE_CODE (se->string_length) == COMPONENT_REF
|| (expr->ts.type == BT_CHARACTER && expr->ts.deferred)))
{
if (expr->ts.kind != 1)
{
@ -7053,6 +7073,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
tree offset;
int full;
bool subref_array_target = false;
bool deferred_array_component = false;
gfc_expr *arg, *ss_expr;
if (se->want_coarray)
@ -7092,6 +7113,14 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gfc_conv_ss_descriptor (&se->pre, ss, 0);
desc = info->descriptor;
/* The charlen backend decl for deferred character components cannot
be used because it is fixed at zero. Instead, the hidden string
length component is used. */
if (expr->ts.type == BT_CHARACTER
&& expr->ts.deferred
&& TREE_CODE (desc) == COMPONENT_REF)
deferred_array_component = true;
subref_array_target = se->direct_byref && is_subref_array (expr);
need_tmp = gfc_ref_needs_temporary_p (expr->ref)
&& !subref_array_target;
@ -7140,8 +7169,12 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
se->expr = desc;
}
if (expr->ts.type == BT_CHARACTER)
if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
se->string_length = gfc_get_expr_charlen (expr);
/* The ss_info string length is returned set to the value of the
hidden string length component. */
else if (deferred_array_component)
se->string_length = ss_info->string_length;
gfc_free_ss_chain (ss);
return;
@ -9797,8 +9830,15 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
array1, build_int_cst (TREE_TYPE (array1), 0));
if (expr1->ts.deferred)
cond_null = gfc_evaluate_now (logical_true_node, &fblock);
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
{
tmp = fold_build2_loc (input_location, NE_EXPR,
logical_type_node,
lss->info->string_length,
rss->info->string_length);
cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
logical_type_node, tmp, cond_null);
}
else
cond_null= gfc_evaluate_now (cond_null, &fblock);
@ -10024,6 +10064,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
else
gfc_add_modify (&fblock, lss->info->string_length, tmp);
if (expr1->ts.kind > 1)
tmp = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp),
tmp, build_int_cst (TREE_TYPE (tmp),
expr1->ts.kind));
}
else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
{
@ -10037,6 +10083,10 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
else
tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
tmp = fold_convert (gfc_array_index_type, tmp);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
gfc_conv_descriptor_span_set (&fblock, desc, tmp);
size2 = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
tmp, size2);

1
gcc/fortran/trans-intrinsic.c
View file

@ -6404,7 +6404,6 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
/* Fall through. */
default:
/* Anybody stupid enough to do this deserves inefficient code. */
gfc_init_se (&argse, se);
if (arg->rank == 0)
gfc_conv_expr (&argse, arg);

10
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,13 @@
2018-10-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/87151
* gfortran.dg/deferred_type_component_3.f90: New test.
PR fortran/80931
* gfortran.dg/deferred_character_28.f90: New test.
* gfortran.dg/deferred_character_29.f90: New test (note that
this test appears in PR83196 comment #4 by mistake).
2018-10-08 Eric Botcazou <ebotcazou@adacore.com>
* gcc.target/i386/vararg-loc.c: Accept a column number.

60
gcc/testsuite/gfortran.dg/deferred_character_28.f90 Normal file
View file

@ -0,0 +1,60 @@
! { dg-do run }
!
! Test the fix for PR80931, which was nearly fix by the patch for PR87151.
! However, the 'span' for 'temp' was not being set and so a segfault
! occurred in the assignment at line 39.
!
! Contributed by Tiziano Mueller <dev-zero@gentoo.org>
!
module input_section_types
type :: section
character(len=:), allocatable :: keywords_(:)
contains
procedure, pass :: add_keyword
end type
interface section
procedure constructor
end interface
contains
type(section) function constructor ()
allocate (character(len=255) :: constructor%keywords_(0))
end function
subroutine add_keyword (this, name)
class(section), intent(inout) :: this
character(*), intent(in) :: name
character(len=:), allocatable :: temp(:)
integer :: n_elements
n_elements = size (this%keywords_)
allocate (character(len=255) :: temp(n_elements+1))
temp(:n_elements) = this%keywords_
call move_alloc (temp, this%keywords_)
this%keywords_(n_elements+1) = name
end subroutine
end module
use input_section_types
type(section) :: s
character(*), parameter :: hello = "Hello World"
character(*), parameter :: bye = "Goodbye World"
s = constructor ()
call s%add_keyword (hello)
if (len (s%keywords_) .ne. 255) stop 1
if (size (s%keywords_, 1) .ne. 1) stop 2
if (trim (s%keywords_(1)) .ne. hello) stop 3
call s%add_keyword (bye)
if (len (s%keywords_) .ne. 255) stop 4
if (size (s%keywords_, 1) .ne. 2) stop 5
if (trim (s%keywords_(1)) .ne. hello) stop 6
if (trim (s%keywords_(2)) .ne. bye) stop 7
end

197
gcc/testsuite/gfortran.dg/deferred_character_29.f90 Normal file
View file

@ -0,0 +1,197 @@
! { dg-do compile }
!
! Test the fix for PR83196 comment #4 (there by mistake)
!
! Contributed by Arjen Markus <arjen.markus895@gmail.com>
!____________________________________________________________
! keyindex.f90 --
! Class implementing a straightforward keyword/index list
! The idea is to have a very simple implementation to
! store keywords (strings) and return the position in the
! list or vice versa.
!____________________________________________________________
module keyindices
implicit none
private
integer, parameter :: default_keylength = 40
type keyindex
integer :: keylength
integer :: lastindex = 0
character(len=:), dimension(:), allocatable :: keyword
contains
procedure :: init => init_keyindex
procedure :: get_index => get_index_from_list
procedure :: get_key => get_keyword_from_list
procedure :: has_key => has_keyword_in_list
end type keyindex
public :: keyindex
contains
! init_keyindex --
! Initialise the object
!
! Arguments:
! this Keyindex object
! initial_size Initial size of the list (optimisation)
! keylength Maximum length of a keyword (optional)
!
subroutine init_keyindex( this, initial_size, keylength )
class(keyindex), intent(inout) :: this
integer, intent(in) :: initial_size
integer, intent(in), optional :: keylength
integer :: keylength_
if ( present(keylength) ) then
keylength_ = keylength
else
keylength_ = default_keylength
endif
!
! Allocate the list of keywords
!
if ( allocated(this%keyword) ) then
deallocate( this%keyword )
endif
allocate( character(len=keylength_):: this%keyword(initial_size) )
this%lastindex = 0
this%keylength = keylength_
end subroutine init_keyindex
! get_index_from_list --
! Look up the keyword in the list and return its index
!
! Arguments:
! this Keyindex object
! keyword Keyword to be looked up
!
! Returns:
! Index in the list
!
! Note:
! If the keyword does not yet exist, add it to the list
!
integer function get_index_from_list( this, keyword )
class(keyindex), intent(inout) :: this
character(len=*), intent(in) :: keyword
integer :: i
character(len=this%keylength), dimension(:), allocatable :: newlist
if ( .not. allocated(this%keyword) ) then
call this%init( 50 )
endif
get_index_from_list = 0
do i = 1,this%lastindex
if ( this%keyword(i) == keyword ) then
get_index_from_list = i
exit
endif
enddo
!
! Do we need to add it?
!
if ( get_index_from_list == 0 ) then
if ( size(this%keyword) <= this%lastindex ) then
!
! Allocate a larger list
!
allocate( character(len=this%keylength):: newlist(2*size(this%keyword)) )
newlist(1:size(this%keyword)) = this%keyword
call move_alloc( newlist, this%keyword )
endif
get_index_from_list = this%lastindex + 1
this%lastindex = get_index_from_list
this%keyword(get_index_from_list) = keyword
endif
end function get_index_from_list
! get_keyword_from_list --
! Look up the keyword in the list by the given index
!
! Arguments:
! this Keyindex object
! idx Index of the keyword
!
! Returns:
! Keyword as stored in the list
!
! Note:
! If the index does not exist, an empty string is returned
!
function get_keyword_from_list( this, idx )
class(keyindex), intent(inout) :: this
integer, intent(in) :: idx
character(len=this%keylength) :: get_keyword_from_list
get_keyword_from_list = ' '
if ( idx >= 1 .and. idx <= this%lastindex ) then
get_keyword_from_list = this%keyword(idx)
endif
end function get_keyword_from_list
! has_keyword_in_list --
! Look up whether the keyword is stored in the list or not
!
! Arguments:
! this Keyindex object
! keyword Keyword to be looked up
!
! Returns:
! True if the keyword is in the list or false if not
!
logical function has_keyword_in_list( this, keyword )
class(keyindex), intent(inout) :: this
character(len=*), intent(in) :: keyword
integer :: i
has_keyword_in_list = .false.
do i = 1,this%lastindex
if ( this%keyword(i) == keyword ) then
has_keyword_in_list = .true.
exit
endif
enddo
end function has_keyword_in_list
end module keyindices
use keyindices
type(keyindex) :: idx
call idx%init (3, 8)
if (idx%get_index ("one") .ne. 1) stop 1
if (idx%get_index ("two") .ne. 2) stop 2
if (idx%get_index ("three") .ne. 3) stop 3
! Check that new span is generated as list is extended.
if (idx%get_index ("four") .ne. 4) stop 4
if (idx%get_index ("five") .ne. 5) stop 5
if (idx%get_index ("six") .ne. 6) stop 6
! Search by keyword
if (.not.idx%has_key ("four")) stop 7
if (idx%has_key ("seven")) stop 8
! Search by index
if (idx%get_key (4) .ne. "four") stop 9
if (idx%get_key (10) .ne. "") stop 10
end

71
gcc/testsuite/gfortran.dg/deferred_type_component_3.f90 Normal file
View file

@ -0,0 +1,71 @@
! { dg-do run }
!
! Test the fix for PR87151 by exercising deferred length character
! array components.
!
! Based on the contribution by Valery Weber <valeryweber@hotmail.com>
!
module bvec
type, public :: bvec_t
private
character(:), dimension(:), allocatable :: vc
contains
PROCEDURE, PASS :: create
PROCEDURE, PASS :: test_bvec
PROCEDURE, PASS :: delete
end type bvec_t
contains
subroutine create (this, switch)
class(bvec_t), intent(inout) :: this
logical :: switch
if (switch) then
allocate (character(2)::this%vc(3))
if (len (this%vc) .ne. 2) stop 1 ! The orignal problem. Gave 0.
! Check that reallocation on assign does what it should do as required by
! F2003 7.4.1.3. ie. reallocation occurs because LEN has changed.
this%vc = ['abcd','efgh','ijkl']
else
allocate (this%vc, source = ['abcd','efgh','ijkl'])
endif
end subroutine create
subroutine test_bvec (this)
class(bvec_t), intent(inout) :: this
character(20) :: buffer
if (allocated (this%vc)) then
if (len (this%vc) .ne. 4) stop 2
if (size (this%vc) .ne. 3) stop 3
! Check array referencing and scalarized array referencing
if (this%vc(2) .ne. 'efgh') stop 4
if (any (this%vc .ne. ['abcd','efgh','ijkl'])) stop 5
! Check full array io
write (buffer, *) this%vc
if (trim (buffer(2:)) .ne. 'abcdefghijkl') stop 6
! Make sure that substrings work correctly
write (buffer, *) this%vc(:)(2:3)
if (trim (buffer(2:)) .ne. 'bcfgjk') stop 7
write (buffer, *) this%vc(2:)(2:3)
if (trim (buffer(2:)) .ne. 'fgjk') stop 8
endif
end subroutine test_bvec
subroutine delete (this)
class(bvec_t), intent(inout) :: this
if (allocated (this%vc)) then
deallocate (this%vc)
endif
end subroutine delete
end module bvec
program test
use bvec
type(bvec_t) :: a
call a%create (.false.)
call a%test_bvec
call a%delete
call a%create (.true.)
call a%test_bvec
call a%delete
end program test