From patchwork Tue Aug 20 20:32:37 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Thomas_K=C3=B6nig?= X-Patchwork-Id: 1150356 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-507397-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=tkoenig.net Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="GTM/LQqO"; dkim=fail reason="signature verification failed" (2048-bit key; unprotected) header.d=tkoenig.net header.i=@tkoenig.net header.b="CctTuEPM"; 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 46CjCy09DHz9sNF for ; Wed, 21 Aug 2019 06:32:59 +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=xM9oXCT+QTNXv+1vxbLLFGBOXhcg6mdVau9lBbNr8JTU4n0YhN 1sDwXzdQ/5xr5xKbyUtrXlg01NifKdm5k8PsC7vJh2tGMyYaCVcTzQ2WpU36rqaG krj+2rObfWzuazyeBFPr+6aL9giXhEIU0Zncx514CE4jjbkSbqeEfbylM= 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=pnOZWGW8ysoWHpOnhg7dPR7GLP8=; b=GTM/LQqO3bnNiKHaf4CY Q6kla0eY/u3wO/MgSYsFA0/+qUxzv6aSq97BGgvSviET2wRk6fS2E3dD0q6Nb1xU TcUjMRdPH8waVjq048cGJHPRuCjHGgexJRkt+LC+KiN0Rj6zI4BQZKqzU8puhlqv FKkafb1al5Xnv67HcYBMKBU= Received: (qmail 10069 invoked by alias); 20 Aug 2019 20:32:46 -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 10042 invoked by uid 89); 20 Aug 2019 20:32:45 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.1 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_PASS autolearn=ham version=3.3.1 spammy=nicht, ups, SIN, grade X-HELO: mo4-p00-ob.smtp.rzone.de Received: from mo4-p00-ob.smtp.rzone.de (HELO mo4-p00-ob.smtp.rzone.de) (85.215.255.20) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 20 Aug 2019 20:32:41 +0000 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; t=1566333158; s=strato-dkim-0002; d=tkoenig.net; h=Date:Message-ID:Subject:From:To:X-RZG-CLASS-ID:X-RZG-AUTH:From: Subject:Sender; bh=7R/WOzvCAXv0Xj8WrtsWdsSRGBCZBkTkM3KjcE0fZ7g=; b=CctTuEPM6Lbf/lQQZ6bus6C9ABdbk7VFn1c8M8xNoQKkbLJ+8cjY2JVnwlrwQiccRc EouTeL6jTVBrlRFEcA9QsIWIuLihnDJ0i42euAMtkX6CMKXg3a9OmL3zL7bFnxSHYOmX 9xrh+jyqPOWqgITbDMqfvGn5fAxLv1mY3IWST3fkq9mUccJKAW1mT1XEevLMPb2ADKjD D6bztk7J7m/o0eeJnfHyHkF60grYAVmGeCSoVtQlSkdzZHk1l88y92CzY8BzuYlv3eRF Vy/PUVeDDfRSLYKmubpYswsA8j+r61BbxAUSC+I7fCkJGKpKDPIjzhXC4Cx3kISwNVLR GOoQ== Received: from [IPv6:2001:4dd7:34e1:0:7285:c2ff:fe6c:992d] by smtp.strato.de (RZmta 44.26.1 AUTH) with ESMTPSA id m07349v7KKWbSND (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (curve secp521r1 with 521 ECDH bits, eq. 15360 bits RSA)) (Client did not present a certificate); Tue, 20 Aug 2019 22:32:37 +0200 (CEST) To: "fortran@gcc.gnu.org" , gcc-patches From: =?utf-8?q?Thomas_K=C3=B6nig?= Subject: [patch, fortran] Fix PR 91390 - treatment of extra parameter in a subroutine call Message-ID: <81d346ae-3da0-d082-234d-a0cc64050a7e@tkoenig.net> Date: Tue, 20 Aug 2019 22:32:37 +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, here is the next installment of checking for mismatched calls, this time for mismatching CALLs. The solution is to build a separate namespace with procedure arguments determined from the actual arguments the first time a procedure is seen, and then compare it against that on subsequent calls. This has uncovered quite a few examples of non-conforming code in our testsuite, so no separate test case needed, IMHO. So, OK for trunk? (The -std=legacy question can be settled later). 2019-08-20 Thomas Koenig PR fortran/91390 * frontend-passes.c (check_externals_procedure): New function. If a procedure is not in the translation unit, create an "interface" for it, including its formal arguments. (check_externals_code): Use check_externals_procedure for common code with check_externals_expr. (check_externals_expr): Vice versa. * gfortran.h (gfc_get_formal_from_actual-arglist): New prototype. (gfc_compare_actual_formal): New prototype. * interface.c (compare_actual_formal): Rename to (gfc_compare_actual_forma): New function, make global. (gfc_get_formal_from_actual_arglist): Make global, and move here from * trans-types.c (get_formal_from_actual_arglist): Remove here. (gfc_get_function_type): Use gfc_get_formal_from_actual_arglist. 2019-08-20 Thomas Koenig PR fortran/91390 * gfortran.dg/bessel_3.f90: Add type mismatch errors. * gfortran.dg/coarray_7.f90: Rename subroutines to avoid additional errors. * gfortran.dg/g77/20010519-1.f: Add -std=legacy. Remove warnings for ASSIGN. Add warnings for type mismatch. * gfortran.dg/goacc/acc_on_device-1.f95: Add -std=legacy. Add cath-all warning. * gfortran.dg/internal_pack_9.f90: Rename subroutine to avoid type error. * gfortran.dg/internal_pack_9.f90: Add -std=legacy. Add warnings for type mismatch. * gfortran.dg/pr39937.f: Add -std=legacy and type warnings. Move here from * gfortran.fortran-torture/compile/pr39937.f: Move to gfortran.dg. Index: fortran/frontend-passes.c =================================================================== --- fortran/frontend-passes.c (Revision 274623) +++ fortran/frontend-passes.c (Arbeitskopie) @@ -5369,25 +5369,22 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t code 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. */ +/* Common tests for argument checking for both functions and subroutines. */ + static int -check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) +check_externals_procedure (gfc_symbol *sym, locus *loc, gfc_actual_arglist *actual) { - gfc_expr *e = *ep; - gfc_symbol *sym, *def_sym; gfc_gsymbol *gsym; + gfc_symbol *def_sym = NULL; - if (e->expr_type != EXPR_FUNCTION) + if (sym == NULL || sym->attr.is_bind_c) return 0; - sym = e->value.function.esym; - - if (sym == NULL || sym->attr.is_bind_c) + if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN) return 0; - if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN) + if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL) return 0; gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); @@ -5394,15 +5391,39 @@ static int if (gsym == NULL) return 0; - gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); + if (gsym->ns) + 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); + if (def_sym) + { + gfc_procedure_use (def_sym, &actual, loc); + return 0; + } + /* First time we have seen this procedure called. Let's create an + "interface" from the call and put it into a new namespace. */ + gfc_namespace *save_ns; + gfc_symbol *new_sym; + + gsym->where = *loc; + save_ns = gfc_current_ns; + gsym->ns = gfc_get_namespace (gfc_current_ns, 0); + gsym->ns->proc_name = sym; + + gfc_get_symbol (sym->name, gsym->ns, &new_sym); + gcc_assert (new_sym); + new_sym->attr = sym->attr; + new_sym->attr.if_source = IFSRC_DECL; + gfc_current_ns = gsym->ns; + + gfc_get_formal_from_actual_arglist (new_sym, actual); + gfc_current_ns = save_ns; + return 0; + } -/* Callback for external code. */ +/* Callback for calls of external routines. */ static int check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, @@ -5409,32 +5430,43 @@ check_externals_code (gfc_code **c, int *walk_subt void *data ATTRIBUTE_UNUSED) { gfc_code *co = *c; - gfc_symbol *sym, *def_sym; - gfc_gsymbol *gsym; + gfc_symbol *sym; + locus *loc; + gfc_actual_arglist *actual; if (co->op != EXEC_CALL) return 0; sym = co->resolved_sym; - if (sym == NULL || sym->attr.is_bind_c) - return 0; + loc = &co->loc; + actual = co->ext.actual; - if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN) - return 0; + return check_externals_procedure (sym, loc, actual); - if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL) +} + +/* 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; + locus *loc; + gfc_actual_arglist *actual; + + if (e->expr_type != EXPR_FUNCTION) return 0; - gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); - if (gsym == NULL) + sym = e->value.function.esym; + if (sym == NULL) return 0; - gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); + loc = &e->where; + actual = e->value.function.actual; - if (sym && def_sym) - gfc_procedure_use (def_sym, &co->ext.actual, &co->loc); - - return 0; + return check_externals_procedure (sym, loc, actual); } /* Called routine. */ Index: fortran/gfortran.h =================================================================== --- fortran/gfortran.h (Revision 274623) +++ fortran/gfortran.h (Arbeitskopie) @@ -3421,6 +3421,9 @@ bool gfc_check_typebound_override (gfc_symtree*, g void gfc_check_dtio_interfaces (gfc_symbol*); gfc_symtree* gfc_find_typebound_dtio_proc (gfc_symbol *, bool, bool); gfc_symbol* gfc_find_specific_dtio_proc (gfc_symbol*, bool, bool); +void gfc_get_formal_from_actual_arglist (gfc_symbol *, gfc_actual_arglist *); +bool gfc_compare_actual_formal (gfc_actual_arglist **, gfc_formal_arglist *, + int, int, bool, locus *); /* io.c */ Index: fortran/interface.c =================================================================== --- fortran/interface.c (Revision 274623) +++ fortran/interface.c (Arbeitskopie) @@ -2878,10 +2878,10 @@ lookup_arg_fuzzy (const char *arg, gfc_formal_argl errors when things don't match instead of just returning the status code. */ -static bool -compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, - int ranks_must_agree, int is_elemental, - bool in_statement_function, locus *where) +bool +gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, + int ranks_must_agree, int is_elemental, + bool in_statement_function, locus *where) { gfc_actual_arglist **new_arg, *a, *actual; gfc_formal_arglist *f; @@ -3805,8 +3805,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arg /* For a statement function, check that types and type parameters of actual arguments and dummy arguments match. */ - if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, - sym->attr.proc == PROC_ST_FUNCTION, where)) + if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, + sym->attr.proc == PROC_ST_FUNCTION, where)) return false; if (!check_intents (dummy_args, *ap)) @@ -3854,7 +3854,7 @@ gfc_ppc_use (gfc_component *comp, gfc_actual_argli return; } - if (!compare_actual_formal (ap, comp->ts.interface->formal, 0, + if (!gfc_compare_actual_formal (ap, comp->ts.interface->formal, 0, comp->attr.elemental, false, where)) return; @@ -3880,7 +3880,7 @@ gfc_arglist_matches_symbol (gfc_actual_arglist** a dummy_args = gfc_sym_get_dummy_args (sym); r = !sym->attr.elemental; - if (compare_actual_formal (args, dummy_args, r, !r, false, NULL)) + if (gfc_compare_actual_formal (args, dummy_args, r, !r, false, NULL)) { check_intents (dummy_args, *args); if (warn_aliasing) @@ -5131,3 +5131,65 @@ finish: return dtio_sub; } + +/* Helper function - if we do not find an interface for a procedure, + construct it from the actual arglist. Luckily, this can only + happen for call by reference, so the information we actually need + to provide (and which would be impossible to guess from the call + itself) is not actually needed. */ + +void +gfc_get_formal_from_actual_arglist (gfc_symbol *sym, + gfc_actual_arglist *actual_args) +{ + gfc_actual_arglist *a; + gfc_formal_arglist **f; + gfc_symbol *s; + char name[GFC_MAX_SYMBOL_LEN + 1]; + static int var_num; + + f = &sym->formal; + for (a = actual_args; a != NULL; a = a->next) + { + (*f) = gfc_get_formal_arglist (); + if (a->expr) + { + snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++); + gfc_get_symbol (name, gfc_current_ns, &s); + if (a->expr->ts.type == BT_PROCEDURE) + { + s->attr.flavor = FL_PROCEDURE; + } + else + { + s->ts = a->expr->ts; + + if (s->ts.type == BT_CHARACTER) + s->ts.u.cl = gfc_get_charlen (); + + s->ts.deferred = 0; + s->ts.is_iso_c = 0; + s->ts.is_c_interop = 0; + s->attr.flavor = FL_VARIABLE; + s->attr.artificial = 1; + if (a->expr->rank > 0) + { + s->attr.dimension = 1; + s->as = gfc_get_array_spec (); + s->as->rank = 1; + s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, + &a->expr->where, 1); + s->as->upper[0] = NULL; + s->as->type = AS_ASSUMED_SIZE; + } + } + s->attr.dummy = 1; + s->attr.intent = INTENT_UNKNOWN; + (*f)->sym = s; + } + else /* If a->expr is NULL, this is an alternate rerturn. */ + (*f)->sym = NULL; + + f = &((*f)->next); + } +} Index: fortran/trans-types.c =================================================================== --- fortran/trans-types.c (Revision 274623) +++ fortran/trans-types.c (Arbeitskopie) @@ -2975,66 +2975,6 @@ create_fn_spec (gfc_symbol *sym, tree fntype) return build_type_attribute_variant (fntype, tmp); } -/* Helper function - if we do not find an interface for a procedure, - construct it from the actual arglist. Luckily, this can only - happen for call by reference, so the information we actually need - to provide (and which would be impossible to guess from the call - itself) is not actually needed. */ - -static void -get_formal_from_actual_arglist (gfc_symbol *sym, gfc_actual_arglist *actual_args) -{ - gfc_actual_arglist *a; - gfc_formal_arglist **f; - gfc_symbol *s; - char name[GFC_MAX_SYMBOL_LEN + 1]; - static int var_num; - - f = &sym->formal; - for (a = actual_args; a != NULL; a = a->next) - { - (*f) = gfc_get_formal_arglist (); - if (a->expr) - { - snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++); - gfc_get_symbol (name, gfc_current_ns, &s); - if (a->expr->ts.type == BT_PROCEDURE) - { - s->attr.flavor = FL_PROCEDURE; - } - else - { - s->ts = a->expr->ts; - - if (s->ts.type == BT_CHARACTER) - s->ts.u.cl = gfc_get_charlen (); - - s->ts.deferred = 0; - s->ts.is_iso_c = 0; - s->ts.is_c_interop = 0; - s->attr.flavor = FL_VARIABLE; - if (a->expr->rank > 0) - { - s->attr.dimension = 1; - s->as = gfc_get_array_spec (); - s->as->rank = 1; - s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, - &a->expr->where, 1); - s->as->upper[0] = NULL; - s->as->type = AS_ASSUMED_SIZE; - } - } - s->attr.dummy = 1; - s->attr.intent = INTENT_UNKNOWN; - (*f)->sym = s; - } - else /* If a->expr is NULL, this is an alternate rerturn. */ - (*f)->sym = NULL; - - f = &((*f)->next); - } -} - tree gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args) { @@ -3097,7 +3037,7 @@ gfc_get_function_type (gfc_symbol * sym, gfc_actua if (sym->backend_decl == error_mark_node && actual_args != NULL && sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL || sym->attr.proc == PROC_UNKNOWN)) - get_formal_from_actual_arglist (sym, actual_args); + gfc_get_formal_from_actual_arglist (sym, actual_args); /* Build the argument types for the function. */ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) Index: testsuite/gfortran.dg/bessel_3.f90 =================================================================== --- testsuite/gfortran.dg/bessel_3.f90 (Revision 274623) +++ testsuite/gfortran.dg/bessel_3.f90 (Arbeitskopie) @@ -9,10 +9,10 @@ print *, SIN (1.0) print *, BESSEL_J0(1.0) ! { dg-error "has no IMPLICIT type" }) print *, BESSEL_J1(1.0) ! { dg-error "has no IMPLICIT type" } print *, BESSEL_JN(1,1.0) ! { dg-error "has no IMPLICIT type" } -print *, BESSEL_JN(1,2,1.0) ! { dg-error "has no IMPLICIT type" } +print *, BESSEL_JN(1,2,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" } print *, BESSEL_Y0(1.0) ! { dg-error "has no IMPLICIT type" } print *, BESSEL_Y1(1.0) ! { dg-error "has no IMPLICIT type" } print *, BESSEL_YN(1,1.0) ! { dg-error "has no IMPLICIT type" } -print *, BESSEL_YN(1,2,1.0) ! { dg-error "has no IMPLICIT type" } +print *, BESSEL_YN(1,2,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" } end Index: testsuite/gfortran.dg/coarray_7.f90 =================================================================== --- testsuite/gfortran.dg/coarray_7.f90 (Revision 274623) +++ testsuite/gfortran.dg/coarray_7.f90 (Arbeitskopie) @@ -50,9 +50,9 @@ program test call coarray(caf2) call coarray(caf2[1]) ! { dg-error "must be a coarray" } call ups(i) - call ups(i[1]) ! { dg-error "with ultimate pointer component" } - call ups(i%ptr) - call ups(i[1]%ptr) ! OK - passes target not pointer + call ups1(i[1]) ! { dg-error "with ultimate pointer component" } + call ups2(i%ptr) + call ups3(i[1]%ptr) ! OK - passes target not pointer contains subroutine asyn(a) integer, intent(in), asynchronous :: a Index: testsuite/gfortran.dg/g77/20010519-1.f =================================================================== --- testsuite/gfortran.dg/g77/20010519-1.f (Revision 274623) +++ testsuite/gfortran.dg/g77/20010519-1.f (Arbeitskopie) @@ -1,4 +1,5 @@ c { dg-do compile } +c { dg-options "-std=legacy" } CHARMM Element source/dimb/nmdimb.src 1.1 C.##IF DIMB SUBROUTINE NMDIMB(X,Y,Z,NAT3,BNBND,BIMAG,LNOMA,AMASS,DDS,DDSCR, @@ -711,19 +712,19 @@ C Begin 1 'NFREG IS LARGER THAN PARDIM*3') C C ALLOCATE-SPACE-FOR-TRANSROT-VECTORS - ASSIGN 801 TO I800 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 801 TO I800 GOTO 800 801 CONTINUE C ALLOCATE-SPACE-FOR-DIAGONALIZATION - ASSIGN 721 TO I720 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 721 TO I720 GOTO 720 721 CONTINUE C ALLOCATE-SPACE-FOR-REDUCED-BASIS - ASSIGN 761 TO I760 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 761 TO I760 GOTO 760 761 CONTINUE C ALLOCATE-SPACE-FOR-OTHER-ARRAYS - ASSIGN 921 TO I920 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 921 TO I920 GOTO 920 921 CONTINUE C @@ -731,12 +732,12 @@ C Space allocation for working arrays of EISPACK C diagonalization subroutines IF(LSCI) THEN C ALLOCATE-SPACE-FOR-LSCI - ASSIGN 841 TO I840 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 841 TO I840 GOTO 840 841 CONTINUE ELSE C ALLOCATE-DUMMY-SPACE-FOR-LSCI - ASSIGN 881 TO I880 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 881 TO I880 GOTO 880 881 CONTINUE ENDIF @@ -846,7 +847,7 @@ C Orthonormalize the eigenvectors C OLDPRN=PRNLEV PRNLEV=1 - CALL ORTHNM(1,NFRET,NFRET,DDV,NAT3,LPURG,TOLER) + CALL ORTHNM(1,NFRET,NFRET,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" } PRNLEV=OLDPRN C C Do reduced basis diagonalization using the DDV vectors @@ -878,11 +879,11 @@ C C C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS C - ASSIGN 621 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 621 TO I620 GOTO 620 621 CONTINUE C SAVE-MODES - ASSIGN 701 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 701 TO I700 GOTO 700 701 CONTINUE IF(ITER.EQ.ITMX) THEN @@ -1025,17 +1026,17 @@ C CALL PARTDS(NAT3,NPARC,ATMPAR,NPARS,ATMPAS,INIDS,NPARMX, 1 DDF,NFREG,CUTF1,PARDIM,NFCUT1) C DO-THE-DIAGONALISATIONS - ASSIGN 641 to I640 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 641 to I640 GOTO 640 641 CONTINUE QDIAG=.FALSE. C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS - ASSIGN 622 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 622 TO I620 GOTO 620 622 CONTINUE QDIAG=.TRUE. C SAVE-MODES - ASSIGN 702 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 702 TO I700 GOTO 700 702 CONTINUE C @@ -1048,7 +1049,7 @@ C ITER=ITER+1 IF(PRNLEV.GE.2) WRITE(OUTU,553) ITER C DO-THE-DWIN-DIAGONALISATIONS - ASSIGN 661 TO I660 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 661 TO I660 GOTO 660 661 CONTINUE ENDIF @@ -1056,13 +1057,13 @@ C DO-THE-DWIN-DIAGONALISATIONS IRESF=0 QDIAG=.FALSE. C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS - ASSIGN 623 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 623 TO I620 GOTO 620 623 CONTINUE QDIAG=.TRUE. IF((CVGMX.LE.TOLDIM).OR.(ITER.EQ.ITMX)) GOTO 600 C SAVE-MODES - ASSIGN 703 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 703 TO I700 GOTO 700 703 CONTINUE ENDIF @@ -1072,7 +1073,7 @@ C SAVE-MODES 600 CONTINUE C C SAVE-MODES - ASSIGN 704 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + ASSIGN 704 TO I700 GOTO 700 704 CONTINUE CALL CLEANHP(NAT3,NFREG,NPARD,NSUBP,PARDIM,DDV2,DDSS,DDVBAS, @@ -1125,7 +1126,7 @@ C NFCUT=NFRET OLDPRN=PRNLEV PRNLEV=1 - CALL ORTHNM(1,NFRET,NFCUT,DDV,NAT3,LPURG,TOLER) + CALL ORTHNM(1,NFRET,NFCUT,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" } PRNLEV=OLDPRN NFRET=NFCUT IF(PRNLEV.GE.2) WRITE(OUTU,568) NFRET @@ -1150,7 +1151,7 @@ C 6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD) CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1) ENDIF - GOTO I620 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + GOTO I620 C C----------------------------------------------------------------------- C TO DO-THE-DIAGONALISATIONS @@ -1173,7 +1174,7 @@ C TO DO-THE-DIAGONALISATIONS NFSAV=NFCUT1 OLDPRN=PRNLEV PRNLEV=1 - CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) + CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" } PRNLEV=OLDPRN CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1) NFRET=NDIM+NFCUT @@ -1190,7 +1191,7 @@ C TO DO-THE-DIAGONALISATIONS NFCUT1=NFCUT NFRET=NFCUT ENDDO - GOTO I640 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + GOTO I640 C C----------------------------------------------------------------------- C TO DO-THE-DWIN-DIAGONALISATIONS @@ -1223,7 +1224,7 @@ C CALL ADZERD(DDV,1,NFCUT1,NAT3,IS1,IS2,IS3,IS4) OLDPRN=PRNLEV PRNLEV=1 - CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) + CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" } PRNLEV=OLDPRN CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1) C @@ -1241,7 +1242,7 @@ C IF(NFCUT.GT.NFRRES) NFCUT=NFRRES NFCUT1=NFCUT NFRET=NFCUT - GOTO I660 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + GOTO I660 C C----------------------------------------------------------------------- C TO SAVE-MODES @@ -1258,7 +1259,7 @@ C TO SAVE-MODES CALL WRTNMD(LCARD,ISTRT,ISTOP,NAT3,DDV,DDSCR,DDEV,IUNMOD, 1 AMASS) CALL SAVEIT(IUNMOD) - GOTO I700 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + GOTO I700 C C----------------------------------------------------------------------- C TO ALLOCATE-SPACE-FOR-DIAGONALIZATION @@ -1269,7 +1270,7 @@ C TO ALLOCATE-SPACE-FOR-DIAGONALIZATION JSPACE=JSPACE+JSP DDSS=ALLHP(JSPACE) DD5=DDSS+JSPACE-JSP - GOTO I720 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + GOTO I720 C C----------------------------------------------------------------------- C TO ALLOCATE-SPACE-FOR-REDUCED-BASIS @@ -1279,13 +1280,13 @@ C TO ALLOCATE-SPACE-FOR-REDUCED-BASIS ELSE DDVBAS=ALLHP(IREAL8(NFREG*NAT3)) ENDIF - GOTO I760 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + GOTO I760 C C----------------------------------------------------------------------- C TO ALLOCATE-SPACE-FOR-TRANSROT-VECTORS 800 CONTINUE TRAROT=ALLHP(IREAL8(6*NAT3)) - GOTO I800 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + GOTO I800 C C----------------------------------------------------------------------- C TO ALLOCATE-SPACE-FOR-LSCI @@ -1300,7 +1301,7 @@ C TO ALLOCATE-SPACE-FOR-LSCI E2RATQ=ALLHP(IREAL8(PARDIM+3)) BDRATQ=ALLHP(IREAL8(PARDIM+3)) INRATQ=ALLHP(INTEG4(PARDIM+3)) - GOTO I840 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + GOTO I840 C C----------------------------------------------------------------------- C TO ALLOCATE-DUMMY-SPACE-FOR-LSCI @@ -1315,13 +1316,13 @@ C TO ALLOCATE-DUMMY-SPACE-FOR-LSCI E2RATQ=ALLHP(IREAL8(2)) BDRATQ=ALLHP(IREAL8(2)) INRATQ=ALLHP(INTEG4(2)) - GOTO I880 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + GOTO I880 C C----------------------------------------------------------------------- C TO ALLOCATE-SPACE-FOR-OTHER-ARRAYS 920 CONTINUE IUPD=ALLHP(INTEG4(PARDIM+3)) - GOTO I920 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + GOTO I920 C.##ELSE C.##ENDIF END Index: testsuite/gfortran.dg/goacc/acc_on_device-1.f95 =================================================================== --- testsuite/gfortran.dg/goacc/acc_on_device-1.f95 (Revision 274623) +++ testsuite/gfortran.dg/goacc/acc_on_device-1.f95 (Arbeitskopie) @@ -1,5 +1,5 @@ ! Have to enable optimizations, as otherwise builtins won't be expanded. -! { dg-additional-options "-O -fdump-rtl-expand" } +! { dg-additional-options "-O -fdump-rtl-expand -std=legacy" } logical function f () implicit none @@ -9,7 +9,7 @@ logical function f () f = .false. f = f .or. acc_on_device () - f = f .or. acc_on_device (1, 2) + f = f .or. acc_on_device (1, 2) ! { dg-warning ".*" } f = f .or. acc_on_device (3.14) f = f .or. acc_on_device ("hello") Index: testsuite/gfortran.dg/internal_pack_9.f90 =================================================================== --- testsuite/gfortran.dg/internal_pack_9.f90 (Revision 274623) +++ testsuite/gfortran.dg/internal_pack_9.f90 (Arbeitskopie) @@ -10,9 +10,9 @@ ! Case 1: Substring encompassing the whole string subroutine foo2 implicit none - external foo + external foo_char character(len=20) :: str(2) = '1234567890' - call foo(str(:)(1:20)) ! This is still not fixed. + call foo_char (str(:)(1:20)) ! This is still not fixed. end ! Case 2: Contiguous array section Index: testsuite/gfortran.dg/pr24823.f =================================================================== --- testsuite/gfortran.dg/pr24823.f (Revision 274623) +++ testsuite/gfortran.dg/pr24823.f (Arbeitskopie) @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-O2" } +! { dg-options "-O2 -std=legacy" } ! PR24823 Flow didn't handle a PARALLEL as destination of a SET properly. SUBROUTINE ZLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, $ RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, @@ -52,7 +52,7 @@ A( J-I+1, I ) = DCONJG( ZLATM2( M, N, I, J, KL, $ DR, IPVTNG, IWORK, SPARSE ) ) ELSE - A( J-I+1, I ) = ZLATM2( M, N, I, J, KL, KU, + A( J-I+1, I ) = ZLATM2( M, N, I, J, KL, KU, ! { dg-warning "Type mismatch" } $ IPVTNG, IWORK, SPARSE ) END IF END IF @@ -61,7 +61,7 @@ IF( ISYM.EQ.0 ) THEN END IF END IF - A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU, + A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU, ! { dg-warning "Type mismatch" } $ DR, IPVTNG, IWORK, SPARSE ) END IF END IF Index: testsuite/gfortran.dg/pr39937.f =================================================================== --- testsuite/gfortran.dg/pr39937.f (nicht existent) +++ testsuite/gfortran.dg/pr39937.f (Arbeitskopie) @@ -0,0 +1,30 @@ +C { dg-do compile } +C { dg-options "-std=legacy" } + SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, INFO ) + DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) + DOUBLE PRECISION X( 2, 2 ) + CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ ZERO, X, 2, SCALE, XNORM, IERR ) + CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + DO 90 J = KI - 2, 1, -1 + IF( J.GT.JNXT ) + $ GO TO 90 + JNXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + IF( WORK( J ).GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + END IF + END IF + CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, + $ T( J-1, J-1 ), LDT, ONE, ONE, + $ XNORM, IERR ) ! { dg-warning "Type mismatch" } + CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, + $ WORK( 1+N2 ), 1 ) + END IF + 90 CONTINUE + END Index: testsuite/gfortran.fortran-torture/compile/pr39937.f =================================================================== --- testsuite/gfortran.fortran-torture/compile/pr39937.f (Revision 274623) +++ testsuite/gfortran.fortran-torture/compile/pr39937.f (nicht existent) @@ -1,28 +0,0 @@ - SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, - $ LDVR, MM, M, WORK, INFO ) - DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), - $ WORK( * ) - DOUBLE PRECISION X( 2, 2 ) - CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), - $ ZERO, X, 2, SCALE, XNORM, IERR ) - CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) - DO 90 J = KI - 2, 1, -1 - IF( J.GT.JNXT ) - $ GO TO 90 - JNXT = J - 1 - IF( J.GT.1 ) THEN - IF( T( J, J-1 ).NE.ZERO ) THEN - IF( WORK( J ).GT.BIGNUM / XNORM ) THEN - X( 1, 1 ) = X( 1, 1 ) / XNORM - END IF - END IF - CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, - $ T( J-1, J-1 ), LDT, ONE, ONE, - $ XNORM, IERR ) - CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, - $ WORK( 1+N ), 1 ) - CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, - $ WORK( 1+N2 ), 1 ) - END IF - 90 CONTINUE - END