From: Thomas Koenig Date: Sat, 24 Aug 2019 21:12:45 +0000 (+0000) Subject: re PR fortran/91390 (treatment of extra parameter in a subroutine call) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=e68a35ae4a65d2b3f42b22e6920a7a29f5727b3f;p=gcc.git re PR fortran/91390 (treatment of extra parameter in a subroutine call) 2019-08-24 Thomas Koenig PR fortran/91390 PR fortran/91519 * 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_formal): 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-24 Thomas Koenig PR fortran/91390 PR fortran/91519 * 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 catch-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. From-SVN: r274902 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4bd9291329f..abdf9e6b24f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2019-08-24 Thomas Koenig + + PR fortran/91390 + PR fortran/91519 + * 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_formal): 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-23 Mark Eggleston * intrinsics.text: References in 'See also:' are now on @@ -14,7 +32,7 @@ 2019-08-23 Mark Eggleston - * intrinsics.text: Removed empty sections. The order of + * intrinsics.text: Removed empty sections. The order of sections for each intrinsic is now consistent throughout. Stray words removed. Text in the wrong section moved. Missing standard statement inserted. diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index dd820899b02..fa416671fc6 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -5369,72 +5369,104 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, 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); 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, 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) - return 0; +} - gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); - if (gsym == NULL) +/* 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; - gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); + sym = e->value.function.esym; + if (sym == NULL) + return 0; - if (sym && def_sym) - gfc_procedure_use (def_sym, &co->ext.actual, &co->loc); + loc = &e->where; + actual = e->value.function.actual; - return 0; + return check_externals_procedure (sym, loc, actual); } /* Called routine. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 6a491ab959c..7f54897361f 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3421,6 +3421,9 @@ bool gfc_check_typebound_override (gfc_symtree*, gfc_symtree*); 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 */ diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index d6f6cce4fbf..43d7cd5a296 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2878,10 +2878,10 @@ lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments) 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_arglist **ap, locus *where) /* 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_arglist **ap, locus *where) 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** args, gfc_symbol* sym) 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); + } +} diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index e1033b3b223..82666c48bec 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -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_actual_arglist *actual_args) 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) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index af6fe82bfbf..efb0157bff1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,22 @@ +2019-08-24 Thomas Koenig + + PR fortran/91390 + PR fortran/91519 + * 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 catch-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. + 2019-08-24 Paolo Carlini * g++.dg/conversion/simd4.C: Test all the locations. diff --git a/gcc/testsuite/gfortran.dg/bessel_3.f90 b/gcc/testsuite/gfortran.dg/bessel_3.f90 index 271768dd890..05610ae0c38 100644 --- a/gcc/testsuite/gfortran.dg/bessel_3.f90 +++ b/gcc/testsuite/gfortran.dg/bessel_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray_7.f90 b/gcc/testsuite/gfortran.dg/coarray_7.f90 index abbd64dd544..49482efdb6a 100644 --- a/gcc/testsuite/gfortran.dg/coarray_7.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_7.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/g77/20010519-1.f b/gcc/testsuite/gfortran.dg/g77/20010519-1.f index c268bf03eb5..4cefb958600 100644 --- a/gcc/testsuite/gfortran.dg/g77/20010519-1.f +++ b/gcc/testsuite/gfortran.dg/g77/20010519-1.f @@ -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 diff --git a/gcc/testsuite/gfortran.dg/goacc/acc_on_device-1.f95 b/gcc/testsuite/gfortran.dg/goacc/acc_on_device-1.f95 index 79dc7316599..e204b539e6f 100644 --- a/gcc/testsuite/gfortran.dg/goacc/acc_on_device-1.f95 +++ b/gcc/testsuite/gfortran.dg/goacc/acc_on_device-1.f95 @@ -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") diff --git a/gcc/testsuite/gfortran.dg/internal_pack_9.f90 b/gcc/testsuite/gfortran.dg/internal_pack_9.f90 index 2b44db5a805..568b42cde67 100644 --- a/gcc/testsuite/gfortran.dg/internal_pack_9.f90 +++ b/gcc/testsuite/gfortran.dg/internal_pack_9.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr24823.f b/gcc/testsuite/gfortran.dg/pr24823.f index 1b6f448d9d9..bb63c411b41 100644 --- a/gcc/testsuite/gfortran.dg/pr24823.f +++ b/gcc/testsuite/gfortran.dg/pr24823.f @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr39937.f b/gcc/testsuite/gfortran.dg/pr39937.f new file mode 100644 index 00000000000..1ab22ee4397 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr39937.f @@ -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 diff --git a/gcc/testsuite/gfortran.fortran-torture/compile/pr39937.f b/gcc/testsuite/gfortran.fortran-torture/compile/pr39937.f deleted file mode 100644 index 5ead135d807..00000000000 --- a/gcc/testsuite/gfortran.fortran-torture/compile/pr39937.f +++ /dev/null @@ -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