diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f3602064f96..c2a3464d54c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,26 @@ +2006-12-09 Paul Thomas + + PR fortran/29975 + PR fortran/30068 + PR fortran/30096 + * interface.c (compare_type_rank_if): Reject invalid generic + interfaces. + (check_interface1): Give a warning for nonreferred to ambiguous + interfaces. + (check_sym_interfaces): Check whether an ambiguous interface is + referred to. Do not check host associated interfaces since these + cannot be ambiguous with the local versions. + (check_uop_interface, gfc_check_interfaces): Update call to + check_interface1. + * symbol.c (gfc_get_sym_tree, gfc_get_sym_tree): Allow adding + unambiguous procedures to generic interfaces. + * gfortran.h (symbol_attribute): Added use_only and + ambiguous_interfaces. + * module.c (load_need): Set the use_only flag, if needed. + * resolve.c (resolve_fl_procedure): Warn for nonreferred + interfaces. + * expr.c (find_array_section): Fix initializer array contructor. + 2006-12-09 Paul Thomas PR fortran/29464 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index f806497bc38..78cb9f07443 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -1189,7 +1189,8 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) for (d = 0; d < rank; d++) { mpz_set (tmp_mpz, ctr[d]); - mpz_sub_ui (tmp_mpz, tmp_mpz, one); + mpz_sub (tmp_mpz, tmp_mpz, + ref->u.ar.as->lower[d]->value.integer); mpz_mul (tmp_mpz, tmp_mpz, delta[d]); mpz_add (ptr, ptr, tmp_mpz); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 5e4b322aebf..8665ec9bb6a 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -483,7 +483,8 @@ typedef struct dummy:1, result:1, assign:1, threadprivate:1; unsigned data:1, /* Symbol is named in a DATA statement. */ - use_assoc:1; /* Symbol has been use-associated. */ + use_assoc:1, /* Symbol has been use-associated. */ + use_only:1; /* Symbol has been use-associated, with ONLY. */ unsigned in_namelist:1, in_common:1, in_equivalence:1; unsigned function:1, subroutine:1, generic:1, generic_copy:1; @@ -518,6 +519,9 @@ typedef struct modification of type or type parameters is permitted. */ unsigned referenced:1; + /* Set if the symbol has ambiguous interfaces. */ + unsigned ambiguous_interfaces:1; + /* Set if the is the symbol for the main program. This is the least cumbersome way to communicate this function property without strcmp'ing with __MAIN everywhere. */ diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 80a773e936a..bcf95f51ee0 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -462,7 +462,9 @@ compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2) if (s1->attr.function && compare_type_rank (s1, s2) == 0) return 0; - return compare_interfaces (s1, s2, 0); /* Recurse! */ + /* Originally, gfortran recursed here to check the interfaces of passed + procedures. This is explicitly not required by the standard. */ + return 1; } @@ -965,7 +967,8 @@ check_interface0 (gfc_interface * p, const char *interface_name) static int check_interface1 (gfc_interface * p, gfc_interface * q0, - int generic_flag, const char *interface_name) + int generic_flag, const char *interface_name, + int referenced) { gfc_interface * q; for (; p; p = p->next) @@ -979,12 +982,20 @@ check_interface1 (gfc_interface * p, gfc_interface * q0, if (compare_interfaces (p->sym, q->sym, generic_flag)) { - gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L", - p->sym->name, q->sym->name, interface_name, &p->where); + if (referenced) + { + gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L", + p->sym->name, q->sym->name, interface_name, + &p->where); + } + + if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc) + gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L", + p->sym->name, q->sym->name, interface_name, + &p->where); return 1; } } - return 0; } @@ -997,7 +1008,7 @@ static void check_sym_interfaces (gfc_symbol * sym) { char interface_name[100]; - gfc_symbol *s2; + int k; if (sym->ns != gfc_current_ns) return; @@ -1008,17 +1019,13 @@ check_sym_interfaces (gfc_symbol * sym) if (check_interface0 (sym->generic, interface_name)) return; - s2 = sym; - while (s2 != NULL) - { - if (check_interface1 (sym->generic, s2->generic, 1, interface_name)) - return; - - if (s2->ns->parent == NULL) - break; - if (gfc_find_symbol (sym->name, s2->ns->parent, 1, &s2)) - break; - } + /* Originally, this test was aplied to host interfaces too; + this is incorrect since host associated symbols, from any + source, cannot be ambiguous with local symbols. */ + k = sym->attr.referenced || !sym->attr.use_assoc; + if (check_interface1 (sym->generic, sym->generic, 1, + interface_name, k)) + sym->attr.ambiguous_interfaces = 1; } } @@ -1040,7 +1047,8 @@ check_uop_interfaces (gfc_user_op * uop) if (uop2 == NULL) continue; - check_interface1 (uop->operator, uop2->operator, 0, interface_name); + check_interface1 (uop->operator, uop2->operator, 0, + interface_name, 1); } } @@ -1082,7 +1090,7 @@ gfc_check_interfaces (gfc_namespace * ns) for (ns2 = ns->parent; ns2; ns2 = ns2->parent) if (check_interface1 (ns->operator[i], ns2->operator[i], 0, - interface_name)) + interface_name, 1)) break; } diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 7c9c2b1ab3c..ca4e0913b18 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -3228,6 +3228,8 @@ load_needed (pointer_info * p) mio_symbol (sym); sym->attr.use_assoc = 1; + if (only_flag) + sym->attr.use_only = 1; return 1; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 863e8319d09..0690dca46e5 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5528,6 +5528,10 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) gfc_formal_arglist *arg; gfc_symtree *st; + if (sym->attr.ambiguous_interfaces && !sym->attr.referenced) + gfc_warning ("Although not referenced, '%s' at %L has ambiguous " + "interfaces", sym->name, &sym->declared_at); + if (sym->attr.function && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE) return FAILURE; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 7cb5e762de5..a8090824718 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2037,7 +2037,9 @@ gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag, if (st != NULL) { *result = st; - if (st->ambiguous) + /* Ambiguous generic interfaces are permitted, as long + as the specific interfaces are different. */ + if (st->ambiguous && !st->n.sym->attr.generic) { ambiguous_symbol (name, st); return 1; @@ -2138,8 +2140,10 @@ gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result) } else { - /* Make sure the existing symbol is OK. */ - if (st->ambiguous) + /* Make sure the existing symbol is OK. Ambiguous + generic interfaces are permitted, as long as the + specific interfaces are different. */ + if (st->ambiguous && !st->n.sym->attr.generic) { ambiguous_symbol (name, st); return 1; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5204470816a..2402aa803c0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,24 @@ +2006-12-09 Paul Thomas + Tobias Burnus + + PR fortran/29975 + PR fortran/30068 + * gfortran.dg/interface_4.f90: Test adding procedure to generic + interface. + * gfortran.dg/interface_5.f90: Test warning for not-referenced-to + ambiguous interfaces. + * gfortran.dg/interface_6.f90: Test invalid, ambiguous interface. + * gfortran.dg/interface_7.f90: Test invalid, ambiguous interface. + * gfortran.dg/interface_8.f90: Test warning for not-referenced-to + ambiguous interfaces. + * gfortran.dg/interface_1.f90: Change dg-error into a dg-warning. + * gfortran.dg/array_initializer_2.f90: Add initializer array + constructor test. + + PR fortran/30096 + * gfortran.dg/interface_9.f90: Test that host interfaces are + not checked for ambiguity with the local version. + 2006-12-09 Paul Thomas PR fortran/29464 diff --git a/gcc/testsuite/gfortran.dg/array_initializer_2.f90 b/gcc/testsuite/gfortran.dg/array_initializer_2.f90 index a7cd3a7c45e..ef30b84d409 100644 --- a/gcc/testsuite/gfortran.dg/array_initializer_2.f90 +++ b/gcc/testsuite/gfortran.dg/array_initializer_2.f90 @@ -2,6 +2,10 @@ ! Tests the fix for PR28496 in which initializer array constructors with ! a missing initial array index would cause an ICE. ! +! Test for the fix of the initializer array constructor part of PR29975 +! was added later. Here, the indexing would get in a mess if the array +! specification had a lower bound other than unity. +! ! Contributed by Paul Thomas ! Based on original test case from Samir Nordin ! @@ -11,7 +15,17 @@ integer, dimension(2,3), parameter :: d=reshape ((/c(3:2:-1,:)/),(/2,3/)) integer, dimension(3,3), parameter :: e=reshape ((/a(:),a(:)+3,a(:)+6/),(/3,3/)) integer, dimension(2,3), parameter :: f=reshape ((/c(2:1:-1,:)/),(/2,3/)) + CHARACTER (LEN=1), DIMENSION(3:7), PARAMETER :: g = & + (/ '+', '-', '*', '/', '^' /) + CHARACTER (LEN=3) :: h = "A+C" +! +! PR28496 +! if (any (b .ne. (/1,2,3/))) call abort () if (any (reshape(d,(/6/)) .ne. (/3, 2, 6, 5, 9, 8/))) call abort () if (any (reshape(f,(/6/)) .ne. (/2, 1, 5, 4, 8, 7/))) call abort () +! +! PR29975 +! + IF (all(h(2:2) /= g(3:4))) call abort () end diff --git a/gcc/testsuite/gfortran.dg/generic_7.f90 b/gcc/testsuite/gfortran.dg/generic_7.f90 index 12cb9ae0dcf..e520c0973ae 100644 --- a/gcc/testsuite/gfortran.dg/generic_7.f90 +++ b/gcc/testsuite/gfortran.dg/generic_7.f90 @@ -24,4 +24,5 @@ CONTAINS WRITE(*,*) x, y END SUBROUTINE END MODULE + ! { dg-final { cleanup-modules "global" } } diff --git a/gcc/testsuite/gfortran.dg/interface_1.f90 b/gcc/testsuite/gfortran.dg/interface_1.f90 index 6a398f1d25b..e170f870e1a 100644 --- a/gcc/testsuite/gfortran.dg/interface_1.f90 +++ b/gcc/testsuite/gfortran.dg/interface_1.f90 @@ -27,7 +27,7 @@ module z use y interface ambiguous - module procedure f ! { dg-error "in generic interface" "" } + module procedure f ! { dg-warning "in generic interface" "" } end interface contains diff --git a/gcc/testsuite/gfortran.dg/interface_4.f90 b/gcc/testsuite/gfortran.dg/interface_4.f90 new file mode 100644 index 00000000000..8f6c3317eef --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_4.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! Tests the fix for the interface bit of PR29975, in which the +! interfaces bl_copy were rejected as ambiguous, even though +! they import different specific interfaces. +! +! Contributed by Joost VandeVondele and +! simplified by Tobias Burnus +! +SUBROUTINE RECOPY(N, c) + real, INTENT(IN) :: N + character(6) :: c + c = "recopy" +END SUBROUTINE RECOPY + +MODULE f77_blas_extra +PUBLIC :: BL_COPY +INTERFACE BL_COPY + MODULE PROCEDURE SDCOPY +END INTERFACE BL_COPY +CONTAINS + SUBROUTINE SDCOPY(N, c) + INTEGER, INTENT(IN) :: N + character(6) :: c + c = "sdcopy" + END SUBROUTINE SDCOPY +END MODULE f77_blas_extra + +MODULE f77_blas_generic +INTERFACE BL_COPY + SUBROUTINE RECOPY(N, c) + real, INTENT(IN) :: N + character(6) :: c + END SUBROUTINE RECOPY +END INTERFACE BL_COPY +END MODULE f77_blas_generic + +program main + USE f77_blas_extra + USE f77_blas_generic + character(6) :: chr + call bl_copy(1, chr) + if (chr /= "sdcopy") call abort () + call bl_copy(1.0, chr) + if (chr /= "recopy") call abort () +end program main +! { dg-final { cleanup-modules "f77_blas_generic f77_blas_extra" } } diff --git a/gcc/testsuite/gfortran.dg/interface_5.f90 b/gcc/testsuite/gfortran.dg/interface_5.f90 new file mode 100644 index 00000000000..cc5a7129d4e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_5.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! Tests the fix for the interface bit of PR29975, in which the +! interfaces bl_copy were rejected as ambiguous, even though +! they import different specific interfaces. In this testcase, +! it is verified that ambiguous specific interfaces are caught. +! +! Contributed by Joost VandeVondele and +! simplified by Tobias Burnus +! +SUBROUTINE RECOPY(N, c) + real, INTENT(IN) :: N + character(6) :: c + print *, n + c = "recopy" +END SUBROUTINE RECOPY + +MODULE f77_blas_extra +PUBLIC :: BL_COPY +INTERFACE BL_COPY + MODULE PROCEDURE SDCOPY +END INTERFACE BL_COPY +CONTAINS + SUBROUTINE SDCOPY(N, c) + REAL, INTENT(IN) :: N + character(6) :: c + print *, n + c = "sdcopy" + END SUBROUTINE SDCOPY +END MODULE f77_blas_extra + +MODULE f77_blas_generic +INTERFACE BL_COPY + SUBROUTINE RECOPY(N, c) + real, INTENT(IN) :: N + character(6) :: c + END SUBROUTINE RECOPY +END INTERFACE BL_COPY +END MODULE f77_blas_generic + +subroutine i_am_ok + USE f77_blas_extra ! { dg-warning "ambiguous interfaces" } + USE f77_blas_generic + character(6) :: chr + chr = "" + if (chr /= "recopy") call abort () +end subroutine i_am_ok + +program main + USE f77_blas_extra ! { dg-error "Ambiguous interfaces" } + USE f77_blas_generic + character(6) :: chr + chr = "" + call bl_copy(1.0, chr) + if (chr /= "recopy") call abort () +end program main +! { dg-final { cleanup-modules "f77_blas_generic f77_blas_extra" } } diff --git a/gcc/testsuite/gfortran.dg/interface_6.f90 b/gcc/testsuite/gfortran.dg/interface_6.f90 new file mode 100644 index 00000000000..2e7f85afa47 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_6.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! One of the tests of the patch for PR30068. +! Taken from the fortran 2003 standard C11.2. +! +! The standard specifies that the optional arguments should be +! ignored in the counting of like type/kind, so the specific +! procedures below are invalid, even though actually unambiguous. +! +INTERFACE BAD8 + SUBROUTINE S8A(X,Y,Z) + REAL,OPTIONAL :: X + INTEGER :: Y + REAL :: Z + END SUBROUTINE S8A + SUBROUTINE S8B(X,Z,Y) + INTEGER,OPTIONAL :: X + INTEGER :: Z + REAL :: Y + END SUBROUTINE S8B ! { dg-error "Ambiguous interfaces" } +END INTERFACE BAD8 +real :: a, b +integer :: i, j +call bad8(x,i,b) +end diff --git a/gcc/testsuite/gfortran.dg/interface_7.f90 b/gcc/testsuite/gfortran.dg/interface_7.f90 new file mode 100644 index 00000000000..545211aec36 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_7.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! One of the tests of the patch for PR30068. +! Taken from the fortran 2003 standard C11.2. +! +! The interface is invalid although it is unambiguous because the +! standard explicitly does not require recursion into the formal +! arguments of procedures that themselves are interface arguments. +! +module x + INTERFACE BAD9 + SUBROUTINE S9A(X) + REAL :: X + END SUBROUTINE S9A + SUBROUTINE S9B(X) + INTERFACE + FUNCTION X(A) + REAL :: X,A + END FUNCTION X + END INTERFACE + END SUBROUTINE S9B + SUBROUTINE S9C(X) + INTERFACE + FUNCTION X(A) + REAL :: X + INTEGER :: A + END FUNCTION X + END INTERFACE + END SUBROUTINE S9C ! { dg-error "Ambiguous interfaces" } + END INTERFACE BAD9 +end module x + +! { dg-final { cleanup-modules "x" } } diff --git a/gcc/testsuite/gfortran.dg/interface_8.f90 b/gcc/testsuite/gfortran.dg/interface_8.f90 new file mode 100644 index 00000000000..7feccb38b40 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_8.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! One of the tests of the patch for PR30068. +! Taken from comp.lang.fortran 3rd December 2006. +! +! Although the generic procedure is not referenced and it would +! normally be permissible for it to be ambiguous, the USE, ONLY +! statement is effectively a reference and is invalid. +! +module mod1 + interface generic + subroutine foo(a) + real :: a + end subroutine + end interface generic +end module mod1 + +module mod2 + interface generic + subroutine bar(a) + real :: a + end subroutine + end interface generic +end module mod2 + +program main + use mod1, only: generic ! { dg-warning "has ambiguous interfaces" } + use mod2 +end program main + +! { dg-final { cleanup-modules "mod1 mod2" } } diff --git a/gcc/testsuite/gfortran.dg/interface_9.f90 b/gcc/testsuite/gfortran.dg/interface_9.f90 new file mode 100644 index 00000000000..b407ab06524 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_9.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! Test of the patch for PR30096, in which gfortran incorrectly. +! compared local with host associated interfaces. +! +! Based on contribution by Harald Anlauf +! +module module1 + interface inverse + module procedure A, B + end interface +contains + function A (X) result (Y) + real :: X, Y + Y = 1.0 + end function A + function B (X) result (Y) + integer :: X, Y + Y = 3 + end function B +end module module1 + +module module2 + interface inverse + module procedure C + end interface +contains + function C (X) result (Y) + real :: X, Y + Y = 2.0 + end function C +end module module2 + +program gfcbug48 + use module1, only : inverse + call sub () + if (inverse(1.0_4) /= 1.0_4) call abort () + if (inverse(1_4) /= 3_4) call abort () +contains + subroutine sub () + use module2, only : inverse + if (inverse(1.0_4) /= 2.0_4) call abort () + if (inverse(1_4) /= 3_4) call abort () + end subroutine sub +end program gfcbug48 + +! { dg-final { cleanup-modules "module1 module2" } } +