From e8c78b3a0c7be7020b77f9a8ef04e970b391f1aa Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Fri, 11 Oct 2019 18:05:35 +0000 Subject: [PATCH] re PR fortran/91649 (ICE in gfc_resolve_findloc, at fortran/iresolve.c:1827) 2019-10-11 Steven G. Kargl PR fortran/91649 check.c (gfc_check_findloc): Additional checking for valid arguments 2019-10-11 Steven G. Kargl PR fortran/91649 * gfortran.dg/pr91649.f90: New test. From-SVN: r276900 --- gcc/fortran/ChangeLog | 5 +++++ gcc/fortran/check.c | 31 +++++++++++++++++---------- gcc/testsuite/ChangeLog | 5 +++++ gcc/testsuite/gfortran.dg/pr91649.f90 | 23 ++++++++++++++++++++ 4 files changed, 53 insertions(+), 11 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr91649.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7819bd4001a..82164d713ae 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,8 @@ +2019-10-11 Steven G. Kargl + + PR fortran/91649 + check.c (gfc_check_findloc): Additional checking for valid arguments + 2019-10-11 Steven G. Kargl PR fortran/91715 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index f66ed93f9f4..d2a4949e12b 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -3921,26 +3921,27 @@ bool gfc_check_findloc (gfc_actual_arglist *ap) { gfc_expr *a, *v, *m, *d, *k, *b; + bool a1, v1; a = ap->expr; if (!intrinsic_type_check (a, 0) || !array_check (a, 0)) return false; v = ap->next->expr; - if (!scalar_check (v,1)) + if (!intrinsic_type_check (v, 1) || !scalar_check (v,1)) return false; - /* Check if the type is compatible. */ + /* Check if the type are both logical. */ + a1 = a->ts.type == BT_LOGICAL; + v1 = v->ts.type == BT_LOGICAL; + if ((a1 && !v1) || (!a1 && v1)) + goto incompat; - if ((a->ts.type == BT_LOGICAL && v->ts.type != BT_LOGICAL) - || (a->ts.type != BT_LOGICAL && v->ts.type == BT_LOGICAL)) - { - gfc_error ("Argument %qs of %qs intrinsic at %L must be in type " - "conformance to argument %qs at %L", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &a->where, - gfc_current_intrinsic_arg[1]->name, &v->where); - } + /* Check if the type are both character. */ + a1 = a->ts.type == BT_CHARACTER; + v1 = v->ts.type == BT_CHARACTER; + if ((a1 && !v1) || (!a1 && v1)) + goto incompat; d = ap->next->next->expr; m = ap->next->next->next->expr; @@ -3988,6 +3989,14 @@ gfc_check_findloc (gfc_actual_arglist *ap) return false; return true; + +incompat: + gfc_error ("Argument %qs of %qs intrinsic at %L must be in type " + "conformance to argument %qs at %L", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &a->where, + gfc_current_intrinsic_arg[1]->name, &v->where); + return false; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b11a1bf7d7d..cdc717945be 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-10-11 Steven G. Kargl + + PR fortran/91649 + * gfortran.dg/pr91649.f90: New test. + 2019-10-11 Steven G. Kargl PR fortran/91715 diff --git a/gcc/testsuite/gfortran.dg/pr91649.f90 b/gcc/testsuite/gfortran.dg/pr91649.f90 new file mode 100644 index 00000000000..0e6acb9ac8d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr91649.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! PR fortran/91649 +! Code originally contributed by Gerhard Steinmetz +subroutine p + logical :: back = .true. + integer :: x(1) = findloc([1, 2, 1], '1', back=back) ! { dg-error "must be in type conformance" } + print *, x +end + +subroutine q + type t + end type + logical :: back = .false. + integer :: x(1) = findloc([1, 2, 1], t(), back=back) ! { dg-error "must be of intrinsic type" } + print *, x +end + +subroutine s + character(4) :: c = '1234' + integer :: x(1) = findloc([1, 2, 1], c, back=.true.) ! { dg-error "must be in type conformance" } + print *, x +end + -- 2.30.2