diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/fortran/check.c | 31 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pr91649.f90 | 23 |
4 files changed, 53 insertions, 11 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7819bd4..82164d7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,10 @@ 2019-10-11 Steven G. Kargl <kargl@gcc.gnu.org> + PR fortran/91649 + check.c (gfc_check_findloc): Additional checking for valid arguments + +2019-10-11 Steven G. Kargl <kargl@gcc.gnu.org> + PR fortran/91715 * decl.c (gfc_match_prefix): If matching a type-spec returns an error, it's an error so re-act correctly. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index f66ed93..d2a4949 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 b11a1bf..cdc7179 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,10 @@ 2019-10-11 Steven G. Kargl <kargl@gcc.gnu.org> + PR fortran/91649 + * gfortran.dg/pr91649.f90: New test. + +2019-10-11 Steven G. Kargl <kargl@gcc.gnu.org> + PR fortran/91715 * gfortran.dg/function_kinds_5.f90: Prune run-on error. * gfortran.dg/pr85543.f90: Ditto. diff --git a/gcc/testsuite/gfortran.dg/pr91649.f90 b/gcc/testsuite/gfortran.dg/pr91649.f90 new file mode 100644 index 0000000..0e6acb9 --- /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 + |