re PR fortran/36233 (Array valued actual procedure argument rejected)

2008-05-14  Paul Thomas  <pault@gcc.gnu.org>

       PR fortran/36233
       * interface.c (compare_actual_formal): Do not check sizes if the
       actual is BT_PROCEDURE.

2008-05-14  Paul Thomas  <pault@gcc.gnu.org>

       PR fortran/36233
       * gfortran.dg/actual_procedure_1.f90: New test

From-SVN: r135307

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d2470a1edd6200bf4d4c74d5966bb3e92b97fe48..2facb39a3f02171d468aa6ddf5618cdd6da1c507 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2008-05-14  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/36233
+       * interface.c (compare_actual_formal): Do not check sizes if the
+       actual is BT_PROCEDURE.
+
 2008-05-14  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
        PR fortran/35682

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index f5746bf0a531216b1123f91f2e7d6f3e3b902506..f70cedba949c460d5f604639e710c77d4c026d02 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1942,7 +1942,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 
       actual_size = get_expr_storage_size (a->expr);
       formal_size = get_sym_storage_size (f->sym);
-      if (actual_size != 0 && actual_size < formal_size)
+      if (actual_size != 0
+           && actual_size < formal_size
+           && a->expr->ts.type != BT_PROCEDURE)
        {
          if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
            gfc_warning ("Character length of actual argument shorter "

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2fa16223fab24889620b3747a191f240796b476d..1815f53c65a83fd2c814d477069e32eeaa326486 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2008-05-14  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/36233
+       * gfortran.dg/actual_procedure_1.f90: New test
+
 2008-05-14  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
        PR fortran/35682

diff --git a/gcc/testsuite/gfortran.dg/actual_procedure_1.f90 b/gcc/testsuite/gfortran.dg/actual_procedure_1.f90
new file mode 100644 (file)
index 0000000..5327cb7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/actual_procedure_1.f90
@@ -0,0 +1,72 @@
+! { dg-do run }
+! Tests the fix for PR36433 in which a check for the array size
+! or character length of the actual arguments of foo and bar
+! would reject this legal code.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module m
+contains
+  function proc4 (arg, chr)
+    integer, dimension(10) :: proc4
+    integer, intent(in) :: arg
+    character(8), intent(inout) :: chr
+    proc4 = arg
+    chr = "proc4"
+  end function
+  function chr_proc ()
+    character(8) :: chr_proc
+    chr_proc = "chr_proc"
+  end function
+end module
+
+program procPtrTest
+  use m
+  character(8) :: chr
+  interface
+    function proc_ext (arg, chr)
+      integer, dimension(10) :: proc_ext
+      integer, intent(in) :: arg
+      character(8), intent(inout) :: chr
+    end function
+  end interface
+! Check the passing of a module function
+  call foo (proc4, chr)
+  if (trim (chr) .ne. "proc4") call abort
+! Check the passing of an external function
+  call foo (proc_ext, chr)
+! Check the passing of a character function
+  if (trim (chr) .ne. "proc_ext") call abort
+  call bar (chr_proc)
+contains
+  subroutine foo (p, chr)
+    character(8), intent(inout) :: chr
+    integer :: i(10)
+    interface
+      function p (arg, chr)
+        integer, dimension(10) :: p
+        integer, intent(in) :: arg
+        character(8), intent(inout) :: chr
+      end function
+    end interface
+    i = p (99, chr)
+    if (any(i .ne. 99)) call abort
+  end subroutine
+  subroutine bar (p)
+    interface
+      function p ()
+        character(8):: p
+      end function
+    end interface
+    if (p () .ne. "chr_proc") call abort
+  end subroutine
+end program 
+
+function proc_ext (arg, chr)
+  integer, dimension(10) :: proc_ext
+  integer, intent(in) :: arg
+  character(8), intent(inout) :: chr
+  proc_ext = arg
+  chr = "proc_ext"
+end function
+! { dg-final { cleanup-modules "m" } }
\ No newline at end of file