re PR fortran/25099 (Conformance of arguments to ELEMENTAL subroutines)

2006-04-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25099
	* resolve.c (resolve_call): Check conformity of elemental
	subroutine actual arguments.

2006-04-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25099
	* gfortran.dg/elemental_subroutine_4.f90: New test.
	* gfortran.dg/assumed_size_refs_1.f90: Add error to non-conforming
	call sub (m, x).

From-SVN: r113194

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d10a53e..b64b6c7 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2006-04-23  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/25099
+       * resolve.c (resolve_call): Check conformity of elemental
+       subroutine actual arguments.
+
 2006-04-22  Jakub Jelinek  <jakub@redhat.com>
 
        PR fortran/26769

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fce2322..1e57add 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1657,18 +1657,33 @@ resolve_call (gfc_code * c)
        gfc_internal_error ("resolve_subroutine(): bad function type");
       }
 
+  /* Some checks of elemental subroutines.  */
   if (c->ext.actual != NULL
       && c->symtree->n.sym->attr.elemental)
     {
       gfc_actual_arglist * a;
-      /* Being elemental, the last upper bound of an assumed size array
-        argument must be present.  */
+      gfc_expr * e;
+      e = NULL;
+
       for (a = c->ext.actual; a; a = a->next)
        {
-         if (a->expr != NULL
-               && a->expr->rank > 0
-               && resolve_assumed_size_actual (a->expr))
+         if (a->expr == NULL || a->expr->rank == 0)
+           continue;
+
+        /* The last upper bound of an assumed size array argument must
+           be present.  */
+         if (resolve_assumed_size_actual (a->expr))
            return FAILURE;
+
+         /* Array actual arguments must conform.  */
+         if (e != NULL)
+           {
+             if (gfc_check_conformance ("elemental subroutine", a->expr, e)
+                       == FAILURE)
+               return FAILURE;
+           }
+         else
+           e = a->expr;
        }
     }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3264503..7a3fb00 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2006-04-23  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/25099
+       * gfortran.dg/elemental_subroutine_4.f90: New test.
+       * gfortran.dg/assumed_size_refs_1.f90: Add error to non-conforming
+       call sub (m, x).
+
 2006-04-22  Joseph S. Myers  <joseph@codesourcery.com>
 
        * gcc.c-torture/compile/20060421-1.c: New testcase.

diff --git a/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90 b/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90
index ff42c02..1590ec5 100644 (file)
--- a/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_size_refs_1.f90
@@ -35,7 +35,7 @@ contains
     x = fcn (m)                ! { dg-error "upper bound in the last dimension" }
     m(:, 1:2) = fcn (q)
     call sub (m, x)            ! { dg-error "upper bound in the last dimension" }
-    call sub (m(1:2, 1:2), x)
+    call sub (m(1:2, 1:2), x)  ! { dg-error "Incompatible ranks in elemental subroutine" }
     print *, p
 
     call DHSEQR(x)

diff --git a/gcc/testsuite/gfortran.dg/elemental_subroutine_4.f90 b/gcc/testsuite/gfortran.dg/elemental_subroutine_4.f90
new file mode 100644 (file)
index 0000000..1a34462
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/elemental_subroutine_4.f90
@@ -0,0 +1,38 @@
+! { dg-do compile }
+! Test the fix for PR25099, in which conformance checking was not being
+! done for elemental subroutines and therefore for interface assignments.
+!
+! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+!
+module elem_assign
+   implicit none
+   type mytype
+      integer x
+   end type mytype
+   interface assignment(=)
+      module procedure myassign
+   end interface assignment(=)
+   contains
+      elemental subroutine myassign(x,y)
+         type(mytype), intent(out) :: x
+         type(mytype), intent(in) :: y
+         x%x = y%x
+      end subroutine myassign
+end module elem_assign
+
+   use elem_assign
+   integer :: I(2,2),J(2)
+   type (mytype) :: w(2,2), x(4), y(5), z(4)
+! The original PR
+   CALL S(I,J) ! { dg-error "Incompatible ranks in elemental subroutine" }
+! Check interface assignments
+   x = w       ! { dg-error "Incompatible ranks in elemental subroutine" }
+   x = y       ! { dg-error "different shape for elemental subroutine" }
+   x = z
+CONTAINS
+   ELEMENTAL SUBROUTINE S(I,J)
+     INTEGER, INTENT(IN) :: I,J
+   END SUBROUTINE S
+END
+
+! { dg-final { cleanup-modules "elem_assign" } }