This patch fixes three issues, (a) and (b) are 4.6/4.7 regressions.
a) PR48112: Due to incomplete resolution, there was an ICE when writing
the module file. Solution: Back-out the patch which introduced the
incomplete resolution - and add a similar patch later to avoid printing
errors multiple times.
b) PR48279: The patch adding supporting functions calls as actual
argument to intent-in dummies had problems with generics, which lead to
an ICE. Solution: Use the expr's specific procedure (esym) instead.
c) PR48279 comment 8: gfortran was accepting internal procedures in
INTERFACE; solution: Reject it with -std=f2008, but accept it with
-std=gnu. Reasoning: Except of NAG all other tested compilers also
accept it.
Build and currently regtesting on x86-64.
OK for the trunk - and for 4.6?
Tobias
PS: Besides those two, there are three other regressions:
1. PR 48462: -frealloc-lhs issue, partially fixed by Paul; follow-up
patch pending - and then 4.6 backporting.
2. PR 45586: ICE (tree checking) with LTO, seems to be a restricted vs.
not decl issue.
3. PR 42954: The target CPP issue ...
As (1) and (2) are 4.6/4.7 regressions, we should really concentrate on
fixing them before the 4.6.1 release.
2011-04-26 Tobias Burnus <bur...@net-b.de>
PR fortran/48112
* resolve.c (resolve_fl_var_and_proc): Print diagnostic of
function results only once.
(resolve_symbol): Always resolve function results.
PR fortran/48279
* expr.c (gfc_check_vardef_context): Fix handling of generic
EXPR_FUNCTION.
* interface.c (check_interface0): Reject internal functions
in generic interfaces, unless -std=gnu.
2011-04-26 Tobias Burnus <bur...@net-b.de>
PR fortran/48112
PR fortran/48279
* gfortran.dg/interface_35.f90: New.
* gfortran.dg/erfc_scaled_1.f90: Don't compile with -pedantic.
* gfortran.dg/func_result_6.f90: Add dg-warning.
* gfortran.dg/bessel_1.f90: Ditto.
* gfortran.dg/hypot_1.f90: Ditto.
* gfortran.dg/proc_ptr_comp_20.f90: Ditto.
* gfortran.dg/proc_ptr_comp_21.f90: Ditto.
* gfortran.dg/interface_assignment_4.f90: Ditto.
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index dae2149..3d519db 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4371,15 +4371,26 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
gfc_try
gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
{
- gfc_symbol* sym;
+ gfc_symbol* sym = NULL;
bool is_pointer;
bool check_intentin;
bool ptr_component;
symbol_attribute attr;
gfc_ref* ref;
+ if (e->expr_type == EXPR_VARIABLE)
+ {
+ gcc_assert (e->symtree);
+ sym = e->symtree->n.sym;
+ }
+ else if (e->expr_type == EXPR_FUNCTION)
+ {
+ gcc_assert (e->symtree);
+ sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
+ }
+
if (!pointer && e->expr_type == EXPR_FUNCTION
- && e->symtree->n.sym->result->attr.pointer)
+ && sym->result->attr.pointer)
{
if (!(gfc_option.allow_std & GFC_STD_F2008))
{
@@ -4397,9 +4408,6 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
return FAILURE;
}
- gcc_assert (e->symtree);
- sym = e->symtree->n.sym;
-
if (!pointer && sym->attr.flavor == FL_PARAMETER)
{
if (context)
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 5e7a1dc..1f75724 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1128,6 +1128,12 @@ check_interface0 (gfc_interface *p, const char *interface_name)
" or all FUNCTIONs", interface_name, &p->sym->declared_at);
return 1;
}
+
+ if (p->sym->attr.proc == PROC_INTERNAL
+ && gfc_notify_std (GFC_STD_GNU, "Extension: Internal procedure '%s' "
+ "in %s at %L", p->sym->name, interface_name,
+ &p->sym->declared_at) == FAILURE)
+ return 1;
}
p = psave;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index d7b95f5..59a863c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9886,6 +9886,11 @@ apply_default_init_local (gfc_symbol *sym)
static gfc_try
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{
+ /* Avoid double diagnostics for function result symbols. */
+ if ((sym->result || sym->attr.result) && !sym->attr.dummy
+ && (sym->ns != gfc_current_ns))
+ return SUCCESS;
+
/* Constraints on deferred shape variable. */
if (sym->as == NULL || sym->as->type != AS_DEFERRED)
{
@@ -11974,11 +11979,6 @@ resolve_symbol (gfc_symbol *sym)
gfc_namespace *ns;
gfc_component *c;
- /* Avoid double resolution of function result symbols. */
- if ((sym->result || sym->attr.result) && !sym->attr.dummy
- && (sym->ns != gfc_current_ns))
- return;
-
if (sym->attr.flavor == FL_UNKNOWN)
{
--- /dev/null 2011-04-21 07:44:25.943893902 +0200
+++ gcc/gcc/testsuite/gfortran.dg/interface_35.f90 2011-04-26 22:41:18.000000000 +0200
@@ -0,0 +1,79 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/48112 (module_m)
+! PR fortran/48279 (sidl_string_array, s_Hard)
+!
+! Contributed by mh...@gmx.at (module_m)
+! and Adrian Prantl (sidl_string_array, s_Hard)
+!
+
+module module_m
+ interface test
+ function test1( ) result( test )
+ integer :: test
+ end function test1
+ end interface test
+end module module_m
+
+! -----
+
+module sidl_string_array
+ type sidl_string_1d
+ end type sidl_string_1d
+ interface set
+ module procedure &
+ setg1_p
+ end interface
+contains
+ subroutine setg1_p(array, index, val)
+ type(sidl_string_1d), intent(inout) :: array
+ end subroutine setg1_p
+end module sidl_string_array
+
+module s_Hard
+ use sidl_string_array
+ type :: s_Hard_t
+ integer(8) :: dummy
+ end type s_Hard_t
+ interface set_d_interface
+ end interface
+ interface get_d_string
+ module procedure get_d_string_p
+ end interface
+ contains ! Derived type member access functions
+ type(sidl_string_1d) function get_d_string_p(s)
+ type(s_Hard_t), intent(in) :: s
+ end function get_d_string_p
+ subroutine set_d_objectArray_p(s, d_objectArray)
+ end subroutine set_d_objectArray_p
+end module s_Hard
+
+subroutine initHard(h, ex)
+ use s_Hard
+ type(s_Hard_t), intent(inout) :: h
+ call set(get_d_string(h), 0, 'Three') ! { dg-error "There is no specific subroutine for the generic" }
+end subroutine initHard
+
+! -----
+
+ interface get
+ procedure get1
+ end interface
+
+ integer :: h
+ call set1 (get (h))
+
+contains
+
+ subroutine set1 (a)
+ integer, intent(in) :: a
+ end subroutine
+
+ integer function get1 (s) ! { dg-error "Extension: Internal procedure .get1. in generic interface .get." }
+ integer :: s
+ end function
+
+end
+
+! { dg-final { cleanup-modules "module_m module_m2 s_hard sidl_string_array" } }
diff --git a/gcc/testsuite/gfortran.dg/bessel_1.f90 b/gcc/testsuite/gfortran.dg/bessel_1.f90
index 728c5ce..fb1e19b 100644
--- a/gcc/testsuite/gfortran.dg/bessel_1.f90
+++ b/gcc/testsuite/gfortran.dg/bessel_1.f90
@@ -26,11 +26,11 @@ program test
call check(bessel_yn (3,x4), bessel_yn (3,1.9_4))
contains
- subroutine check_r4 (a, b)
+ subroutine check_r4 (a, b) ! { dg-warning "Extension: Internal procedure" }
real(kind=4), intent(in) :: a, b
if (abs(a - b) > 1.e-5 * abs(b)) call abort
end subroutine
- subroutine check_r8 (a, b)
+ subroutine check_r8 (a, b) ! { dg-warning "Extension: Internal procedure" }
real(kind=8), intent(in) :: a, b
if (abs(a - b) > 1.e-7 * abs(b)) call abort
end subroutine
diff --git a/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90 b/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90
index 8a114e6..eeb54c8 100644
--- a/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90
+++ b/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90
@@ -1,4 +1,8 @@
! { dg-do run }
+!
+! { dg-options "" }
+! Do not run with -pedantic checks enabled as "check"
+! contains internal procedures which is a vendor extension
program test
implicit none
diff --git a/gcc/testsuite/gfortran.dg/func_result_6.f90 b/gcc/testsuite/gfortran.dg/func_result_6.f90
index e64a2ef..e8347be 100644
--- a/gcc/testsuite/gfortran.dg/func_result_6.f90
+++ b/gcc/testsuite/gfortran.dg/func_result_6.f90
@@ -63,7 +63,7 @@ if (ptr /= 2) call abort()
bar = gen()
if (ptr /= 77) call abort()
contains
- function foo()
+ function foo() ! { dg-warning "Extension: Internal procedure .foo. in generic interface" }
integer, allocatable :: foo(:)
allocate(foo(2))
foo = [33, 77]
diff --git a/gcc/testsuite/gfortran.dg/hypot_1.f90 b/gcc/testsuite/gfortran.dg/hypot_1.f90
index 59022fa..0c1c6e2 100644
--- a/gcc/testsuite/gfortran.dg/hypot_1.f90
+++ b/gcc/testsuite/gfortran.dg/hypot_1.f90
@@ -18,11 +18,11 @@ program test
call check(hypot(x4,y4), hypot(1.9_4,-2.1_4))
contains
- subroutine check_r4 (a, b)
+ subroutine check_r4 (a, b) ! { dg-warning "Extension: Internal procedure" }
real(kind=4), intent(in) :: a, b
if (abs(a - b) > 1.e-5 * abs(b)) call abort
end subroutine
- subroutine check_r8 (a, b)
+ subroutine check_r8 (a, b) ! { dg-warning "Extension: Internal procedure" }
real(kind=8), intent(in) :: a, b
if (abs(a - b) > 1.e-7 * abs(b)) call abort
end subroutine
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
index d477368..57660c7 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
@@ -35,12 +35,12 @@ o1%ppc => o2%ppc ! { dg-error "Type/kind mismatch" }
contains
- real function f1(a,b)
+ real function f1(a,b) ! { dg-warning "Extension: Internal procedure" }
real,intent(in) :: a,b
f1 = a + b
end function
- integer function f2(a,b)
+ integer function f2(a,b) ! { dg-warning "Extension: Internal procedure" }
real,intent(in) :: a,b
f2 = a - b
end function
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90
index c000896..a21916b 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90
@@ -19,7 +19,7 @@
contains
- elemental subroutine op_assign (str, ch)
+ elemental subroutine op_assign (str, ch) ! { dg-warning "Extension: Internal procedure" }
type(nf_t), intent(out) :: str
character(len=*), intent(in) :: ch
end subroutine
diff --git a/gcc/testsuite/gfortran.dg/interface_assignment_4.f90 b/gcc/testsuite/gfortran.dg/interface_assignment_4.f90
index 535e884..d55af29 100644
--- a/gcc/testsuite/gfortran.dg/interface_assignment_4.f90
+++ b/gcc/testsuite/gfortran.dg/interface_assignment_4.f90
@@ -16,7 +16,7 @@
contains
- subroutine op_assign_VS_CH (var, exp)
+ subroutine op_assign_VS_CH (var, exp) ! { dg-warning "Extension: Internal procedure" }
type(varying_string), intent(out) :: var
character(LEN=*), intent(in) :: exp
end subroutine
