Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (revision 197769) +++ gcc/fortran/expr.c (working copy) @@ -3556,6 +3556,22 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex 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)) { Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 197769) +++ gcc/fortran/gfortran.h (working copy) @@ -2843,6 +2843,7 @@ match gfc_iso_c_sub_interface(gfc_code *, gfc_symb 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 */ Index: gcc/fortran/interface.c =================================================================== --- gcc/fortran/interface.c (revision 197769) +++ gcc/fortran/interface.c (working copy) @@ -1239,7 +1239,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_ 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); Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 197769) +++ gcc/fortran/resolve.c (working copy) @@ -2118,6 +2118,126 @@ not_entry_self_reference (gfc_symbol *sym, gfc_na 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 * gfc_gsymbol * gsym; gfc_namespace *ns; enum gfc_symbol_type type; + char reason[200]; type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; @@ -2195,162 +2316,16 @@ resolve_global_procedure (gfc_symbol *sym, locus * } } - /* Differences in constant character lengths. */ - if (sym->attr.function && sym->ts.type == BT_CHARACTER) - { - long int l1 = 0, l2 = 0; - gfc_charlen *cl1 = sym->ts.u.cl; - gfc_charlen *cl2 = def_sym->ts.u.cl; + 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); + else if (sym->attr.if_source == IFSRC_UNKNOWN + && gfc_explicit_interface_required (def_sym, reason, + sizeof(reason))) + gfc_error ("Explicit interface required for '%s' at %L: %s", + sym->name, &sym->declared_at, reason); - 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); - } - - /* 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) - { - 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; - } - } - - 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); - - /* 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 (!pedantic || ((gfc_option.warn_std & GFC_STD_LEGACY) && !(gfc_option.warn_std & GFC_STD_GNU))) Index: gcc/testsuite/gfortran.dg/assumed_rank_4.f90 =================================================================== --- gcc/testsuite/gfortran.dg/assumed_rank_4.f90 (revision 197769) +++ gcc/testsuite/gfortran.dg/assumed_rank_4.f90 (working copy) @@ -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) Index: gcc/testsuite/gfortran.dg/auto_char_len_4.f90 =================================================================== --- gcc/testsuite/gfortran.dg/auto_char_len_4.f90 (revision 197769) +++ gcc/testsuite/gfortran.dg/auto_char_len_4.f90 (working copy) @@ -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 Index: gcc/testsuite/gfortran.dg/block_11.f90 =================================================================== --- gcc/testsuite/gfortran.dg/block_11.f90 (revision 197769) +++ gcc/testsuite/gfortran.dg/block_11.f90 (working copy) @@ -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 Index: gcc/testsuite/gfortran.dg/g77/19990218-0.f =================================================================== --- gcc/testsuite/gfortran.dg/g77/19990218-0.f (revision 197769) +++ gcc/testsuite/gfortran.dg/g77/19990218-0.f (working copy) @@ -2,7 +2,7 @@ c { dg-do compile } program test double precision a,b,c data a,b/1.0d-46,1.0d0/ - c=fun(a,b) ! { dg-error "Return type mismatch of function" } + c=fun(a,b) ! { dg-error "Type/rank mismatch in function result" } print*,'in main: fun=',c end double precision function fun(a,b) Index: gcc/testsuite/gfortran.dg/g77/19990218-1.f =================================================================== --- gcc/testsuite/gfortran.dg/g77/19990218-1.f (revision 197769) +++ gcc/testsuite/gfortran.dg/g77/19990218-1.f (working copy) @@ -20,6 +20,6 @@ c program test double precision a,b,c data a,b/1.0d-46,1.0d0/ - c=fun(a,b) ! { dg-error "Return type mismatch of function" } + c=fun(a,b) ! { dg-error "Type/rank mismatch in function result" } print*,'in main: fun=',c end Index: gcc/testsuite/gfortran.dg/proc_decl_18.f90 =================================================================== --- gcc/testsuite/gfortran.dg/proc_decl_18.f90 (revision 197769) +++ gcc/testsuite/gfortran.dg/proc_decl_18.f90 (working copy) @@ -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(:) Index: gcc/testsuite/gfortran.dg/proc_decl_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/proc_decl_2.f90 (revision 197769) +++ gcc/testsuite/gfortran.dg/proc_decl_2.f90 (working copy) @@ -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 Index: gcc/testsuite/gfortran.dg/proc_decl_9.f90 =================================================================== --- gcc/testsuite/gfortran.dg/proc_decl_9.f90 (revision 197769) +++ gcc/testsuite/gfortran.dg/proc_decl_9.f90 (working copy) @@ -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 Index: gcc/testsuite/gfortran.dg/whole_file_16.f90 =================================================================== --- gcc/testsuite/gfortran.dg/whole_file_16.f90 (revision 197769) +++ gcc/testsuite/gfortran.dg/whole_file_16.f90 (working copy) @@ -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) Index: gcc/testsuite/gfortran.dg/whole_file_17.f90 =================================================================== --- gcc/testsuite/gfortran.dg/whole_file_17.f90 (revision 197769) +++ gcc/testsuite/gfortran.dg/whole_file_17.f90 (working copy) @@ -17,6 +17,6 @@ program xx INTEGER :: a CHARACTER(len=4) :: s, string ! { dg-error "Character length mismatch" } - a = two() ! { dg-error "Return type mismatch" } + a = two() ! { dg-error "Type/rank mismatch" } s = string() end program xx Index: gcc/testsuite/gfortran.dg/whole_file_18.f90 =================================================================== --- gcc/testsuite/gfortran.dg/whole_file_18.f90 (revision 197769) +++ gcc/testsuite/gfortran.dg/whole_file_18.f90 (working copy) @@ -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) Index: gcc/testsuite/gfortran.dg/whole_file_20.f03 =================================================================== --- gcc/testsuite/gfortran.dg/whole_file_20.f03 (revision 197769) +++ gcc/testsuite/gfortran.dg/whole_file_20.f03 (working copy) @@ -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) Index: gcc/testsuite/gfortran.dg/whole_file_34.f90 =================================================================== --- gcc/testsuite/gfortran.dg/whole_file_34.f90 (revision 197769) +++ gcc/testsuite/gfortran.dg/whole_file_34.f90 (working copy) @@ -6,7 +6,7 @@ ! function foo () end function foo - character(4), external :: foo ! { dg-error "Return type mismatch of function" } + character(4), external :: foo ! { dg-error "Type/rank mismatch" } character(4) :: x x = foo () END Index: gcc/testsuite/gfortran.dg/whole_file_7.f90 =================================================================== --- gcc/testsuite/gfortran.dg/whole_file_7.f90 (revision 197769) +++ gcc/testsuite/gfortran.dg/whole_file_7.f90 (working copy) @@ -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 "Interface mismatch in global procedure" } print *, res end program Index: gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90 =================================================================== --- gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90 (revision 197769) +++ gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90 (working copy) @@ -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