Patchwork [Fortran] Fix regressions PRs 48810 and 48800: wrong access flag and missing deferred-shape diagnostics

login
register
mail settings
Submitter Tobias Burnus
Date April 28, 2011, 11:18 p.m.
Message ID <4DB9F5DE.8090402@net-b.de>
Download mbox | patch
Permalink /patch/93348/
State New
Headers show

Comments

Tobias Burnus - April 28, 2011, 11:18 p.m.
The attached patch fixes two regressions:

a) PR 48810: For type-bound procedures, the access flags should be 
checked only for the generic function, not for the specific function the 
generic resolves to. (4.6/4.7 rejects-valid regression.)

b) PR 48800: Function-results shall not be assumed-shape arrays, unless 
they are allocatable or a pointer. gfortran was missing a diagnostic for 
that. (The diagnostic never existed, but with 4.6/4.7 it now ICEs as 
realloc on assignment does not like it.)

Build and regtested on x86-64-linux.
OK for the trunk and the 4.6 branch?

Tobias

PS: We still have 4 other 4.6/4.7 regressions (+ the CPP target one). 
Two of them are true realloc-on-assignment bugs (PRs 42954 and 48746; 
wrong code). One is an OOP bug (PR 48786; rejects valid + ICE on invalid 
code), the other one is a tree-check bug (ICE) related to "restrict". -- 
As written before, we should try hard to fix all 4.6/4.7 regression 
before 4.6.1 is relased. Cf. http://gcc.gnu.org/ml/gcc/2011-04/msg00349.html
Jerry DeLisle - April 29, 2011, 3:39 p.m.
On 04/28/2011 04:18 PM, Tobias Burnus wrote:
> The attached patch fixes two regressions:
>
> a) PR 48810: For type-bound procedures, the access flags should be checked only
> for the generic function, not for the specific function the generic resolves to.
> (4.6/4.7 rejects-valid regression.)
>
> b) PR 48800: Function-results shall not be assumed-shape arrays, unless they are
> allocatable or a pointer. gfortran was missing a diagnostic for that. (The
> diagnostic never existed, but with 4.6/4.7 it now ICEs as realloc on assignment
> does not like it.)
>
> Build and regtested on x86-64-linux.
> OK for the trunk and the 4.6 branch?
>

Yes, OK and we just keep chipping away at these bugs and we'll be in good shape!

Thanks,

Jerry

Patch

2011-04-28  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-28  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.

--- /dev/null	2011-04-28 20:20:21.287889577 +0200
+++ gcc/gcc/testsuite/gfortran.dg/typebound_proc_22.f90	2011-04-28 22:52:39.000000000 +0200
@@ -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" } }
--- /dev/null	2011-04-28 20:20:21.287889577 +0200
+++ gcc/gcc/testsuite/gfortran.dg/interface_36.f90	2011-04-28 23:27:22.000000000 +0200
@@ -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/fortran/resolve.c b/gcc/fortran/resolve.c
index 7fed7a5..a19b103 100644
--- 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)