+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
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)
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);
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
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)
{
tree offset;
int full;
bool subref_array_target = false;
+ bool deferred_array_component = false;
gfc_expr *arg, *ss_expr;
if (se->want_coarray)
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;
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;
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);
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)
{
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);
/* 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);
+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.
--- /dev/null
+! { 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
--- /dev/null
+! { 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
\ No newline at end of file
--- /dev/null
+! { 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
projects / gcc.git / commitdiff