From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1431) id D17F13857B9B; Thu, 8 Jun 2023 06:11:40 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org D17F13857B9B DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1686204700; bh=Oj8O6yzr0qz07hhAM+I4aU3yd3bsX7KKZCVwuCK+dw4=; h=From:To:Subject:Date:From; b=dH1tI7vFCBvBJh+8u7+SIdfQOVWThpY+JmdUbq9HNWDGxXioFQbnOjS7OZ8zvVuoh TMxyLjUMVHFX8jT9I9x4HXJusgivBqfDVQgGVfc8nVeA3RRkSuCwKQXAt5z7gHhOL5 EfZaAQIpu9Ifgr7DmuzUN7dL8Y9VCOO2ZSydy5IE= MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Paul Thomas To: gcc-cvs@gcc.gnu.org Subject: [gcc r14-1629] Fortran: Fix some more blockers in associate meta-bug [PR87477] X-Act-Checkin: gcc X-Git-Author: Paul Thomas X-Git-Refname: refs/heads/master X-Git-Oldrev: 8b327e0e273d525275e6236d1048192284779732 X-Git-Newrev: d08f2e4f74583e27002368989bba197f8eb7f6d2 Message-Id: <20230608061140.D17F13857B9B@sourceware.org> Date: Thu, 8 Jun 2023 06:11:40 +0000 (GMT) List-Id: https://gcc.gnu.org/g:d08f2e4f74583e27002368989bba197f8eb7f6d2 commit r14-1629-gd08f2e4f74583e27002368989bba197f8eb7f6d2 Author: Paul Thomas Date: Thu Jun 8 07:11:32 2023 +0100 Fortran: Fix some more blockers in associate meta-bug [PR87477] 2023-06-08 Paul Thomas gcc/fortran PR fortran/87477 PR fortran/99350 PR fortran/107821 PR fortran/109451 * decl.cc (char_len_param_value): Simplify a copy of the expr and replace the original if there is no error. * gfortran.h : Remove the redundant field 'rankguessed' from 'gfc_association_list'. * resolve.cc (resolve_assoc_var): Remove refs to 'rankguessed'. (resolve_variable): Associate names with constant or structure constructor targets cannot have array refs. * trans-array.cc (gfc_conv_expr_descriptor): Guard expression character length backend decl before using it. Suppress the assignment if lhs equals rhs. * trans-io.cc (gfc_trans_transfer): Scalarize transfer of associate variables pointing to a variable. Add comment. * trans-stmt.cc (trans_associate_var): Remove requirement that the character length be deferred before assigning the value returned by gfc_conv_expr_descriptor. Also, guard the backend decl before testing with VAR_P. gcc/testsuite/ PR fortran/99350 * gfortran.dg/pr99350.f90 : New test. PR fortran/107821 * gfortran.dg/associate_5.f03 : Changed error message. * gfortran.dg/pr107821.f90 : New test. PR fortran/109451 * gfortran.dg/associate_61.f90 : New test Diff: --- gcc/fortran/decl.cc | 9 ++--- gcc/fortran/gfortran.h | 3 -- gcc/fortran/resolve.cc | 15 ++++++--- gcc/fortran/trans-array.cc | 12 ++++++- gcc/fortran/trans-io.cc | 4 +++ gcc/fortran/trans-stmt.cc | 6 ++-- gcc/testsuite/gfortran.dg/associate_5.f03 | 2 +- gcc/testsuite/gfortran.dg/associate_61.f90 | 54 ++++++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/pr107821.f90 | 9 +++++ gcc/testsuite/gfortran.dg/pr99350.f90 | 16 +++++++++ 10 files changed, 113 insertions(+), 17 deletions(-) diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index f5d39e2a3d8..d09c8bc97d9 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -1056,6 +1056,7 @@ static match char_len_param_value (gfc_expr **expr, bool *deferred) { match m; + gfc_expr *p; *expr = NULL; *deferred = false; @@ -1081,10 +1082,10 @@ char_len_param_value (gfc_expr **expr, bool *deferred) if (!gfc_expr_check_typed (*expr, gfc_current_ns, false)) return MATCH_ERROR; - /* If gfortran gets an EXPR_OP, try to simplify it. This catches things - like CHARACTER(([1])). */ - if ((*expr)->expr_type == EXPR_OP) - gfc_simplify_expr (*expr, 1); + /* Try to simplify the expression to catch things like CHARACTER(([1])). */ + p = gfc_copy_expr (*expr); + if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1)) + gfc_replace_expr (*expr, p); if ((*expr)->expr_type == EXPR_FUNCTION) { diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 33ca4986f69..a58c60e9828 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2922,9 +2922,6 @@ typedef struct gfc_association_list for memory handling. */ unsigned dangling:1; - /* True when the rank of the target expression is guessed during parsing. */ - unsigned rankguessed:1; - char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symtree *st; /* Symtree corresponding to name. */ locus where; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index fd059dddf05..50b49d0cb83 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -5872,7 +5872,15 @@ resolve_variable (gfc_expr *e) if (sym->ts.type == BT_CLASS) gfc_fix_class_refs (e); if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) - return false; + { + /* Unambiguously scalar! */ + if (sym->assoc->target + && (sym->assoc->target->expr_type == EXPR_CONSTANT + || sym->assoc->target->expr_type == EXPR_STRUCTURE)) + gfc_error ("Scalar variable %qs has an array reference at %L", + sym->name, &e->where); + return false; + } else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY)) { /* This can happen because the parser did not detect that the @@ -9279,7 +9287,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) gfc_array_spec *as; /* The rank may be incorrectly guessed at parsing, therefore make sure it is corrected now. */ - if (sym->ts.type != BT_CLASS && (!sym->as || sym->assoc->rankguessed)) + if (sym->ts.type != BT_CLASS && !sym->as) { if (!sym->as) sym->as = gfc_get_array_spec (); @@ -9292,8 +9300,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) sym->attr.codimension = 1; } else if (sym->ts.type == BT_CLASS - && CLASS_DATA (sym) - && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed)) + && CLASS_DATA (sym) && !CLASS_DATA (sym)->as) { if (!CLASS_DATA (sym)->as) CLASS_DATA (sym)->as = gfc_get_array_spec (); diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 1c7ea900ea1..e1c75e9fe02 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -7934,7 +7934,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) else tmp = se->string_length; - if (expr->ts.deferred && VAR_P (expr->ts.u.cl->backend_decl)) + if (expr->ts.deferred && expr->ts.u.cl->backend_decl + && VAR_P (expr->ts.u.cl->backend_decl)) gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp); else expr->ts.u.cl->backend_decl = tmp; @@ -7999,6 +8000,15 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) } } + if (expr->ts.type == BT_CHARACTER + && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm))))) + { + tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm))); + gfc_add_modify (&loop.pre, elem_len, + fold_convert (TREE_TYPE (elem_len), + gfc_get_array_span (desc, expr))); + } + /* Set the span field. */ tmp = NULL_TREE; if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc index 0c0e3332778..e36ad0e3db4 100644 --- a/gcc/fortran/trans-io.cc +++ b/gcc/fortran/trans-io.cc @@ -2620,9 +2620,13 @@ gfc_trans_transfer (gfc_code * code) gcc_assert (ref && ref->type == REF_ARRAY); } + /* These expressions don't always have the dtype element length set + correctly, rendering them useless for array transfer. */ if (expr->ts.type != BT_CLASS && expr->expr_type == EXPR_VARIABLE && ((expr->symtree->n.sym->ts.type == BT_DERIVED && expr->ts.deferred) + || (expr->symtree->n.sym->assoc + && expr->symtree->n.sym->assoc->variable) || gfc_expr_attr (expr).pointer)) goto scalarize; diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index b5b82941b41..dcabeca0078 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -1930,15 +1930,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_conv_expr_descriptor (&se, e); if (sym->ts.type == BT_CHARACTER - && sym->ts.deferred && !sym->attr.select_type_temporary + && sym->ts.u.cl->backend_decl && VAR_P (sym->ts.u.cl->backend_decl) && se.string_length != sym->ts.u.cl->backend_decl) - { - gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, + gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl), se.string_length)); - } /* If we didn't already do the pointer assignment, set associate-name descriptor to the one generated for the temporary. */ diff --git a/gcc/testsuite/gfortran.dg/associate_5.f03 b/gcc/testsuite/gfortran.dg/associate_5.f03 index 64345d323f3..c91f88f4e12 100644 --- a/gcc/testsuite/gfortran.dg/associate_5.f03 +++ b/gcc/testsuite/gfortran.dg/associate_5.f03 @@ -11,7 +11,7 @@ PROGRAM main INTEGER, POINTER :: ptr ASSOCIATE (a => 5) ! { dg-error "is used as array" } - PRINT *, a(3) + PRINT *, a(3) ! { dg-error "has an array reference" } END ASSOCIATE ASSOCIATE (a => nontarget) diff --git a/gcc/testsuite/gfortran.dg/associate_61.f90 b/gcc/testsuite/gfortran.dg/associate_61.f90 new file mode 100644 index 00000000000..da5528834d7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_61.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! Test fixes for PR109451 +! Contributed by Harald Anlauf +! +program p + implicit none + character(4) :: c(2) = ["abcd","efgh"] + call dcs3 (c) + call dcs0 (c) +contains + subroutine dcs3 (a) + character(len=*), intent(in) :: a(:) + character(:), allocatable :: b(:) + b = a(:) + call test (b, a, 1) + associate (q => b(:)) ! no ICE but print repeated first element + call test (q, a, 2) + print *, q ! Checked with dg-output + q = q(:)(2:3) + end associate + call test (b, ["bc ","fg "], 4) + b = a(:) + associate (q => b(:)(:)) ! ICE + call test (q, a, 3) + associate (r => q(:)(1:3)) + call test (r, a(:)(1:3), 5) + end associate + end associate + associate (q => b(:)(2:3)) + call test (q, a(:)(2:3), 6) + end associate + end subroutine dcs3 + +! The associate vars in dsc0 had string length not set + subroutine dcs0 (a) + character(len=*), intent(in) :: a(:) + associate (q => a) + call test (q, a, 7) + end associate + associate (q => a(:)) + call test (q, a, 8) + end associate + associate (q => a(:)(:)) + call test (q, a, 9) + end associate + end subroutine dcs0 + + subroutine test (x, y, i) + character(len=*), intent(in) :: x(:), y(:) + integer, intent(in) :: i + if (any (x .ne. y)) stop i + end subroutine test +end program p +! { dg-output " abcdefgh" } diff --git a/gcc/testsuite/gfortran.dg/pr107821.f90 b/gcc/testsuite/gfortran.dg/pr107821.f90 new file mode 100644 index 00000000000..5d86997d91f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr107821.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! Contributed by Gerhard Steinmetz +! +program p + associate (a => 1) + print *, [character((a(1))) :: '1'] ! { dg-error "has an array reference" } + end associate +end diff --git a/gcc/testsuite/gfortran.dg/pr99350.f90 b/gcc/testsuite/gfortran.dg/pr99350.f90 new file mode 100644 index 00000000000..7f751b9fdcc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr99350.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! Contributed by Gerhard Steinmetz +! +program p + type t + character(:), pointer :: a + end type + type(t) :: z + character((0.)/0), target :: c = 'abc' ! { dg-error "Division by zero" } + z%a => c +! The associate statement was not needed to trigger the ICE. + associate (y => z%a) + print *, y + end associate +end