From: Paul Thomas <pault@gcc.gnu.org>
Date: Wed, 14 May 2008 21:32:53 +0000 (+0000)
Subject: re PR fortran/36233 (Array valued actual procedure argument rejected)
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=16f2a7a4a53554e454d5373e6ef689da8fc84ef4;p=gcc.git

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 d2470a1edd6..2facb39a3f0 100644
--- 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 f5746bf0a53..f70cedba949 100644
--- 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 2fa16223fab..1815f53c65a 100644
--- 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
index 00000000000..5327cb73d7f
--- /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