From 89c1cf2695c796aaf9610615e9f1ecd1f2198da1 Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Mon, 24 Dec 2018 18:26:25 +0000 Subject: re PR fortran/45513 (BOZ kinds differently handled, F2008: BOZ in bit intrinsics) 2018-12-24 Steven G. Kargl PR fortran/45513 PR fortran/81509 * check.c: Rename function gfc_check_iand to gfc_check_iand_ieor_ior. * check.c (boz_args_check): New function. Check I and J not both BOZ. (gfc_check_dshift,gfc_check_iand_ieor_ior, gfc_check_ishft, gfc_check_and, gfc_check_merge_bits): Use it. * check.c (gfc_check_iand_ieor_ior): Force conversion of BOZ to kind type of other agrument. Remove silly GNU extension. (gfc_check_ieor, gfc_check_ior): Delete now unused functions. * intrinsic.c (add_functions): Use gfc_check_iand_ieor_ior. Wrap long line. * intrinsic.h: Rename gfc_check_iand to gfc_check_iand_ieor_ior. Delete prototype for bool gfc_check_ieor and gfc_check_ior * intrinsic.texi: Update documentation for boz-literal-constant. 2018-12-24 Steven G. Kargl PR fortran/45513 PR fortran/81509 * gfortran.dg/graphite/id-26.f03: Fix non-conforming use of IAND. * gfortran.dg/pr81509_1.f90: New test. * gfortran.dg/pr81509_2.f90: New test. From-SVN: r267415 --- gcc/fortran/check.c | 90 ++++++++++++++++++++++++----------------------------- 1 file changed, 40 insertions(+), 50 deletions(-) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 43b0713..2f63c3e 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2168,6 +2168,21 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y) } +static bool +boz_args_check(gfc_expr *i, gfc_expr *j) +{ + if (i->is_boz && j->is_boz) + { + gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ " + "literal constants", gfc_current_intrinsic, &i->where, + &j->where); + return false; + + } + return true; +} + + bool gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) { @@ -2177,12 +2192,8 @@ gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) if (!type_check (j, 1, BT_INTEGER)) return false; - if (i->is_boz && j->is_boz) - { - gfc_error ("% at %L and %' at %L cannot both be BOZ literal " - "constants", &i->where, &j->where); - return false; - } + if (!boz_args_check (i, j)) + return false; if (!i->is_boz && !j->is_boz && !same_type_check (i, 0, j, 1)) return false; @@ -2482,7 +2493,7 @@ gfc_check_i (gfc_expr *i) bool -gfc_check_iand (gfc_expr *i, gfc_expr *j) +gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j) { if (!type_check (i, 0, BT_INTEGER)) return false; @@ -2490,10 +2501,16 @@ gfc_check_iand (gfc_expr *i, gfc_expr *j) if (!type_check (j, 1, BT_INTEGER)) return false; + if (!boz_args_check (i, j)) + return false; + + if (i->is_boz) i->ts.kind = j->ts.kind; + if (j->is_boz) j->ts.kind = i->ts.kind; + if (i->ts.kind != j->ts.kind) { - if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", - &i->where)) + gfc_error ("Arguments of %qs have different kind type parameters " + "at %L", gfc_current_intrinsic, &i->where); return false; } @@ -2608,26 +2625,6 @@ gfc_check_idnint (gfc_expr *a) bool -gfc_check_ieor (gfc_expr *i, gfc_expr *j) -{ - if (!type_check (i, 0, BT_INTEGER)) - return false; - - if (!type_check (j, 1, BT_INTEGER)) - return false; - - if (i->ts.kind != j->ts.kind) - { - if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", - &i->where)) - return false; - } - - return true; -} - - -bool gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, gfc_expr *kind) { @@ -2680,27 +2677,6 @@ gfc_check_intconv (gfc_expr *x) return true; } - -bool -gfc_check_ior (gfc_expr *i, gfc_expr *j) -{ - if (!type_check (i, 0, BT_INTEGER)) - return false; - - if (!type_check (j, 1, BT_INTEGER)) - return false; - - if (i->ts.kind != j->ts.kind) - { - if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", - &i->where)) - return false; - } - - return true; -} - - bool gfc_check_ishft (gfc_expr *i, gfc_expr *shift) { @@ -3584,6 +3560,12 @@ gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) if (!type_check (j, 1, BT_INTEGER)) return false; + if (!boz_args_check (i, j)) + return false; + + if (i->is_boz) i->ts.kind = j->ts.kind; + if (j->is_boz) j->ts.kind = i->ts.kind; + if (!type_check (mask, 2, BT_INTEGER)) return false; @@ -3593,6 +3575,8 @@ gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) if (!same_type_check (i, 0, mask, 2)) return false; + if (mask->is_boz) mask->ts.kind = i->ts.kind; + return true; } @@ -6719,6 +6703,12 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) if (!scalar_check (j, 1)) return false; + if (!boz_args_check (i, j)) + return false; + + if (i->is_boz) i->ts.kind = j->ts.kind; + if (j->is_boz) j->ts.kind = i->ts.kind; + return true; } -- cgit v1.1