From: Steven G. Kargl Date: Fri, 11 Oct 2019 17:52:27 +0000 (+0000) Subject: re PR fortran/92018 (ICE in gfc_conv_constant_to_tree, at fortran/trans-const.c:370) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=405e87e8259b6e70bdf31544bb0e5d147e6f301a;p=gcc.git re PR fortran/92018 (ICE in gfc_conv_constant_to_tree, at fortran/trans-const.c:370) 2019-10-11 Steven G. Kargl PR fortran/92018 * check.c (reset_boz): New function. (illegal_boz_arg, boz_args_check, gfc_check_complex, gfc_check_float, gfc_check_transfer): Use it. (gfc_check_dshift): Use reset_boz, and re-arrange the checking to help suppress possible run-on errors. (gfc_check_and): Restore checks for valid argument types. Use reset_boz, and re-arrange the checking to help suppress possible un-on errors. * resolve.c (resolve_function): Actual arguments cannot be BOZ in a function reference. 2019-10-11 Steven G. Kargl PR fortran/92018 * gfortran.dg/gnu_logical_2.f90: Update dg-error regex. * gfortran.dg/pr81509_2.f90: Ditto. * gfortran.dg/pr92018.f90: New test. From-SVN: r276898 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 47b20614cd7..b6d97cb3c71 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2019-10-11 Steven G. Kargl + + PR fortran/92018 + * check.c (reset_boz): New function. + (illegal_boz_arg, boz_args_check, gfc_check_complex, gfc_check_float, + gfc_check_transfer): Use it. + (gfc_check_dshift): Use reset_boz, and re-arrange the checking to + help suppress possible run-on errors. + (gfc_check_and): Restore checks for valid argument types. Use + reset_boz, and re-arrange the checking to help suppress possible + run-on errors. + * resolve.c (resolve_function): Actual arguments cannot be BOZ in + a function reference. + 2019-10-11 Steven G. Kargl PR fortran/92019 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 87a81969062..f66ed93f9f4 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -34,6 +34,24 @@ along with GCC; see the file COPYING3. If not see #include "constructor.h" #include "target-memory.h" + +/* Reset a BOZ to a zero value. This is used to prevent run-on errors + from resolve.c(resolve_function). */ + +static void +reset_boz (gfc_expr *x) +{ + /* Clear boz info. */ + x->boz.rdx = 0; + x->boz.len = 0; + free (x->boz.str); + + x->ts.type = BT_INTEGER; + x->ts.kind = gfc_default_integer_kind; + mpz_init (x->value.integer); + mpz_set_ui (x->value.integer, 0); +} + /* A BOZ literal constant can appear in a limited number of contexts. gfc_invalid_boz() is a helper function to simplify error/warning generation. gfortran accepts the nonstandard 'X' for 'Z', and gfortran @@ -63,6 +81,7 @@ illegal_boz_arg (gfc_expr *x) { gfc_error ("BOZ literal constant at %L cannot be an actual argument " "to %qs", &x->where, gfc_current_intrinsic); + reset_boz (x); return true; } @@ -79,6 +98,8 @@ boz_args_check(gfc_expr *i, gfc_expr *j) gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ " "literal constants", gfc_current_intrinsic, &i->where, &j->where); + reset_boz (i); + reset_boz (j); return false; } @@ -2399,7 +2420,10 @@ gfc_check_complex (gfc_expr *x, gfc_expr *y) { if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX " "intrinsic subprogram", &x->where)) - return false; + { + reset_boz (x); + return false; + } if (y->ts.type == BT_INTEGER && !gfc_boz2int (x, y->ts.kind)) return false; if (y->ts.type == BT_REAL && !gfc_boz2real (x, y->ts.kind)) @@ -2410,7 +2434,10 @@ gfc_check_complex (gfc_expr *x, gfc_expr *y) { if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX " "intrinsic subprogram", &y->where)) - return false; + { + reset_boz (y); + return false; + } if (x->ts.type == BT_INTEGER && !gfc_boz2int (y, x->ts.kind)) return false; if (x->ts.type == BT_REAL && !gfc_boz2real (y, x->ts.kind)) @@ -2674,20 +2701,32 @@ gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) if (!boz_args_check (i, j)) return false; - /* If i is BOZ and j is integer, convert i to type of j. */ - if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER - && !gfc_boz2int (i, j->ts.kind)) - return false; - - /* If j is BOZ and i is integer, convert j to type of i. */ - if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER - && !gfc_boz2int (j, i->ts.kind)) - return false; - - if (!type_check (i, 0, BT_INTEGER)) - return false; + /* If i is BOZ and j is integer, convert i to type of j. If j is not + an integer, clear the BOZ; otherwise, check that i is an integer. */ + if (i->ts.type == BT_BOZ) + { + if (j->ts.type != BT_INTEGER) + reset_boz (i); + else if (!gfc_boz2int (i, j->ts.kind)) + return false; + } + else if (!type_check (i, 0, BT_INTEGER)) + { + if (j->ts.type == BT_BOZ) + reset_boz (j); + return false; + } - if (!type_check (j, 1, BT_INTEGER)) + /* If j is BOZ and i is integer, convert j to type of i. If i is not + an integer, clear the BOZ; otherwise, check that i is an integer. */ + if (j->ts.type == BT_BOZ) + { + if (i->ts.type != BT_INTEGER) + reset_boz (j); + else if (!gfc_boz2int (j, i->ts.kind)) + return false; + } + else if (!type_check (j, 1, BT_INTEGER)) return false; if (!same_type_check (i, 0, j, 1)) @@ -2860,7 +2899,10 @@ gfc_check_float (gfc_expr *a) { if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in the " "FLOAT intrinsic subprogram", &a->where)) - return false; + { + reset_boz (a); + return false; + } if (!gfc_boz2int (a, gfc_default_integer_kind)) return false; } @@ -6126,7 +6168,11 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) if (size != NULL) { if (!type_check (size, 2, BT_INTEGER)) - return false; + { + if (size->ts.type == BT_BOZ) + reset_boz (size); + return false; + } if (!scalar_check (size, 2)) return false; @@ -7286,19 +7332,61 @@ gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status) bool gfc_check_and (gfc_expr *i, gfc_expr *j) { + if (i->ts.type != BT_INTEGER + && i->ts.type != BT_LOGICAL + && i->ts.type != BT_BOZ) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, " + "LOGICAL, or a BOZ literal constant", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &i->where); + return false; + } + + if (j->ts.type != BT_INTEGER + && j->ts.type != BT_LOGICAL + && j->ts.type != BT_BOZ) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, " + "LOGICAL, or a BOZ literal constant", + gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &j->where); + return false; + } + /* i and j cannot both be BOZ literal constants. */ if (!boz_args_check (i, j)) return false; /* If i is BOZ and j is integer, convert i to type of j. */ - if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER - && !gfc_boz2int (i, j->ts.kind)) - return false; + if (i->ts.type == BT_BOZ) + { + if (j->ts.type != BT_INTEGER) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", + gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &j->where); + reset_boz (i); + return false; + } + if (!gfc_boz2int (i, j->ts.kind)) + return false; + } /* If j is BOZ and i is integer, convert j to type of i. */ - if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER - && !gfc_boz2int (j, i->ts.kind)) - return false; + if (j->ts.type == BT_BOZ) + { + if (i->ts.type != BT_INTEGER) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &j->where); + reset_boz (j); + return false; + } + if (!gfc_boz2int (j, i->ts.kind)) + return false; + } if (!same_type_check (i, 0, j, 1, false)) return false; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 20ecafd944e..71539fed448 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3243,19 +3243,14 @@ resolve_function (gfc_expr *expr) return t; /* Walk the argument list looking for invalid BOZ. */ - if (expr->value.function.esym) - { - gfc_actual_arglist *a; - - for (a = expr->value.function.actual; a; a = a->next) - if (a->expr && a->expr->ts.type == BT_BOZ) - { - gfc_error ("A BOZ literal constant at %L cannot appear as an " - "actual argument in a function reference", - &a->expr->where); - return false; - } - } + for (arg = expr->value.function.actual; arg; arg = arg->next) + if (arg->expr && arg->expr->ts.type == BT_BOZ) + { + gfc_error ("A BOZ literal constant at %L cannot appear as an " + "actual argument in a function reference", + &arg->expr->where); + return false; + } temp = need_full_assumed_size; need_full_assumed_size = 0; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6c6a077259f..0cf04a5b3a5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2019-10-11 Steven G. Kargl + + PR fortran/92018 + * gfortran.dg/gnu_logical_2.f90: Update dg-error regex. + * gfortran.dg/pr81509_2.f90: Ditto. + * gfortran.dg/pr92018.f90: New test. + 2019-10-11 Steven G. Kargl PR fortran/92019 diff --git a/gcc/testsuite/gfortran.dg/gnu_logical_2.f90 b/gcc/testsuite/gfortran.dg/gnu_logical_2.f90 index a7b31b4a7e2..0e24c722cc6 100644 --- a/gcc/testsuite/gfortran.dg/gnu_logical_2.f90 +++ b/gcc/testsuite/gfortran.dg/gnu_logical_2.f90 @@ -7,22 +7,22 @@ print *, and(i,i) print *, and(l,l) - print *, and(i,r) ! { dg-error "must be the same type" } - print *, and(c,l) ! { dg-error "must be the same type" } + print *, and(i,r) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" } + print *, and(c,l) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" } print *, and(i,l) ! { dg-error "must be the same type" } print *, and(l,i) ! { dg-error "must be the same type" } print *, or(i,i) print *, or(l,l) - print *, or(i,r) ! { dg-error "must be the same type" } - print *, or(c,l) ! { dg-error "must be the same type" } + print *, or(i,r) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" } + print *, or(c,l) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" } print *, or(i,l) ! { dg-error "must be the same type" } print *, or(l,i) ! { dg-error "must be the same type" } print *, xor(i,i) print *, xor(l,l) - print *, xor(i,r) ! { dg-error "must be the same type" } - print *, xor(c,l) ! { dg-error "must be the same type" } + print *, xor(i,r) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" } + print *, xor(c,l) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" } print *, xor(i,l) ! { dg-error "must be the same type" } print *, xor(l,i) ! { dg-error "must be the same type" } diff --git a/gcc/testsuite/gfortran.dg/pr81509_2.f90 b/gcc/testsuite/gfortran.dg/pr81509_2.f90 index a0618cc49b2..719feb5c510 100644 --- a/gcc/testsuite/gfortran.dg/pr81509_2.f90 +++ b/gcc/testsuite/gfortran.dg/pr81509_2.f90 @@ -13,6 +13,6 @@ k = ieor(z'ade',i) k = ior(i,z'1111') k = ior(i,k) ! { dg-error "different kind type parameters" } k = and(i,k) ! { dg-error "must be the same type" } -k = and(a,z'1234') ! { dg-error "must be the same type" } +k = and(a,z'1234') ! { dg-error "must be INTEGER" } end program foo diff --git a/gcc/testsuite/gfortran.dg/pr92018.f90 b/gcc/testsuite/gfortran.dg/pr92018.f90 new file mode 100644 index 00000000000..6c90d2f6762 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr92018.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/92018 +subroutine sub (f) + integer :: f + print *, f(b'11') ! { dg-error "cannot appear as an actual" } + print *, f(o'11') ! { dg-error "cannot appear as an actual" } + print *, f(z'11') ! { dg-error "cannot appear as an actual" } +end