This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [patch, fortran] PR31346 - improve whole-file checking (2nd update)
On Monday 24 May 2010 20:38:06 Daniel Franke wrote:
> On Monday 24 May 2010 17:40:00 Daniel Franke wrote:
> > if no explicit interface is given, a called procedure must not have dummy
> > arguments with assumed-shape. Attached patch adds a whole-file check for
> > that.
>
> While at it, verify that return type, kind and string lengths match.
Second update: optional arguments require an explicit interface as well.
gcc/fortran/:
2010-05-24 Daniel Franke <franke.daniel@gmail.com>
PR fortran/30668
PR fortran/31346
* 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-24 Daniel Franke <franke.daniel@gmail.com>
PR fortran/30668
PR fortran/31346
* 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.
Once more regression tested on i686-pc-linux-gnu.
Ok for trunk?
Daniel
Index: fortran/resolve.c
===================================================================
--- fortran/resolve.c (revision 159646)
+++ fortran/resolve.c (working copy)
@@ -1864,7 +1864,7 @@ resolve_global_procedure (gfc_symbol *sy
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 *sy
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);
Index: testsuite/gfortran.dg/pr40999.f
===================================================================
--- testsuite/gfortran.dg/pr40999.f (revision 159646)
+++ testsuite/gfortran.dg/pr40999.f (working copy)
@@ -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 )
Index: testsuite/gfortran.dg/whole_file_5.f90
===================================================================
--- testsuite/gfortran.dg/whole_file_5.f90 (revision 159646)
+++ testsuite/gfortran.dg/whole_file_5.f90 (working copy)
@@ -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" } }
Index: testsuite/gfortran.dg/whole_file_6.f90
===================================================================
--- testsuite/gfortran.dg/whole_file_6.f90 (revision 159646)
+++ testsuite/gfortran.dg/whole_file_6.f90 (working copy)
@@ -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" } }
! { 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
! { 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
! { 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