diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 616680d3bc4..e290e49fcd7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2013-04-12 Janus Weil + + PR fortran/56261 + * gfortran.h (gfc_explicit_interface_required): New prototype. + * expr.c (gfc_check_pointer_assign): Check if an explicit interface is + required in a proc-ptr assignment. + * interface.c (check_result_characteristics): Extra check. + * resolve.c (gfc_explicit_interface_required): New function. + (resolve_global_procedure): Use new function + 'gfc_explicit_interface_required'. Do a full interface check. + 2013-04-12 Tobias Burnus PR fortran/56845 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 1a531d92afc..829b0870a3b 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3556,6 +3556,22 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (s1 == s2 || !s1 || !s2) return true; + /* F08:7.2.2.4 (4) */ + if (s1->attr.if_source == IFSRC_UNKNOWN + && gfc_explicit_interface_required (s2, err, sizeof(err))) + { + gfc_error ("Explicit interface required for '%s' at %L: %s", + s1->name, &lvalue->where, err); + return false; + } + if (s2->attr.if_source == IFSRC_UNKNOWN + && gfc_explicit_interface_required (s1, err, sizeof(err))) + { + gfc_error ("Explicit interface required for '%s' at %L: %s", + s2->name, &rvalue->where, err); + return false; + } + if (!gfc_compare_interfaces (s1, s2, name, 0, 1, err, sizeof(err), NULL, NULL)) { diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index b033b748901..a69cea2b349 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2843,6 +2843,7 @@ match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *); gfc_expr *gfc_expr_to_initialize (gfc_expr *); bool gfc_type_is_extensible (gfc_symbol *); bool gfc_resolve_intrinsic (gfc_symbol *, locus *); +bool gfc_explicit_interface_required (gfc_symbol *, char *, int); /* array.c */ diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 2cadd8b0b2b..741416469f4 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1239,7 +1239,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2, return false; } - if (r1->ts.u.cl->length) + if (r1->ts.u.cl->length && r2->ts.u.cl->length) { int compval = gfc_dep_compare_expr (r1->ts.u.cl->length, r2->ts.u.cl->length); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9098d2cc4bd..30cfcd09058 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2118,6 +2118,126 @@ not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns) return true; } + +/* Check for the requirement of an explicit interface. F08:12.4.2.2. */ + +bool +gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len) +{ + gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym); + + for ( ; arg; arg = arg->next) + { + if (!arg->sym) + continue; + + if (arg->sym->attr.allocatable) /* (2a) */ + { + strncpy (errmsg, _("allocatable argument"), err_len); + return true; + } + else if (arg->sym->attr.asynchronous) + { + strncpy (errmsg, _("asynchronous argument"), err_len); + return true; + } + else if (arg->sym->attr.optional) + { + strncpy (errmsg, _("optional argument"), err_len); + return true; + } + else if (arg->sym->attr.pointer) + { + strncpy (errmsg, _("pointer argument"), err_len); + return true; + } + else if (arg->sym->attr.target) + { + strncpy (errmsg, _("target argument"), err_len); + return true; + } + else if (arg->sym->attr.value) + { + strncpy (errmsg, _("value argument"), err_len); + return true; + } + else if (arg->sym->attr.volatile_) + { + strncpy (errmsg, _("volatile argument"), err_len); + return true; + } + else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */ + { + strncpy (errmsg, _("assumed-shape argument"), err_len); + return true; + } + else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */ + { + strncpy (errmsg, _("assumed-rank argument"), err_len); + return true; + } + else if (arg->sym->attr.codimension) /* (2c) */ + { + strncpy (errmsg, _("coarray argument"), err_len); + return true; + } + else if (false) /* (2d) TODO: parametrized derived type */ + { + strncpy (errmsg, _("parametrized derived type argument"), err_len); + return true; + } + else if (arg->sym->ts.type == BT_CLASS) /* (2e) */ + { + strncpy (errmsg, _("polymorphic argument"), err_len); + return true; + } + else if (arg->sym->ts.type == BT_ASSUMED) + { + /* As assumed-type is unlimited polymorphic (cf. above). + See also TS 29113, Note 6.1. */ + strncpy (errmsg, _("assumed-type argument"), err_len); + return true; + } + } + + if (sym->attr.function) + { + gfc_symbol *res = sym->result ? sym->result : sym; + + if (res->attr.dimension) /* (3a) */ + { + strncpy (errmsg, _("array result"), err_len); + return true; + } + else if (res->attr.pointer || res->attr.allocatable) /* (3b) */ + { + strncpy (errmsg, _("pointer or allocatable result"), err_len); + return true; + } + else if (res->ts.type == BT_CHARACTER && res->ts.u.cl + && res->ts.u.cl->length + && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */ + { + strncpy (errmsg, _("result with non-constant character length"), err_len); + return true; + } + } + + if (sym->attr.elemental) /* (4) */ + { + strncpy (errmsg, _("elemental procedure"), err_len); + return true; + } + else if (sym->attr.is_bind_c) /* (5) */ + { + strncpy (errmsg, _("bind(c) procedure"), err_len); + return true; + } + + return false; +} + + static void resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_actual_arglist **actual, int sub) @@ -2125,6 +2245,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_gsymbol * gsym; gfc_namespace *ns; enum gfc_symbol_type type; + char reason[200]; type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; @@ -2195,160 +2316,32 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, } } - /* Differences in constant character lengths. */ - if (sym->attr.function && sym->ts.type == BT_CHARACTER) + if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts)) { - long int l1 = 0, l2 = 0; - gfc_charlen *cl1 = sym->ts.u.cl; - gfc_charlen *cl2 = def_sym->ts.u.cl; - - if (cl1 != NULL - && cl1->length != NULL - && cl1->length->expr_type == EXPR_CONSTANT) - l1 = mpz_get_si (cl1->length->value.integer); - - if (cl2 != NULL - && cl2->length != NULL - && cl2->length->expr_type == EXPR_CONSTANT) - l2 = mpz_get_si (cl2->length->value.integer); - - if (l1 && l2 && l1 != l2) - gfc_error ("Character length mismatch in return type of " - "function '%s' at %L (%ld/%ld)", sym->name, - &sym->declared_at, l1, l2); + gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)", + sym->name, &sym->declared_at, gfc_typename (&sym->ts), + gfc_typename (&def_sym->ts)); + goto done; } - /* Type mismatch of function return type and expected type. */ - if (sym->attr.function - && !gfc_compare_types (&sym->ts, &def_sym->ts)) - gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)", - sym->name, &sym->declared_at, gfc_typename (&sym->ts), - gfc_typename (&def_sym->ts)); - - if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY) + if (sym->attr.if_source == IFSRC_UNKNOWN + && gfc_explicit_interface_required (def_sym, reason, sizeof(reason))) { - gfc_formal_arglist *arg = def_sym->formal; - for ( ; arg; arg = arg->next) - if (!arg->sym) - continue; - /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */ - else if (arg->sym->attr.allocatable - || arg->sym->attr.asynchronous - || arg->sym->attr.optional - || arg->sym->attr.pointer - || arg->sym->attr.target - || arg->sym->attr.value - || arg->sym->attr.volatile_) - { - gfc_error ("Dummy argument '%s' of procedure '%s' at %L " - "has an attribute that requires an explicit " - "interface for this procedure", arg->sym->name, - sym->name, &sym->declared_at); - break; - } - /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */ - else if (arg->sym && arg->sym->as - && arg->sym->as->type == AS_ASSUMED_SHAPE) - { - gfc_error ("Procedure '%s' at %L with assumed-shape dummy " - "argument '%s' must have an explicit interface", - sym->name, &sym->declared_at, arg->sym->name); - break; - } - /* TS 29113, 6.2. */ - else if (arg->sym && arg->sym->as - && arg->sym->as->type == AS_ASSUMED_RANK) - { - gfc_error ("Procedure '%s' at %L with assumed-rank dummy " - "argument '%s' must have an explicit interface", - sym->name, &sym->declared_at, arg->sym->name); - break; - } - /* F2008, 12.4.2.2 (2c) */ - else if (arg->sym->attr.codimension) - { - gfc_error ("Procedure '%s' at %L with coarray dummy argument " - "'%s' must have an explicit interface", - sym->name, &sym->declared_at, arg->sym->name); - break; - } - /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */ - else if (false) /* TODO: is a parametrized derived type */ - { - gfc_error ("Procedure '%s' at %L with parametrized derived " - "type argument '%s' must have an explicit " - "interface", sym->name, &sym->declared_at, - arg->sym->name); - break; - } - /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */ - else if (arg->sym->ts.type == BT_CLASS) - { - gfc_error ("Procedure '%s' at %L with polymorphic dummy " - "argument '%s' must have an explicit interface", - sym->name, &sym->declared_at, arg->sym->name); - break; - } - /* As assumed-type is unlimited polymorphic (cf. above). - See also TS 29113, Note 6.1. */ - else if (arg->sym->ts.type == BT_ASSUMED) - { - gfc_error ("Procedure '%s' at %L with assumed-type dummy " - "argument '%s' must have an explicit interface", - sym->name, &sym->declared_at, arg->sym->name); - break; - } + gfc_error ("Explicit interface required for '%s' at %L: %s", + sym->name, &sym->declared_at, reason); + goto done; } - if (def_sym->attr.function) - { - /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */ - if (def_sym->as && def_sym->as->rank - && (!sym->as || sym->as->rank != def_sym->as->rank)) - gfc_error ("The reference to function '%s' at %L either needs an " - "explicit INTERFACE or the rank is incorrect", sym->name, - where); + if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU)) + /* Turn erros into warnings with -std=gnu and -std=legacy. */ + gfc_errors_to_warnings (1); - /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */ - if ((def_sym->result->attr.pointer - || def_sym->result->attr.allocatable) - && (sym->attr.if_source != IFSRC_IFBODY - || def_sym->result->attr.pointer - != sym->result->attr.pointer - || def_sym->result->attr.allocatable - != sym->result->attr.allocatable)) - gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE " - "result must have an explicit interface", sym->name, - where); - - /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */ - if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY - && def_sym->ts.type == BT_CHARACTER && def_sym->ts.u.cl->length != NULL) - { - gfc_charlen *cl = sym->ts.u.cl; - - if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN - && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) - { - gfc_error ("Nonconstant character-length function '%s' at %L " - "must have an explicit interface", sym->name, - &sym->declared_at); - } - } - } - - /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */ - if (def_sym->attr.elemental && !sym->attr.elemental) - { - gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit " - "interface", sym->name, &sym->declared_at); - } - - /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */ - if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c) - { - gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have " - "an explicit interface", sym->name, &sym->declared_at); + if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, + reason, sizeof(reason), NULL, NULL)) + { + gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ", + sym->name, &sym->declared_at, reason); + goto done; } if (!pedantic @@ -2358,9 +2351,10 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, if (sym->attr.if_source != IFSRC_IFBODY) gfc_procedure_use (def_sym, actual, where); - - gfc_errors_to_warnings (0); } + +done: + gfc_errors_to_warnings (0); if (gsym->type == GSYM_UNKNOWN) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 57b3c5b77a3..29a624e080b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,25 @@ +2013-04-12 Janus Weil + + PR fortran/56261 + * gfortran.dg/auto_char_len_4.f90: Add -pedantic. Changed error. + * gfortran.dg/assumed_rank_4.f90: Modified error wording. + * gfortran.dg/block_11.f90: Fix invalid test case. + * gfortran.dg/function_types_3.f90: Add new error message. + * gfortran.dg/global_references_1.f90: Ditto. + * gfortran.dg/import2.f90: Remove unneeded parts. + * gfortran.dg/import6.f90: Fix invalid test case. + * gfortran.dg/proc_decl_2.f90: Ditto. + * gfortran.dg/proc_decl_9.f90: Ditto. + * gfortran.dg/proc_decl_18.f90: Ditto. + * gfortran.dg/proc_ptr_40.f90: New. + * gfortran.dg/whole_file_7.f90: Modified error wording. + * gfortran.dg/whole_file_16.f90: Ditto. + * gfortran.dg/whole_file_17.f90: Add -pedantic. + * gfortran.dg/whole_file_18.f90: Modified error wording. + * gfortran.dg/whole_file_20.f03: Ditto. + * gfortran.fortran-torture/execute/intrinsic_associated.f90: Fix + invalid test case. + 2013-04-12 Richard Biener Revert diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_4.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_4.f90 index 3391fba882f..756ab2245c5 100644 --- a/gcc/testsuite/gfortran.dg/assumed_rank_4.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_rank_4.f90 @@ -20,8 +20,8 @@ end subroutine valid2 subroutine foo99(x) integer x(99) - call valid1(x) ! { dg-error "Procedure 'valid1' at .1. with assumed-rank dummy argument 'x' must have an explicit interface" } - call valid2(x(1)) ! { dg-error "Procedure 'valid2' at .1. with assumed-type dummy argument 'x' must have an explicit interface" } + call valid1(x) ! { dg-error "Explicit interface required" } + call valid2(x(1)) ! { dg-error "Explicit interface required" } end subroutine foo99 subroutine foo(x) diff --git a/gcc/testsuite/gfortran.dg/auto_char_len_4.f90 b/gcc/testsuite/gfortran.dg/auto_char_len_4.f90 index 6b4e26e6b45..72ee8450dc7 100644 --- a/gcc/testsuite/gfortran.dg/auto_char_len_4.f90 +++ b/gcc/testsuite/gfortran.dg/auto_char_len_4.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-fwhole-file" } +! { dg-options "-pedantic -fwhole-file" } ! ! Tests the fix for PR25087, in which the following invalid code ! was not detected. @@ -14,8 +14,8 @@ FUNCTION a() END FUNCTION a SUBROUTINE s(n) - CHARACTER(LEN=n), EXTERNAL :: a ! { dg-error "must have an explicit interface" } - CHARACTER(LEN=n), EXTERNAL :: d ! { dg-error "must have an explicit interface" } + CHARACTER(LEN=n), EXTERNAL :: a ! { dg-error "Character length mismatch" } + CHARACTER(LEN=n), EXTERNAL :: d ! { dg-error "Character length mismatch" } interface function b (m) ! This is OK CHARACTER(LEN=m) :: b diff --git a/gcc/testsuite/gfortran.dg/block_11.f90 b/gcc/testsuite/gfortran.dg/block_11.f90 index 2c2ce9083f6..6fe244d91e8 100644 --- a/gcc/testsuite/gfortran.dg/block_11.f90 +++ b/gcc/testsuite/gfortran.dg/block_11.f90 @@ -50,7 +50,7 @@ module m3 implicit none contains subroutine my_test() - procedure(), pointer :: ptr + procedure(sub), pointer :: ptr ! Before the fix, one had the link error ! "undefined reference to `sub.1909'" block diff --git a/gcc/testsuite/gfortran.dg/function_types_3.f90 b/gcc/testsuite/gfortran.dg/function_types_3.f90 index 49d5d5f561b..e8347251441 100644 --- a/gcc/testsuite/gfortran.dg/function_types_3.f90 +++ b/gcc/testsuite/gfortran.dg/function_types_3.f90 @@ -5,7 +5,7 @@ ! PR 50401: SIGSEGV in resolve_transfer interface - function f() ! { dg-error "must be a dummy argument" } + function f() ! { dg-error "must be a dummy argument|Interface mismatch in global procedure" } dimension f(*) end function end interface diff --git a/gcc/testsuite/gfortran.dg/global_references_1.f90 b/gcc/testsuite/gfortran.dg/global_references_1.f90 index 5e72dc9419b..cfff8b32c0b 100644 --- a/gcc/testsuite/gfortran.dg/global_references_1.f90 +++ b/gcc/testsuite/gfortran.dg/global_references_1.f90 @@ -23,7 +23,7 @@ function g(x) ! Global entity ! Function 'f' cannot be referenced as a subroutine. The previous ! definition is in 'line 12'. - call f(g) ! { dg-error "is already being used as a FUNCTION" } + call f(g) ! { dg-error "is already being used as a FUNCTION|Interface mismatch in global procedure" } end function g ! Error only appears once but testsuite associates with both lines. function h(x) ! { dg-error "is already being used as a FUNCTION" } @@ -59,7 +59,7 @@ END SUBROUTINE TT ! Function 'h' cannot be referenced as a subroutine. The previous ! definition is in 'line 29'. - call h (x) ! { dg-error "is already being used as a FUNCTION" } + call h (x) ! { dg-error "is already being used as a FUNCTION|Interface mismatch in global procedure" } ! PR23308=========================================================== ! Lahey - 2521-S: "SOURCE.F90", line 68: Intrinsic procedure name or diff --git a/gcc/testsuite/gfortran.dg/import2.f90 b/gcc/testsuite/gfortran.dg/import2.f90 index 9db21977daa..76c87d617dd 100644 --- a/gcc/testsuite/gfortran.dg/import2.f90 +++ b/gcc/testsuite/gfortran.dg/import2.f90 @@ -4,30 +4,6 @@ ! Test whether import does not work with -std=f95 ! PR fortran/29601 -subroutine test(x) - type myType3 - sequence - integer :: i - end type myType3 - type(myType3) :: x - if(x%i /= 7) call abort() - x%i = 1 -end subroutine test - - -subroutine bar(x,y) - type myType - sequence - integer :: i - end type myType - type(myType) :: x - integer(8) :: y - if(y /= 8) call abort() - if(x%i /= 2) call abort() - x%i = 5 - y = 42 -end subroutine bar - module testmod implicit none integer, parameter :: kind = 8 @@ -66,14 +42,4 @@ program foo end subroutine test end interface - type(myType) :: y - type(myType3) :: z - integer(dp) :: i8 - y%i = 2 - i8 = 8 - call bar(y,i8) ! { dg-error "Type mismatch in argument" } - if(y%i /= 5 .or. i8/= 42) call abort() - z%i = 7 - call test(z) ! { dg-error "Type mismatch in argument" } - if(z%i /= 1) call abort() end program foo diff --git a/gcc/testsuite/gfortran.dg/import6.f90 b/gcc/testsuite/gfortran.dg/import6.f90 index 1bf9669c5b6..d57a6368b74 100644 --- a/gcc/testsuite/gfortran.dg/import6.f90 +++ b/gcc/testsuite/gfortran.dg/import6.f90 @@ -7,6 +7,7 @@ ! subroutine func1(param) type :: my_type + sequence integer :: data end type my_type type(my_type) :: param @@ -15,6 +16,7 @@ end subroutine func1 subroutine func2(param) type :: my_type + sequence integer :: data end type my_type type(my_type) :: param @@ -22,6 +24,7 @@ subroutine func2(param) end subroutine func2 type :: my_type + sequence integer :: data end type my_type diff --git a/gcc/testsuite/gfortran.dg/proc_decl_18.f90 b/gcc/testsuite/gfortran.dg/proc_decl_18.f90 index 15993626cc9..c4216135106 100644 --- a/gcc/testsuite/gfortran.dg/proc_decl_18.f90 +++ b/gcc/testsuite/gfortran.dg/proc_decl_18.f90 @@ -23,7 +23,7 @@ implicit none abstract interface function abs_fun(x,sz) - integer :: x(:) + integer,intent(in) :: x(:) interface pure integer function sz(b) integer,intent(in) :: b(:) diff --git a/gcc/testsuite/gfortran.dg/proc_decl_2.f90 b/gcc/testsuite/gfortran.dg/proc_decl_2.f90 index a16b4db5f01..97e06148e27 100644 --- a/gcc/testsuite/gfortran.dg/proc_decl_2.f90 +++ b/gcc/testsuite/gfortran.dg/proc_decl_2.f90 @@ -124,12 +124,12 @@ integer function p2(x) end function subroutine p3(x) - real,intent(inout):: x + real :: x x=x+1.0 end subroutine subroutine p4(x) - real,intent(inout):: x + real :: x x=x-1.5 end subroutine @@ -137,7 +137,7 @@ subroutine p5() end subroutine subroutine p6(x) - real,intent(inout):: x + real :: x x=x*2. end subroutine diff --git a/gcc/testsuite/gfortran.dg/proc_decl_9.f90 b/gcc/testsuite/gfortran.dg/proc_decl_9.f90 index 08faee931e6..58ae321899e 100644 --- a/gcc/testsuite/gfortran.dg/proc_decl_9.f90 +++ b/gcc/testsuite/gfortran.dg/proc_decl_9.f90 @@ -2,7 +2,7 @@ ! PR33162 INTRINSIC functions as ACTUAL argument ! Test case adapted from PR by Jerry DeLisle real function t(x) - real ::x + real, intent(in) ::x t = x end function diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_40.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_40.f90 new file mode 100644 index 00000000000..dae91df1c3c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_40.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR 56261: [OOP] seg fault call procedure pointer on polymorphic array +! +! Contributed by Andrew Benson + + implicit none + type :: nc + end type + external :: qq + procedure( ), pointer :: f1 + procedure(ff), pointer :: f2 + + f1 => ff ! { dg-error "Explicit interface required" } + f2 => qq ! { dg-error "Explicit interface required" } + +contains + + subroutine ff (self) + class(nc) :: self + end subroutine + +end diff --git a/gcc/testsuite/gfortran.dg/whole_file_16.f90 b/gcc/testsuite/gfortran.dg/whole_file_16.f90 index 048350f1d7e..6c910f47a2c 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_16.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_16.f90 @@ -5,7 +5,7 @@ ! program main real, dimension(2) :: a - call foo(a) ! { dg-error "must have an explicit interface" } + call foo(a) ! { dg-error "Explicit interface required" } end program main subroutine foo(a) diff --git a/gcc/testsuite/gfortran.dg/whole_file_17.f90 b/gcc/testsuite/gfortran.dg/whole_file_17.f90 index 86272b848a8..a2a9d151511 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_17.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_17.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-fwhole-file" } +! { dg-options "-pedantic -fwhole-file" } ! ! PR fortran/30668 ! diff --git a/gcc/testsuite/gfortran.dg/whole_file_18.f90 b/gcc/testsuite/gfortran.dg/whole_file_18.f90 index f758408f81e..c483c7da100 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_18.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_18.f90 @@ -5,7 +5,7 @@ ! PROGRAM MAIN REAL A - CALL SUB(A) ! { dg-error "requires an explicit interface" } + CALL SUB(A) ! { dg-error "Explicit interface required" } END PROGRAM SUBROUTINE SUB(A,I) diff --git a/gcc/testsuite/gfortran.dg/whole_file_20.f03 b/gcc/testsuite/gfortran.dg/whole_file_20.f03 index 766851776bf..b3f77e46105 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_20.f03 +++ b/gcc/testsuite/gfortran.dg/whole_file_20.f03 @@ -17,8 +17,8 @@ PROGRAM main INTEGER :: coarr[*] - CALL coarray(coarr) ! { dg-error " must have an explicit interface" } - CALL polymorph(tt) ! { dg-error " must have an explicit interface" } + CALL coarray(coarr) ! { dg-error "Explicit interface required" } + CALL polymorph(tt) ! { dg-error "Explicit interface required" } END PROGRAM SUBROUTINE coarray(a) diff --git a/gcc/testsuite/gfortran.dg/whole_file_7.f90 b/gcc/testsuite/gfortran.dg/whole_file_7.f90 index 53fed228ae2..3225304397c 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_7.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_7.f90 @@ -29,6 +29,6 @@ end function test program arr ! The error was not picked up causing an ICE real, dimension(2) :: res - res = test(2) ! { dg-error "needs an explicit INTERFACE" } + res = test(2) ! { dg-error "Explicit interface required" } print *, res end program diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90 index 586f766010a..22ea6f0a62a 100644 --- a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90 +++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90 @@ -121,7 +121,7 @@ subroutine associated_2 () interface subroutine sub1 (a, ap) integer, pointer :: ap(:, :) - integer, target :: a(10, 1) + integer, target :: a(10, 10) end endinterface