diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f8038837bdf..7c63b51b5c1 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2004-12-12 Steven G. Kargl + + PR fortran/16581 + * check.c (gfc_check_iand, gfc_check_ibclr, gfc_check_ibits, + gfc_check_ibset, gfc_check_ieor, gfc_check_ior): Remove default + integer kind check; Issue error for -std=f95 when needed. + * intrinsic.c (add_functions): Change ieor from GFC_STD_GNU to + GFC_STD_F95. + * iresolve.c (gfc_resolve_iand, gfc_resolve_ieor, gfc_resolve_ior): + Promote arguments to same kind. + 2004-12-12 Steven G. Kargl Paul Brook diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 0b4f92e6c6e..3d67b1c4d1a 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -809,13 +809,19 @@ try gfc_check_iand (gfc_expr * i, gfc_expr * j) { - if (type_check (i, 0, BT_INTEGER) == FAILURE - || type_check (j, 1, BT_INTEGER) == FAILURE) + if (type_check (i, 0, BT_INTEGER) == FAILURE) return FAILURE; - if (same_type_check (i, 0, j, 1) == FAILURE) + if (type_check (j, 1, BT_INTEGER) == FAILURE) return FAILURE; + if (i->ts.kind != j->ts.kind) + { + if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L", + &i->where) == FAILURE) + return FAILURE; + } + return SUCCESS; } @@ -824,9 +830,10 @@ try gfc_check_ibclr (gfc_expr * i, gfc_expr * pos) { - if (type_check (i, 0, BT_INTEGER) == FAILURE - || type_check (pos, 1, BT_INTEGER) == FAILURE - || kind_value_check (pos, 1, gfc_default_integer_kind) == FAILURE) + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (pos, 1, BT_INTEGER) == FAILURE) return FAILURE; return SUCCESS; @@ -837,10 +844,13 @@ try gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len) { - if (type_check (i, 0, BT_INTEGER) == FAILURE - || type_check (pos, 1, BT_INTEGER) == FAILURE - || kind_value_check (pos, 1, gfc_default_integer_kind) == FAILURE - || type_check (len, 2, BT_INTEGER) == FAILURE) + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (pos, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (len, 2, BT_INTEGER) == FAILURE) return FAILURE; return SUCCESS; @@ -851,9 +861,10 @@ try gfc_check_ibset (gfc_expr * i, gfc_expr * pos) { - if (type_check (i, 0, BT_INTEGER) == FAILURE - || type_check (pos, 1, BT_INTEGER) == FAILURE - || kind_value_check (pos, 1, gfc_default_integer_kind) == FAILURE) + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (pos, 1, BT_INTEGER) == FAILURE) return FAILURE; return SUCCESS; @@ -875,13 +886,19 @@ try gfc_check_ieor (gfc_expr * i, gfc_expr * j) { - if (type_check (i, 0, BT_INTEGER) == FAILURE - || type_check (j, 1, BT_INTEGER) == FAILURE) + if (type_check (i, 0, BT_INTEGER) == FAILURE) return FAILURE; - if (same_type_check (i, 0, j, 1) == FAILURE) + if (type_check (j, 1, BT_INTEGER) == FAILURE) return FAILURE; + if (i->ts.kind != j->ts.kind) + { + if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L", + &i->where) == FAILURE) + return FAILURE; + } + return SUCCESS; } @@ -924,13 +941,19 @@ try gfc_check_ior (gfc_expr * i, gfc_expr * j) { - if (type_check (i, 0, BT_INTEGER) == FAILURE - || type_check (j, 1, BT_INTEGER) == FAILURE) + if (type_check (i, 0, BT_INTEGER) == FAILURE) return FAILURE; - if (same_type_check (i, 0, j, 1) == FAILURE) + if (type_check (j, 1, BT_INTEGER) == FAILURE) return FAILURE; + if (i->ts.kind != j->ts.kind) + { + if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L", + &i->where) == FAILURE) + return FAILURE; + } + return SUCCESS; } diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index a079e86374d..2aa3f294ac8 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1375,11 +1375,11 @@ add_functions (void) make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77); - add_sym_2 ("ieor", 1, 1, BT_INTEGER, di, GFC_STD_GNU, + add_sym_2 ("ieor", 1, 1, BT_INTEGER, di, GFC_STD_F95, gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor, i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); - make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_GNU); + make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95); add_sym_3 ("index", 1, 1, BT_INTEGER, di, GFC_STD_F77, gfc_check_index, gfc_simplify_index, NULL, diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 7a4602872f1..d942fdd36d4 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -619,8 +619,18 @@ gfc_resolve_getuid (gfc_expr * f) } void -gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j ATTRIBUTE_UNUSED) +gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j) { + /* If the kind of i and j are different, then g77 cross-promoted the + kinds to the largest value. The Fortran 95 standard requires the + kinds to match. */ + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i,j)) + gfc_convert_type(j, &i->ts, 2); + else + gfc_convert_type(i, &j->ts, 2); + } f->ts = i->ts; f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind); @@ -676,9 +686,18 @@ gfc_resolve_idnint (gfc_expr * f, gfc_expr * a) void -gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, - gfc_expr * j ATTRIBUTE_UNUSED) +gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j) { + /* If the kind of i and j are different, then g77 cross-promoted the + kinds to the largest value. The Fortran 95 standard requires the + kinds to match. */ + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i,j)) + gfc_convert_type(j, &i->ts, 2); + else + gfc_convert_type(i, &j->ts, 2); + } f->ts = i->ts; f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind); @@ -686,9 +705,18 @@ gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, void -gfc_resolve_ior (gfc_expr * f, gfc_expr * i, - gfc_expr * j ATTRIBUTE_UNUSED) +gfc_resolve_ior (gfc_expr * f, gfc_expr * i, gfc_expr * j) { + /* If the kind of i and j are different, then g77 cross-promoted the + kinds to the largest value. The Fortran 95 standard requires the + kinds to match. */ + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i,j)) + gfc_convert_type(j, &i->ts, 2); + else + gfc_convert_type(i, &j->ts, 2); + } f->ts = i->ts; f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind);