OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/30668 (-fwhole-file should catch function of wrong type) 

gcc/fortran/:
2010-05-25  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/30668
	PR fortran/31346
	PR fortran/34260
	* resolve.c (resolve_global_procedure): Add check for global
	procedures with implicit interfaces and assumed-shape or optional
	dummy arguments. Verify that function return type, kind and string
	lengths match.

gcc/testsuite/:
2010-05-25  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/30668
	PR fortran/31346
	PR fortran/34260
	* gfortran.dg/pr40999.f: Fix function type.
	* gfortran.dg/whole_file_5.f90: Likewise.
	* gfortran.dg/whole_file_6.f90: Likewise.
	* gfortran.dg/whole_file_16.f90: New.
	* gfortran.dg/whole_file_17.f90: New.
	* gfortran.dg/whole_file_18.f90: New.

From-SVN: r159838
This commit is contained in:
Daniel Franke 2010-05-25 14:10:01 -04:00 committed by Daniel Franke
parent f80e2b00c9
commit 30145da598
9 changed files with 133 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
gcc/fortran/ChangeLog
View File

@ -1,3 +1,13 @@
2010-05-25 Daniel Franke <franke.daniel@gmail.com>
PR fortran/30668
PR fortran/31346
PR fortran/34260
* resolve.c (resolve_global_procedure): Add check for global
procedures with implicit interfaces and assumed-shape or optional
dummy arguments. Verify that function return type, kind and string
lengths match.
2010-05-21 Tobias Burnus <burnus@net-b.de>
* gfortran.h: Do not include system.h.

63
gcc/fortran/resolve.c
View File

@ -1864,7 +1864,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
gfc_error ("The reference to function '%s' at %L either needs an "
"explicit INTERFACE or the rank is incorrect", sym->name,
where);
/* Non-assumed length character functions. */
if (sym->attr.function && sym->ts.type == BT_CHARACTER
&& gsym->ns->proc_name->ts.u.cl->length != NULL)
@ -1872,18 +1872,69 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
gfc_charlen *cl = sym->ts.u.cl;
if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
&& cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
&& cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
{
gfc_error ("Nonconstant character-length function '%s' at %L "
gfc_error ("Nonconstant character-length function '%s' at %L "
"must have an explicit interface", sym->name,
&sym->declared_at);
}
}
/* Differences in constant character lengths. */
if (sym->attr.function && sym->ts.type == BT_CHARACTER)
{
long int l1 = 0, l2 = 0;
gfc_charlen *cl1 = sym->ts.u.cl;
gfc_charlen *cl2 = gsym->ns->proc_name->ts.u.cl;
if (cl1 != NULL
&& cl1->length != NULL
&& cl1->length->expr_type == EXPR_CONSTANT)
l1 = mpz_get_si (cl1->length->value.integer);
if (cl2 != NULL
&& cl2->length != NULL
&& cl2->length->expr_type == EXPR_CONSTANT)
l2 = mpz_get_si (cl2->length->value.integer);
if (l1 && l2 && l1 != l2)
gfc_error ("Character length mismatch in return type of "
"function '%s' at %L (%ld/%ld)", sym->name,
&sym->declared_at, l1, l2);
}
/* Type mismatch of function return type and expected type. */
if (sym->attr.function
&& !gfc_compare_types (&sym->ts, &gsym->ns->proc_name->ts))
gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
sym->name, &sym->declared_at, gfc_typename (&sym->ts),
gfc_typename (&gsym->ns->proc_name->ts));
/* Assumed shape arrays as dummy arguments. */
if (gsym->ns->proc_name->formal)
{
gfc_formal_arglist *arg = gsym->ns->proc_name->formal;
for ( ; arg; arg = arg->next)
if (arg->sym && arg->sym->as
&& arg->sym->as->type == AS_ASSUMED_SHAPE)
{
gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
"'%s' argument must have an explicit interface",
sym->name, &sym->declared_at, arg->sym->name);
break;
}
else if (arg->sym && arg->sym->attr.optional)
{
gfc_error ("Procedure '%s' at %L with optional dummy argument "
"'%s' must have an explicit interface",
sym->name, &sym->declared_at, arg->sym->name);
break;
}
}
if (gfc_option.flag_whole_file == 1
|| ((gfc_option.warn_std & GFC_STD_LEGACY)
&&
!(gfc_option.warn_std & GFC_STD_GNU)))
|| ((gfc_option.warn_std & GFC_STD_LEGACY)
&& !(gfc_option.warn_std & GFC_STD_GNU)))
gfc_errors_to_warnings (1);
gfc_procedure_use (gsym->ns->proc_name, actual, where);

