From patchwork Thu Aug 15 11:35:05 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 1147550 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-507044-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=pass (p=quarantine dis=none) header.from=netcologne.de Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="QKlmjfGc"; dkim=pass (2048-bit key; unprotected) header.d=netcologne.de header.i=@netcologne.de header.b="eF4N+Bta"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 468PWz2mWcz9sN1 for ; Thu, 15 Aug 2019 21:35:25 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; q=dns; s=default; b=s6sMSmIHnpwjXTipdpNEhaKiWVNBRPs42+GFrrwMECeQUIzVCL gFYfIT0dj83ronEUmrxd53PqgRs6EpIjQl+qMFl9OxtYscJyyzEFv/oEEdrYOKqq sqS5wP0zIiYU7gccZ+Yg7I9iJnNF21cyFDqi878dT59WOoXxiVqVl6dKo= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; s= default; bh=6WItNpuWQFGERW2/AlXXH5N1Fcg=; b=QKlmjfGcf34BAQuybQWn C+9t692e9i5+dJc7A8cbHE7+f1+ZnyszmT4XWwlem80yoQJ1rOg5bAYtY+5NVbC6 632xL/6kt5TAn1XPwzZH04rBcob60z+pfVniUs8MwJembkPtvLtEg9RxmE1mT3Ew 8yZPWA4vnIz3F2KsYP2NRes= Received: (qmail 58161 invoked by alias); 15 Aug 2019 11:35:17 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 58143 invoked by uid 89); 15 Aug 2019 11:35:16 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.3 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, KAM_NUMSUBJECT, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.1 spammy=274394, LOC, H*Ad:U*tkoenig, resolve_call X-HELO: cc-smtpout2.netcologne.de Received: from cc-smtpout2.netcologne.de (HELO cc-smtpout2.netcologne.de) (89.1.8.212) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 15 Aug 2019 11:35:13 +0000 Received: from cc-smtpin3.netcologne.de (cc-smtpin3.netcologne.de [89.1.8.203]) by cc-smtpout2.netcologne.de (Postfix) with ESMTP id 6A40F12662; Thu, 15 Aug 2019 13:35:07 +0200 (CEST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=netcologne.de; s=nc1116a; t=1565868907; bh=IdZtoR3O9A8MVuV9qzwBVdwbB3hWDthp6WrDfYpH6b8=; h=To:From:Subject:Message-ID:Date:From; b=eF4N+BtauXWqLWmbc6u8jqfQz3fnLRmERN//s2aMhLOyyC0/DTKWHDvadN4x/0Hyi 8Bxb2t0OWMipVivkj42OXX/aAsq5uUmmMDAAv4jutcn1fOuWbUGQ0OhjBAnpaik/Zy AmTNdjkKMrsty4zm8YxBhqYP6wLZHfbvEPD/FStNFhsxNQx3XX3y6qre2v/XUTsJTA BezO7ivuj0M0lsH5QM8PbVmlSgataaCTmqC3yxUck0o7tqjT1WvwdGGGrkGEC05ubf 2xnkgNyn4QC4/R7Nkx+EvqS0/oUjwv5S+lBJjFswVqj1v4ZJ95VuSAYhXCr3UFbNTG AhM55XwHBYAjQ== Received: from localhost (localhost [127.0.0.1]) by cc-smtpin3.netcologne.de (Postfix) with ESMTP id 5EB4D11ECF; Thu, 15 Aug 2019 13:35:07 +0200 (CEST) Received: from [2001:4dd6:e4c:0:7285:c2ff:fe6c:992d] (helo=cc-smtpin3.netcologne.de) by localhost with ESMTP (eXpurgate 4.6.0) (envelope-from ) id 5d55436b-388c-7f0000012729-7f000001a27e-1 for ; Thu, 15 Aug 2019 13:35:07 +0200 Received: from [IPv6:2001:4dd6:e4c:0:7285:c2ff:fe6c:992d] (2001-4dd6-e4c-0-7285-c2ff-fe6c-992d.ipv6dyn.netcologne.de [IPv6:2001:4dd6:e4c:0:7285:c2ff:fe6c:992d]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by cc-smtpin3.netcologne.de (Postfix) with ESMTPSA; Thu, 15 Aug 2019 13:35:06 +0200 (CEST) To: "fortran@gcc.gnu.org" , gcc-patches From: Thomas Koenig Subject: [patch, fortran] Fix PR 91443 Message-ID: <97473f33-2ec4-0fbf-a6b3-e96615254713@netcologne.de> Date: Thu, 15 Aug 2019 13:35:05 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:60.0) Gecko/20100101 Thunderbird/60.7.2 MIME-Version: 1.0 Hello world, this patch fixes PR 91443, in which we did not warn about a mismatched external procedure. The problem was that the module this was called in was resolved before parsing of the procedure ever started. The approach taken here is to move the checking of external procedures to a stage after normal resolution. And, of course, fix the resulting fallout from regression-testing :-) There is also one policy change in the patch. Previously, we only warned about mismatched declarations. Now, this is a hard error unless the user specifies -std=legacy. The reason is that we have not yet solved our single declaration problem, but it cannot be solved unless all of a procedure's callers match. People who have such broken code should at least be made aware that they have a problem. However, I would like to have some sort of agreement on this point before the patch is committed. This can also be changed (see the code at the bottom of frontend-passes.c). Once this is in, the next step is to issue errors for mismatching calls where the callee is not in the same file. This can be done with the infrastructure of this patch. So, OK for trunk? Regards Thomas 2019-08-15 Thomas Koenig PR fortran/91443 * frontend-passes.c (check_externals_expr): New function. (check_externals_code): New function. (gfc_check_externals): New function. * gfortran.h (debug): Add prototypes for gfc_symbol * and gfc_expr *. (gfc_check_externals): Add prototype. * interface.c (compare_actual_formal): Do not complain about alternate returns if the formal argument is optional. (gfc_procedure_use): Handle cases when an error has been issued previously. Break long line. * parse.c (gfc_parse_file): Call gfc_check_externals for all external procedures. * resolve.c (resolve_global_procedure): Remove checking of argument list. 2019-08-15 Thomas Koenig PR fortran/91443 * gfortran.dg/argument_checking_19.f90: New test. * gfortran.dg/altreturn_10.f90: Change dg-warning to dg-error. * gfortran.dg/dec_union_11.f90: Add -std=legacy. * gfortran.dg/hollerith8.f90: Likewise. Remove warning for Hollerith constant. * gfortran.dg/integer_exponentiation_2.f90: New subroutine gee_i8; use it to avoid type mismatches. * gfortran.dg/pr41011.f: Add -std=legacy. * gfortran.dg/whole_file_1.f90: Change warnings to errors. * gfortran.dg/whole_file_2.f90: Likewise. Index: fortran/frontend-passes.c =================================================================== --- fortran/frontend-passes.c (Revision 274394) +++ fortran/frontend-passes.c (Arbeitskopie) @@ -56,7 +56,6 @@ static gfc_expr* check_conjg_transpose_variable (g static int call_external_blas (gfc_code **, int *, void *); static int matmul_temp_args (gfc_code **, int *,void *data); static int index_interchange (gfc_code **, int*, void *); - static bool is_fe_temp (gfc_expr *e); #ifdef CHECKING_P @@ -5364,3 +5363,100 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t code } return 0; } + +/* As a post-resolution step, check that all global symbols which are + not declared in the source file match in their call signatures. + We do this by looping over the code (and expressions). The first call + we happen to find is assumed to be canonical. */ + +/* Callback for external functions. */ + +static int +check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_expr *e = *ep; + gfc_symbol *sym, *def_sym; + gfc_gsymbol *gsym; + + if (e->expr_type != EXPR_FUNCTION) + return 0; + + sym = e->value.function.esym; + + if (sym == NULL || sym->attr.is_bind_c) + return 0; + + if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN) + return 0; + + gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); + if (gsym == NULL) + return 0; + + gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); + + if (sym && def_sym) + gfc_procedure_use (def_sym, &e->value.function.actual, &e->where); + + return 0; +} + +/* Callback for external code. */ + +static int +check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code *co = *c; + gfc_symbol *sym, *def_sym; + gfc_gsymbol *gsym; + + if (co->op != EXEC_CALL) + return 0; + + sym = co->resolved_sym; + if (sym == NULL || sym->attr.is_bind_c) + return 0; + + if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN) + return 0; + + if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL) + return 0; + + gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); + if (gsym == NULL) + return 0; + + gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); + + if (sym && def_sym) + gfc_procedure_use (def_sym, &co->ext.actual, &co->loc); + + return 0; +} + +/* Called routine. */ + +void +gfc_check_externals (gfc_namespace *ns) +{ + + gfc_clear_error (); + + /* Turn errors into warnings if -std=legacy is given by the user. */ + + if (!pedantic && !(gfc_option.warn_std & GFC_STD_LEGACY)) + gfc_errors_to_warnings (true); + + gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL); + + for (ns = ns->contained; ns; ns = ns->sibling) + { + if (ns->code == NULL || ns->code->op != EXEC_BLOCK) + gfc_check_externals (ns); + } + + gfc_errors_to_warnings (false); +} Index: fortran/gfortran.h =================================================================== --- fortran/gfortran.h (Revision 274370) +++ fortran/gfortran.h (Arbeitskopie) @@ -3477,6 +3477,8 @@ void gfc_dump_parse_tree (gfc_namespace *, FILE *) void gfc_dump_c_prototypes (gfc_namespace *, FILE *); void gfc_dump_external_c_prototypes (FILE *); void gfc_dump_global_symbols (FILE *); +void debug (gfc_symbol *); +void debug (gfc_expr *); /* parse.c */ bool gfc_parse_file (void); @@ -3551,6 +3553,7 @@ int gfc_dummy_code_callback (gfc_code **, int *, v int gfc_expr_walker (gfc_expr **, walk_expr_fn_t, void *); int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *); bool gfc_has_dimen_vector_ref (gfc_expr *e); +void gfc_check_externals (gfc_namespace *); /* simplify.c */ Index: fortran/interface.c =================================================================== --- fortran/interface.c (Revision 274370) +++ fortran/interface.c (Arbeitskopie) @@ -2979,10 +2979,15 @@ compare_actual_formal (gfc_actual_arglist **ap, gf if (a->expr == NULL) { - if (where) - gfc_error_now ("Unexpected alternate return specifier in " - "subroutine call at %L", where); - return false; + if (f->sym->attr.optional) + continue; + else + { + if (where) + gfc_error_now ("Unexpected alternate return specifier in " + "subroutine call at %L", where); + return false; + } } /* Make sure that intrinsic vtables exist for calls to unlimited @@ -3723,6 +3728,9 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg for (a = *ap; a; a = a->next) { + if (a->expr && a->expr->error) + return false; + /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ if (a->name != NULL && a->name[0] != '%') { @@ -3738,6 +3746,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg gfc_error ("Assumed-type argument %s at %L requires an explicit " "interface", a->expr->symtree->n.sym->name, &a->expr->where); + a->expr->error = 1; break; } @@ -3751,6 +3760,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE " "component at %L requires an explicit interface for " "procedure %qs", &a->expr->where, sym->name); + a->expr->error = 1; break; } @@ -3764,6 +3774,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE " "component at %L requires an explicit interface for " "procedure %qs", &a->expr->where, sym->name); + a->expr->error = 1; break; } @@ -3770,7 +3781,9 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg if (a->expr && a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN) { - gfc_error ("MOLD argument to NULL required at %L", &a->expr->where); + gfc_error ("MOLD argument to NULL required at %L", + &a->expr->where); + a->expr->error = 1; return false; } @@ -3780,6 +3793,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg { gfc_error ("Assumed-rank argument requires an explicit interface " "at %L", &a->expr->where); + a->expr->error = 1; return false; } } Index: fortran/parse.c =================================================================== --- fortran/parse.c (Revision 274370) +++ fortran/parse.c (Arbeitskopie) @@ -6319,6 +6319,12 @@ done: /* Do the resolution. */ resolve_all_program_units (gfc_global_ns_list); + + /* Fixup for external procedures. */ + for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; + gfc_current_ns = gfc_current_ns->sibling) + gfc_check_externals (gfc_current_ns); + /* Do the parse tree dump. */ gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL; Index: fortran/resolve.c =================================================================== --- fortran/resolve.c (Revision 274370) +++ fortran/resolve.c (Arbeitskopie) @@ -2506,8 +2506,7 @@ gfc_explicit_interface_required (gfc_symbol *sym, static void -resolve_global_procedure (gfc_symbol *sym, locus *where, - gfc_actual_arglist **actual, int sub) +resolve_global_procedure (gfc_symbol *sym, locus *where, int sub) { gfc_gsymbol * gsym; gfc_namespace *ns; @@ -2615,14 +2614,6 @@ static void " %s", sym->name, &sym->declared_at, reason); goto done; } - - if (!pedantic - || ((gfc_option.warn_std & GFC_STD_LEGACY) - && !(gfc_option.warn_std & GFC_STD_GNU))) - gfc_errors_to_warnings (true); - - if (sym->attr.if_source != IFSRC_IFBODY) - gfc_procedure_use (def_sym, actual, where); } done: @@ -3198,8 +3189,7 @@ resolve_function (gfc_expr *expr) /* If the procedure is external, check for usage. */ if (sym && is_external_proc (sym)) - resolve_global_procedure (sym, &expr->where, - &expr->value.function.actual, 0); + resolve_global_procedure (sym, &expr->where, 0); if (sym && sym->ts.type == BT_CHARACTER && sym->ts.u.cl @@ -3675,7 +3665,7 @@ resolve_call (gfc_code *c) /* If external, check for usage. */ if (csym && is_external_proc (csym)) - resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1); + resolve_global_procedure (csym, &c->loc, 1); t = true; if (c->resolved_sym == NULL) Index: testsuite/gfortran.dg/altreturn_10.f90 =================================================================== --- testsuite/gfortran.dg/altreturn_10.f90 (Revision 274370) +++ testsuite/gfortran.dg/altreturn_10.f90 (Arbeitskopie) @@ -14,6 +14,6 @@ subroutine sub (x) end subroutine sub2 call sub (*99) ! { dg-error "Unexpected alternate return specifier" } - call sub (99.) ! { dg-warning "Type mismatch in argument" } + call sub (99.) ! { dg-error "Type mismatch in argument" } 99 stop end Index: testsuite/gfortran.dg/dec_union_11.f90 =================================================================== --- testsuite/gfortran.dg/dec_union_11.f90 (Revision 274370) +++ testsuite/gfortran.dg/dec_union_11.f90 (Arbeitskopie) @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-g -fdec-structure" } +! { dg-options "-g -fdec-structure -std=legacy" } ! ! Test a regression where typespecs of unions containing character buffers of ! different lengths where copied, resulting in a bad gimple tree state. Index: testsuite/gfortran.dg/hollerith8.f90 =================================================================== --- testsuite/gfortran.dg/hollerith8.f90 (Revision 274370) +++ testsuite/gfortran.dg/hollerith8.f90 (Arbeitskopie) @@ -1,9 +1,9 @@ ! { dg-do run } -! { dg-options "-std=gnu" } +! { dg-options "-std=legacy" } ! PR43217 Output of Hollerith constants which are not a multiple of 4 bytes ! Test case prepared from OP by Jerry DeLisle program hello2 - call wrtout (9hHELLO YOU, 9) + call wrtout (9hHELLO YOU, 9) ! { dg-warning "Rank mismatch" } stop end @@ -22,5 +22,3 @@ subroutine wrtout (iarray, nchrs) & outstr.ne."48454C4C 4F20594F 55202020") STOP 1 return end -! { dg-warning "Hollerith constant" "" { target *-*-* } 6 } -! { dg-warning "Rank mismatch" "" { target *-*-* } 6 } Index: testsuite/gfortran.dg/integer_exponentiation_2.f90 =================================================================== --- testsuite/gfortran.dg/integer_exponentiation_2.f90 (Revision 274370) +++ testsuite/gfortran.dg/integer_exponentiation_2.f90 (Arbeitskopie) @@ -139,16 +139,16 @@ subroutine foo(a) call gee_i(i**(-huge(0_4))) call gee_i(i**(-huge(0_4)-1_4)) - call gee_i(i**0_8) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**1_8) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**2_8) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**3_8) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**(-1_8)) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**(-2_8)) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**(-3_8)) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**huge(0_8)) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**(-huge(0_8))) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**(-huge(0_8)-1_8)) ! { dg-warning "Type mismatch in argument" } + call gee_i8(i**0_8) + call gee_i8(i**1_8) + call gee_i8(i**2_8) + call gee_i8(i**3_8) + call gee_i8(i**(-1_8)) + call gee_i8(i**(-2_8)) + call gee_i8(i**(-3_8)) + call gee_i8(i**huge(0_8)) + call gee_i8(i**(-huge(0_8))) + call gee_i8(i**(-huge(0_8)-1_8)) ! Real call gee_r(a**0_1) @@ -245,6 +245,10 @@ subroutine gee_i(i) integer :: i end subroutine gee_i +subroutine gee_i8(i) + integer(kind=8) :: i +end subroutine gee_i8 + subroutine gee_r(r) real :: r end subroutine gee_r Index: testsuite/gfortran.dg/pr41011.f =================================================================== --- testsuite/gfortran.dg/pr41011.f (Revision 274370) +++ testsuite/gfortran.dg/pr41011.f (Arbeitskopie) @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-O3" } +! { dg-options "-O3 -std=legacy" } CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,DCDX, ! { dg-warning "Rank mismatch" } *ITY,ISH,NSMT,F) CALL DCTDX(NX,NY,NX1,NFILT,C(MLAG),DCDX(MLAG),HELP,HELPA, Index: testsuite/gfortran.dg/whole_file_1.f90 =================================================================== --- testsuite/gfortran.dg/whole_file_1.f90 (Revision 274370) +++ testsuite/gfortran.dg/whole_file_1.f90 (Arbeitskopie) @@ -19,7 +19,7 @@ subroutine b integer :: u1 end type type (u) :: q - call a(q) ! { dg-warning "Type mismatch" } + call a(q) ! { dg-error "Type mismatch" } print *, q%u1 end subroutine @@ -36,7 +36,7 @@ subroutine d integer :: u1 end type type (u) :: q - call c(q) ! { dg-warning "Type mismatch" } + call c(q) ! { dg-error "Type mismatch" } print *, q%u1 end subroutine Index: testsuite/gfortran.dg/whole_file_2.f90 =================================================================== --- testsuite/gfortran.dg/whole_file_2.f90 (Revision 274370) +++ testsuite/gfortran.dg/whole_file_2.f90 (Arbeitskopie) @@ -14,8 +14,8 @@ end function program gg real :: h character (5) :: chr = 'hello' -h = a(); ! { dg-warning "Missing actual argument" } -call test ([chr]) ! { dg-warning "Rank mismatch" } +h = a(); ! { dg-error "Missing actual argument" } +call test ([chr]) ! { dg-error "Rank mismatch" } end program gg subroutine test (a)