diff options
Diffstat (limited to 'gcc/fortran/check.c')
-rw-r--r-- | gcc/fortran/check.c | 90 |
1 files changed, 40 insertions, 50 deletions
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 ("%<I%> at %L and %<J%>' 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; } |