Skip to content

R
riscv-gcc-1
Commit e68a35ae by Thomas Koenig
Options

re PR fortran/91390 (treatment of extra parameter in a subroutine call) 

2019-08-24  Thomas Koenig  <tkoenig@gcc.gnu.org>

	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  <tkoenig@gcc.gnu.org>

	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
parent c6ca0e3e
Showing with 212 additions and 135 deletions
gcc/fortran/ChangeLog
2019-08-24 Thomas Koenig <tkoenig@gcc.gnu.org>
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 <mark.eggleston@codethink.com>
* intrinsics.text: References in 'See also:' are now on
......
gcc/fortran/frontend-passes.c
......@@ -5369,20 +5369,14 @@ 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;
if (e->expr_type != EXPR_FUNCTION)
return 0;
sym = e->value.function.esym;
gfc_symbol *def_sym = NULL;
if (sym == NULL || sym->attr.is_bind_c)
return 0;
......@@ -5390,51 +5384,89 @@ check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
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;
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)
return 0;
/* Callback for external functions. */
gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
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 (sym && def_sym)
gfc_procedure_use (def_sym, &co->ext.actual, &co->loc);
if (e->expr_type != EXPR_FUNCTION)
return 0;
sym = e->value.function.esym;
if (sym == NULL)
return 0;
loc = &e->where;
actual = e->value.function.actual;
return check_externals_procedure (sym, loc, actual);
}
/* Called routine. */
......
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 */
......
gcc/fortran/interface.c
......@@ -2878,8 +2878,8 @@ 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,
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)
{
......@@ -3805,7 +3805,7 @@ 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,
if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental,
sym->attr.proc == PROC_ST_FUNCTION, where))
return false;
......@@ -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);
}
}
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)
......
gcc/testsuite/ChangeLog
2019-08-24 Thomas Koenig <tkoenig@gcc.gnu.org>
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 <paolo.carlini@oracle.com>
* g++.dg/conversion/simd4.C: Test all the locations.
......
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
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
......
gcc/testsuite/gfortran.dg/g77/20010519-1.f
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
gcc/testsuite/gfortran.dg/goacc/acc_on_device-1.f95
! 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")
......
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
......
gcc/testsuite/gfortran.dg/pr24823.f
! { 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
......
gcc/testsuite/gfortran.fortran-torture/compile/pr39937.f → gcc/testsuite/gfortran.dg/pr39937.f
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, * ),
......@@ -18,7 +20,7 @@
END IF
CALL DLALN2( .FALSE., 2, 2, SMIN, ONE,
$ T( J-1, J-1 ), LDT, ONE, ONE,
$ XNORM, IERR )
$ 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,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment