From: Paul Richard Thomas <paul.richard.thomas@gmail.com>
To: "fortran@gcc.gnu.org" <fortran@gcc.gnu.org>,
gcc-patches <gcc-patches@gcc.gnu.org>
Subject: [Patch, fortran] PR87151 - allocating array of character
Date: Sun, 07 Oct 2018 18:01:00 -0000 [thread overview]
Message-ID: <CAGkQGi+iPRK6VzXNsBALNbyCeYOrKezEtUhFJ4i8mvjku-VQCg@mail.gmail.com> (raw)
[-- Attachment #1: Type: text/plain, Size: 1121 bytes --]
This turned out to be rather more than the allocation... The ChangeLog
and the patch tell the story well enough.
Bootstraps and regtests on FC28/x86_64 - OK for trunk and later for 8-branch?
Cheers
Paul
2018-10-07 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.
2018-10-07 Paul Thomas <pault@gcc.gnu.org>
PR fortran/87151
* gfortran.dg/deferred_type_component_3.f90: New test.
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 9974 bytes --]
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 264906)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_get_array_span (tree desc, gfc_expr
*** 853,859 ****
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)
{
if (expr->expr_type == EXPR_VARIABLE
&& expr->ts.type == BT_CHARACTER)
--- 853,860 ----
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
! || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)))))
{
if (expr->expr_type == EXPR_VARIABLE
&& expr->ts.type == BT_CHARACTER)
*************** gfc_array_init_size (tree descriptor, in
*** 5366,5371 ****
--- 5367,5394 ----
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);
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 5774,5789 ****
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);
! }
gfc_init_block (&set_descriptor_block);
/* Take the corank only from the actual ref and not from the coref. The
--- 5797,5807 ----
if (expr->ts.type == BT_CHARACTER
&& TREE_CODE (se->string_length) == COMPONENT_REF
! && 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
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 7053,7058 ****
--- 7071,7077 ----
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_expr_descriptor (gfc_se *se, gf
*** 7092,7097 ****
--- 7111,7124 ----
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;
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 7140,7147 ****
se->expr = desc;
}
! if (expr->ts.type == BT_CHARACTER)
se->string_length = gfc_get_expr_charlen (expr);
gfc_free_ss_chain (ss);
return;
--- 7167,7178 ----
se->expr = desc;
}
! 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;
*************** gfc_alloc_allocatable_for_assignment (gf
*** 9797,9804 ****
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);
else
cond_null= gfc_evaluate_now (cond_null, &fblock);
--- 9828,9842 ----
cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
array1, build_int_cst (TREE_TYPE (array1), 0));
! 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_alloc_allocatable_for_assignment (gf
*** 10024,10029 ****
--- 10062,10073 ----
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)
{
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10037,10042 ****
--- 10081,10090 ----
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);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 264906)
--- gcc/fortran/trans-intrinsic.c (working copy)
*************** gfc_conv_intrinsic_len (gfc_se * se, gfc
*** 6404,6410 ****
/* 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);
--- 6404,6409 ----
Index: gcc/testsuite/gfortran.dg/deferred_type_component_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_type_component_3.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/deferred_type_component_3.f90 (working copy)
***************
*** 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
next reply other threads:[~2018-10-07 18:01 UTC|newest]
Thread overview: 4+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-10-07 18:01 Paul Richard Thomas [this message]
2018-10-08 22:16 ` Thomas Koenig
2018-10-08 9:09 Dominique d'Humières
2018-10-08 13:23 ` Paul Richard Thomas
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=CAGkQGi+iPRK6VzXNsBALNbyCeYOrKezEtUhFJ4i8mvjku-VQCg@mail.gmail.com \
--to=paul.richard.thomas@gmail.com \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).