From: Janus Weil Date: Wed, 28 May 2008 21:27:56 +0000 (+0200) Subject: re PR fortran/36325 (specific or generic INTERFACE implies the EXTERNAL attribute) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=e68954309d6a19f6008491b90da7bf0c78b3b6b1;p=gcc.git re PR fortran/36325 (specific or generic INTERFACE implies the EXTERNAL attribute) 2008-05-28 Janus Weil PR fortran/36325 PR fortran/35830 * interface.c (gfc_procedure_use): Enable argument checking for external procedures with explicit interface. * symbol.c (check_conflict): Fix conflict checking for externals. (copy_formal_args): Fix handling of arrays. * resolve.c (resolve_specific_f0, resolve_specific_s0): Fix handling of intrinsics. * parse.c (parse_interface): Non-abstract INTERFACE statement implies EXTERNAL attribute. 2008-05-28 Janus Weil PR fortran/36325 PR fortran/35830 * gfortran.dg/interface_23.f90: New. * gfortran.dg/gomp/reduction3.f90: Fixed invalid code. * gfortran.dg/proc_decl_12.f90: New: * gfortran.dg/external_procedures_1.f90: Fixed error message. From-SVN: r136130 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1995f6ac161..cf05afcf665 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2008-05-28 Janus Weil + + PR fortran/36325 + PR fortran/35830 + * interface.c (gfc_procedure_use): Enable argument checking for + external procedures with explicit interface. + * symbol.c (check_conflict): Fix conflict checking for externals. + (copy_formal_args): Fix handling of arrays. + * resolve.c (resolve_specific_f0, resolve_specific_s0): Fix handling + of intrinsics. + * parse.c (parse_interface): Non-abstract INTERFACE statement implies + EXTERNAL attribute. + 2008-05-28 Francois-Xavier Coudert PR fortran/36319 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index f70cedba949..f2ad4f6734e 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2421,8 +2421,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) } } - if (sym->attr.external - || sym->attr.if_source == IFSRC_UNKNOWN) + if (sym->attr.if_source == IFSRC_UNKNOWN) { gfc_actual_arglist *a; for (a = *ap; a; a = a->next) diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index dd072feb30e..b7e63919e8e 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1917,12 +1917,28 @@ loop: new_state = COMP_SUBROUTINE; gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, gfc_new_block->formal, NULL); + if (current_interface.type != INTERFACE_ABSTRACT && + !gfc_new_block->attr.dummy && + gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE) + { + reject_statement (); + gfc_free_namespace (gfc_current_ns); + goto loop; + } break; case ST_FUNCTION: new_state = COMP_FUNCTION; gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, gfc_new_block->formal, NULL); + if (current_interface.type != INTERFACE_ABSTRACT && + !gfc_new_block->attr.dummy && + gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE) + { + reject_statement (); + gfc_free_namespace (gfc_current_ns); + goto loop; + } break; case ST_PROCEDURE: diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index c3354a97d37..8044990b7dd 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1571,7 +1571,8 @@ resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr) /* Existance of isym should be checked already. */ gcc_assert (isym); - sym->ts = isym->ts; + sym->ts.type = isym->ts.type; + sym->ts.kind = isym->ts.kind; sym->attr.function = 1; sym->attr.proc = PROC_EXTERNAL; goto found; @@ -2646,8 +2647,9 @@ resolve_specific_s0 (gfc_code *c, gfc_symbol *sym) /* Existance of isym should be checked already. */ gcc_assert (isym); - sym->ts = isym->ts; - sym->attr.function = 1; + sym->ts.type = isym->ts.type; + sym->ts.kind = isym->ts.kind; + sym->attr.subroutine = 1; goto found; } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 431b6513ce0..e98a19c57fa 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -434,12 +434,14 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (target, external); conf (target, intrinsic); - conf (external, dimension); /* See Fortran 95's R504. */ + + if (!attr->if_source) + conf (external, dimension); /* See Fortran 95's R504. */ conf (external, intrinsic); conf (entry, intrinsic); - if ((attr->if_source && !attr->procedure) || attr->contained) + if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained) { conf (external, subroutine); conf (external, function); @@ -3664,6 +3666,7 @@ copy_formal_args (gfc_symbol *dest, gfc_symbol *src) /* May need to copy more info for the symbol. */ formal_arg->sym->attr = curr_arg->sym->attr; formal_arg->sym->ts = curr_arg->sym->ts; + formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as); /* If this isn't the first arg, set up the next ptr. For the last arg built, the formal_arg->next will never get set to diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1a33d2e1467..c28d1fc3eca 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2008-05-28 Janus Weil + + PR fortran/36325 + PR fortran/35830 + * gfortran.dg/interface_23.f90: New. + * gfortran.dg/gomp/reduction3.f90: Fixed invalid code. + * gfortran.dg/proc_decl_12.f90: New: + * gfortran.dg/external_procedures_1.f90: Fixed error message. + 2008-05-28 Francois-Xavier Coudert PR fortran/36319 diff --git a/gcc/testsuite/gfortran.dg/external_procedures_1.f90 b/gcc/testsuite/gfortran.dg/external_procedures_1.f90 index 95d0212353e..6e833be16e2 100644 --- a/gcc/testsuite/gfortran.dg/external_procedures_1.f90 +++ b/gcc/testsuite/gfortran.dg/external_procedures_1.f90 @@ -24,7 +24,7 @@ program main interface function ext1 (y) real ext1, y - external ext1 ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" } + external ext1 ! { dg-error "Duplicate EXTERNAL attribute" } end function ext1 end interface inval = 1.0 @@ -38,4 +38,4 @@ contains inv = y * y * y end function inv end program main - + diff --git a/gcc/testsuite/gfortran.dg/gomp/reduction3.f90 b/gcc/testsuite/gfortran.dg/gomp/reduction3.f90 index abd6d04415d..0272a741596 100644 --- a/gcc/testsuite/gfortran.dg/gomp/reduction3.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/reduction3.f90 @@ -33,11 +33,6 @@ subroutine f2 end subroutine f2 subroutine f3 integer :: i - interface - function ior (a, b) - integer :: ior, a, b - end function - end interface intrinsic ior i = 6 !$omp parallel reduction (ior:i) diff --git a/gcc/testsuite/gfortran.dg/interface_23.f90 b/gcc/testsuite/gfortran.dg/interface_23.f90 new file mode 100644 index 00000000000..60b6e796908 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_23.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! This tests the fix for PR36325, which corrected for the fact that a +! specific or generic INTERFACE statement implies the EXTERNAL attibute. +! +! Contributed by Janus Weil + +module a + interface + subroutine foo + end subroutine + end interface + external foo ! { dg-error "Duplicate EXTERNAL attribute" } +end module + +module b + interface + function sin (x) + real :: sin, x + end function + end interface + intrinsic sin ! { dg-error "EXTERNAL attribute conflicts with INTRINSIC attribute" } +end module + +! argument checking was not done for external procedures with explicit interface +program c + interface + subroutine bar(x) + real :: x + end subroutine + end interface + call bar() ! { dg-error "Missing actual argument" } +end program + +! { dg-final { cleanup-modules "a b" } } diff --git a/gcc/testsuite/gfortran.dg/proc_decl_12.f90 b/gcc/testsuite/gfortran.dg/proc_decl_12.f90 new file mode 100644 index 00000000000..092c24d3614 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_decl_12.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! This tests the (partial) fix for PR35830, i.e. handling array arguments +! with the PROCEDURE statement. +! +! Contributed by Janus Weil + +module m +contains + subroutine one(a) + integer a(1:3) + if (any(a /= [1,2,3])) call abort() + end subroutine one +end module m + +program test + use m + implicit none + call foo(one) +contains + subroutine foo(f) + procedure(one) :: f + call f([1,2,3]) + end subroutine foo +end program test + +! { dg-final { cleanup-modules "m" } }