From 12578be73d300173f75624b75d1336d17d97c116 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Fri, 29 Apr 2011 18:49:53 +0200 Subject: [PATCH] re PR fortran/48810 ([OOP] TPB rejected because module procedure is private) 2011-04-29 Tobias Burnus 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 PR fortran/48810 * gfortran.dg/typebound_proc_22.f90: New. PR fortran/48800 * gfortran.dg/interface_36.f90: New. From-SVN: r173175 --- gcc/fortran/ChangeLog | 14 ++++++ gcc/fortran/resolve.c | 11 +++-- gcc/testsuite/ChangeLog | 8 +++ gcc/testsuite/gfortran.dg/interface_36.f90 | 28 +++++++++++ .../gfortran.dg/typebound_proc_22.f90 | 49 +++++++++++++++++++ 5 files changed, 107 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/interface_36.f90 create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_22.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 199495c2926..4b84b2052d2 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2011-04-29 Tobias Burnus + + 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 * options.c (options.c): Set warn_maybe_uninitialized. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 7fed7a53961..a19b10399d6 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) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e7153e59f9a..85a4461319a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2011-04-29 Tobias Burnus + + PR fortran/48810 + * gfortran.dg/typebound_proc_22.f90: New. + + PR fortran/48800 + * gfortran.dg/interface_36.f90: New. + 2011-04-29 Jerry DeLisle 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 index 00000000000..503229134ab --- /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 index 00000000000..f7691c5f283 --- /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" } } -- 2.30.2