12
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,15 @@
2010-05-25 Daniel Franke <franke.daniel@gmail.com>
PR fortran/30668
PR fortran/31346
PR fortran/34260
* gfortran.dg/pr40999.f: Fix function type.
* gfortran.dg/whole_file_5.f90: Likewise.
* gfortran.dg/whole_file_6.f90: Likewise.
* gfortran.dg/whole_file_16.f90: New.
* gfortran.dg/whole_file_17.f90: New.
* gfortran.dg/whole_file_18.f90: New.
2010-05-25 Jack Howarth <howarth@bromo.med.uc.edu>
Iain Sandoe <iains@gcc.gnu.org>

1
gcc/testsuite/gfortran.dg/pr40999.f
View File

@ -2,6 +2,7 @@
! { dg-options "-O3 -fwhole-file" }
SUBROUTINE ZLARFG( ALPHA )
COMPLEX*16 ZLADIV
ALPHA = ZLADIV( DCMPLX( 1.0D+0 ) )
END
COMPLEX*16 FUNCTION ZLADIV( X )

13
gcc/testsuite/gfortran.dg/whole_file_16.f90 Normal file
View File

@ -0,0 +1,13 @@
! { dg-do "compile" }
! { dg-options "-fwhole-file" }
!
! PR fortran/31346
!
program main
real, dimension(2) :: a
call foo(a) ! { dg-error "must have an explicit interface" }
end program main
subroutine foo(a)
real, dimension(:) :: a
end subroutine foo

22
gcc/testsuite/gfortran.dg/whole_file_17.f90 Normal file
View File

@ -0,0 +1,22 @@
! { dg-do "compile" }
! { dg-options "-fwhole-file" }
!
! PR fortran/30668
!
integer(8) function two()
two = 2
end function two
CHARACTER(len=8) function string()
string = "gfortran"
end function string
program xx
INTEGER :: a
CHARACTER(len=4) :: s, string ! { dg-error "Character length mismatch" }
a = two() ! { dg-error "Return type mismatch" }
s = string()
end program xx

14
gcc/testsuite/gfortran.dg/whole_file_18.f90 Normal file
View File

@ -0,0 +1,14 @@
! { dg-do "compile" }
! { dg-options "-fwhole-file -Wno-unused-dummy-argument" }
!
! PR fortran/34260
!
PROGRAM MAIN
REAL A
CALL SUB(A) ! { dg-error "must have an explicit interface" }
END PROGRAM
SUBROUTINE SUB(A,I)
REAL :: A
INTEGER, OPTIONAL :: I
END SUBROUTINE

4
gcc/testsuite/gfortran.dg/whole_file_5.f90
View File

@ -11,9 +11,9 @@ INTEGER FUNCTION f()
END FUNCTION
PROGRAM main
INTEGER :: a
INTEGER :: a, f
a = f()
print *, a
print *, a, f()
END PROGRAM
! { dg-final { scan-tree-dump-times "= f \\(\\)" 0 "optimized" } }

4
gcc/testsuite/gfortran.dg/whole_file_6.f90
View File

@ -7,13 +7,13 @@
!
PROGRAM main
INTEGER :: a(3)
INTEGER :: a(3), f
a = f()
print *, a
END PROGRAM
INTEGER FUNCTION f()
f = 42.0
f = 42
END FUNCTION
! { dg-final { scan-tree-dump-times "= f \\(\\)" 0 "optimized" } }