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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4a124d3b3adf9a252fb1eff49e21c601c264ee38..75fb58ae6c464d2bfadd31c733858f6e6b2c1e2d 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2005-11-27  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+       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  <jakub@redhat.com>
 
        PR fortran/14943

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index bc757ff86b874bb83bb5348b5f57f4240edeb53e..7b718960397c9053cac606474c25aca9189374aa 100644 (file)
--- 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 de3c2718956d746686fb04c052dc575454fdddb1..e154a34f6355e245b6e1df2f5e7bfc6129d88f0b 100644 (file)
--- 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 b6931f112e12f7fc298cc4de7c8f5afc6f42ec88..e6fbefcfe5ba8aa19d800ba63def2e19bafd53d0 100644 (file)
--- 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 66bf1af2106b918c89502ea837dc38408d6e88cc..24dc9dc1c3dfc5d5755989c932d14e6ba149742e 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2005-11-27  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+       PR fortran/23912
+       * gfortran.dg/modulo_1.f90: New test.
+
 2005-11-27  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
        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 (file)
index 0000000..4fb255e
--- /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