===================================================================
@@ -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. */
===================================================================
@@ -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 */
===================================================================
@@ -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);
+ }
+}
===================================================================
@@ -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)
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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")
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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
===================================================================
@@ -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