From 991bb832494d3e422ef703e317cd0dc21ab74ac3 Mon Sep 17 00:00:00 2001 From: Francois-Xavier Coudert Date: Sun, 27 Nov 2005 15:01:36 +0100 Subject: [PATCH] re PR fortran/23912 (MOD function requires same kind arguments) PR fortran/23912 * iresolve.c (gfc_resolve_dim, gfc_resolve_mod, gfc_resolve_modulo): When arguments have different kinds, fold the lower one to the largest kind. * check.c (gfc_check_a_p): Arguments of different kinds is not a hard error, but an extension. * simplify.c (gfc_simplify_dim, gfc_simplify_mod, gfc_simplify_modulo): When arguments have different kinds, fold the lower one to the largest kind. * gfortran.dg/modulo_1.f90: New test. From-SVN: r107566 --- gcc/fortran/ChangeLog | 12 +++++ gcc/fortran/check.c | 17 ++++++- gcc/fortran/iresolve.c | 62 ++++++++++++++++++++------ gcc/fortran/simplify.c | 16 ++++--- gcc/testsuite/ChangeLog | 5 +++ gcc/testsuite/gfortran.dg/modulo_1.f90 | 9 ++++ 6 files changed, 101 insertions(+), 20 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/modulo_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4a124d3b3ad..75fb58ae6c4 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2005-11-27 Francois-Xavier Coudert + + PR fortran/23912 + * iresolve.c (gfc_resolve_dim, gfc_resolve_mod, + gfc_resolve_modulo): When arguments have different kinds, fold + the lower one to the largest kind. + * check.c (gfc_check_a_p): Arguments of different kinds is not + a hard error, but an extension. + * simplify.c (gfc_simplify_dim, gfc_simplify_mod, + gfc_simplify_modulo): When arguments have different kinds, fold + the lower one to the largest kind. + 2005-11-21 Jakub Jelinek PR fortran/14943 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index bc757ff86b8..7b718960397 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -450,8 +450,21 @@ gfc_check_a_p (gfc_expr * a, gfc_expr * p) if (int_or_real_check (a, 0) == FAILURE) return FAILURE; - if (same_type_check (a, 0, p, 1) == FAILURE) - return FAILURE; + if (a->ts.type != p->ts.type) + { + gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must " + "have the same type", gfc_current_intrinsic_arg[0], + gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + &p->where); + return FAILURE; + } + + if (a->ts.kind != p->ts.kind) + { + if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L", + &p->where) == FAILURE) + return FAILURE; + } return SUCCESS; } diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index de3c2718956..e154a34f635 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -523,12 +523,24 @@ gfc_resolve_dble (gfc_expr * f, gfc_expr * a) void -gfc_resolve_dim (gfc_expr * f, gfc_expr * x, - gfc_expr * y ATTRIBUTE_UNUSED) +gfc_resolve_dim (gfc_expr * f, gfc_expr * a, gfc_expr * p) { - f->ts = x->ts; + f->ts.type = a->ts.type; + if (p != NULL) + f->ts.kind = gfc_kind_max (a,p); + else + f->ts.kind = a->ts.kind; + + if (p != NULL && a->ts.kind != p->ts.kind) + { + if (a->ts.kind == gfc_kind_max (a,p)) + gfc_convert_type(p, &a->ts, 2); + else + gfc_convert_type(a, &p->ts, 2); + } + f->value.function.name = - gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); + gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind); } @@ -1179,23 +1191,47 @@ gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim, void -gfc_resolve_mod (gfc_expr * f, gfc_expr * a, - gfc_expr * p ATTRIBUTE_UNUSED) +gfc_resolve_mod (gfc_expr * f, gfc_expr * a, gfc_expr * p) { - f->ts = a->ts; + f->ts.type = a->ts.type; + if (p != NULL) + f->ts.kind = gfc_kind_max (a,p); + else + f->ts.kind = a->ts.kind; + + if (p != NULL && a->ts.kind != p->ts.kind) + { + if (a->ts.kind == gfc_kind_max (a,p)) + gfc_convert_type(p, &a->ts, 2); + else + gfc_convert_type(a, &p->ts, 2); + } + f->value.function.name = - gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); + gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind); } void -gfc_resolve_modulo (gfc_expr * f, gfc_expr * a, - gfc_expr * p ATTRIBUTE_UNUSED) +gfc_resolve_modulo (gfc_expr * f, gfc_expr * a, gfc_expr * p) { - f->ts = a->ts; + f->ts.type = a->ts.type; + if (p != NULL) + f->ts.kind = gfc_kind_max (a,p); + else + f->ts.kind = a->ts.kind; + + if (p != NULL && a->ts.kind != p->ts.kind) + { + if (a->ts.kind == gfc_kind_max (a,p)) + gfc_convert_type(p, &a->ts, 2); + else + gfc_convert_type(a, &p->ts, 2); + } + f->value.function.name = - gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type), - a->ts.kind); + gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type), + f->ts.kind); } void diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index b6931f112e1..e6fbefcfe5b 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -920,11 +920,13 @@ gfc_expr * gfc_simplify_dim (gfc_expr * x, gfc_expr * y) { gfc_expr *result; + int kind; if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; + result = gfc_constant_result (x->ts.type, kind, &x->where); switch (x->ts.type) { @@ -2250,11 +2252,13 @@ gfc_simplify_mod (gfc_expr * a, gfc_expr * p) { gfc_expr *result; mpfr_t quot, iquot, term; + int kind; if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where); + kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; + result = gfc_constant_result (a->ts.type, kind, &a->where); switch (a->ts.type) { @@ -2278,7 +2282,7 @@ gfc_simplify_mod (gfc_expr * a, gfc_expr * p) return &gfc_bad_expr; } - gfc_set_model_kind (a->ts.kind); + gfc_set_model_kind (kind); mpfr_init (quot); mpfr_init (iquot); mpfr_init (term); @@ -2306,11 +2310,13 @@ gfc_simplify_modulo (gfc_expr * a, gfc_expr * p) { gfc_expr *result; mpfr_t quot, iquot, term; + int kind; if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) return NULL; - result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where); + kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; + result = gfc_constant_result (a->ts.type, kind, &a->where); switch (a->ts.type) { @@ -2336,7 +2342,7 @@ gfc_simplify_modulo (gfc_expr * a, gfc_expr * p) return &gfc_bad_expr; } - gfc_set_model_kind (a->ts.kind); + gfc_set_model_kind (kind); mpfr_init (quot); mpfr_init (iquot); mpfr_init (term); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 66bf1af2106..24dc9dc1c3d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2005-11-27 Francois-Xavier Coudert + + PR fortran/23912 + * gfortran.dg/modulo_1.f90: New test. + 2005-11-27 Francois-Xavier Coudert PR libfortran/24919 diff --git a/gcc/testsuite/gfortran.dg/modulo_1.f90 b/gcc/testsuite/gfortran.dg/modulo_1.f90 new file mode 100644 index 00000000000..4fb255e6246 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/modulo_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/23912 + integer*4 i4 + integer*8 i8 + + i4 = modulo(i4,i8) ! { dg-warning "Extension" } + i4 = modulo(i8,i4) ! { dg-warning "Extension" } + + end -- 2.30.2