+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
2019-08-23 Mark Eggleston <mark.eggleston@codethink.com>
- * 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.
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. */
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 */
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;
/* 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))
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;
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)
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);
+ }
+}
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)
{
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)
+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.
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
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
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,
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
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
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
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
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
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
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
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,
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
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
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
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
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
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
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
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
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
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
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
! 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
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")
! 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
! { 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,
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
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
--- /dev/null
+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
+++ /dev/null
- 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
projects / gcc.git / commitdiff