re PR fortran/48810 ([OOP] TPB rejected because module procedure is private)

2011-04-29  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48810
        * resolve.c (resolve_typebound_generic_call): Don't check access
        flags of the specific function.

        PR fortran/48800
        * resolve.c (resolve_formal_arglist): Don't change AS_DEFERRED
        to AS_ASSUMED_SHAPE for function results.
        (resolve_fl_var_and_proc): Print also for function results with
        AS_DEFERRED an error, if they are not a pointer or allocatable.
        (resolve_types): Make sure arguments of procedures in interface
        blocks are resolved.

2011-04-29  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48810
        * gfortran.dg/typebound_proc_22.f90: New.

        PR fortran/48800
        * gfortran.dg/interface_36.f90: New.

From-SVN: r173175

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 199495c2926aa073bd91bf9be86a3dd2fdbe29b9..4b84b2052d2e0c0e77ab2c5381a73b384020ed60 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2011-04-29  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/48810
+       * resolve.c (resolve_typebound_generic_call): Don't check access
+       flags of the specific function.
+
+       PR fortran/48800
+       * resolve.c (resolve_formal_arglist): Don't change AS_DEFERRED
+       to AS_ASSUMED_SHAPE for function results.
+       (resolve_fl_var_and_proc): Print also for function results with
+       AS_DEFERRED an error, if they are not a pointer or allocatable.
+       (resolve_types): Make sure arguments of procedures in interface
+       blocks are resolved.
+
 2011-04-29  Michael Matz  <matz@suse.de>
 
        * options.c (options.c): Set warn_maybe_uninitialized.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 7fed7a5396184534704aefbc0f223e85b6b3255e..a19b10399d6c6cb2cd6ccdde87b5a2197df10f4d 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -315,7 +315,8 @@ resolve_formal_arglist (gfc_symbol *proc)
         shape until we know if it has the pointer or allocatable attributes.
       */
       if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
-         && !(sym->attr.pointer || sym->attr.allocatable))
+         && !(sym->attr.pointer || sym->attr.allocatable)
+         && sym->attr.flavor != FL_PROCEDURE)
        {
          sym->as->type = AS_ASSUMED_SHAPE;
          for (i = 0; i < sym->as->rank; i++)
@@ -5684,7 +5685,7 @@ success:
   /* Make sure that we have the right specific instance for the name.  */
   derived = get_declared_from_expr (NULL, NULL, e);
 
-  st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
+  st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
   if (st)
     e->value.compcall.tbp = st->n.tb;
 
@@ -9918,7 +9919,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
   else
     {
       if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
-         && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
+         && sym->ts.type != BT_CLASS && !sym->assoc)
        {
          gfc_error ("Array '%s' at %L cannot have a deferred shape",
                     sym->name, &sym->declared_at);
@@ -13533,6 +13534,10 @@ resolve_types (gfc_namespace *ns)
 
   resolve_contained_functions (ns);
 
+  if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
+      && ns->proc_name->attr.if_source == IFSRC_IFBODY)
+    resolve_formal_arglist (ns->proc_name);
+
   gfc_traverse_ns (ns, resolve_bind_c_derived_types);
 
   for (cl = ns->cl_list; cl; cl = cl->next)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e7153e59f9a17e5c3ed9ae4068165209b83408fd..85a4461319adcacd5fa7c924777c4ddcc525a0fb 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2011-04-29  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/48810
+       * gfortran.dg/typebound_proc_22.f90: New.
+
+       PR fortran/48800
+       * gfortran.dg/interface_36.f90: New.
+
 2011-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR libgfortran/48488

diff --git a/gcc/testsuite/gfortran.dg/interface_36.f90 b/gcc/testsuite/gfortran.dg/interface_36.f90
new file mode 100644 (file)
index 0000000..5032291
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_36.f90
@@ -0,0 +1,28 @@
+! { dg-do compile }
+!
+! PR fortran/48800
+!
+! Contributed by Daniel Carrera
+!
+     pure function runge_kutta_step(t, r_, dr, h) result(res)
+         real, intent(in) :: t, r_(:), h
+         real, dimension(:), allocatable :: k1, k2, k3, k4, res
+         integer :: N
+
+         interface
+             pure function dr(t, r_)  ! { dg-error "cannot have a deferred shape" }
+                 real, intent(in) :: t, r_(:)
+                 real :: dr(:)
+             end function
+         end interface
+
+         N = size(r_)
+         allocate(k1(N),k2(N),k3(N),k4(N),res(N))
+
+         k1 = dr(t, r_)
+         k2 = dr(t + h/2, r_ + k1*h/2)
+         k3 = dr(t + h/2, r_ + k2*h/2)
+         k4 = dr(t + h  , r_ + k3*h)
+
+         res = r_ + (k1 + 2*k2 + 2*k3 + k4) * h/6
+     end function

diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_22.f90 b/gcc/testsuite/gfortran.dg/typebound_proc_22.f90
new file mode 100644 (file)
index 0000000..f7691c5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_proc_22.f90
@@ -0,0 +1,49 @@
+! { dg-do compile }
+!
+! PR fortran/48810
+!
+! Contributed by Andrew Baldwin
+!
+      module qtest
+      type foobar
+        integer :: x
+        contains
+        private
+        procedure :: gimmex
+        generic, public :: getx => gimmex
+      end type foobar
+      contains
+        function gimmex(foo)
+          class (foobar) :: foo
+          integer :: gimmex
+          gimmex = foo%x
+        end function gimmex
+      end module qtest
+
+      module qtestPriv
+      type foobarPriv
+        integer :: x
+        contains
+        private
+        procedure :: gimmexPriv
+        generic, private :: getxPriv => gimmexPriv
+      end type foobarPriv
+      contains
+        function gimmexPriv(foo)
+          class (foobarPriv) :: foo
+          integer :: gimmex
+          gimmex = foo%x
+        end function gimmexPriv
+      end module qtestPriv
+
+      program quicktest
+      use qtest
+      use qtestPriv
+      type (foobar) :: foo
+      type (foobarPriv) :: fooPriv
+      integer :: bar
+      bar = foo%getx()  ! OK
+      bar = fooPriv%getxPriv() ! { dg-error " is PRIVATE " }
+      end program quicktest
+
+! { dg-final { cleanup-modules "qtest qtestpriv" } }