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
2011-04-28 Tobias Burnus <bur...@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 <bur...@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)
