Commit edc802c7 by Janus Weil

re PR fortran/35831 ([F95] Shape mismatch check missing for dummy procedure argument)

2012-08-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/35831
	* interface.c (check_result_characteristics): New function, which checks
	the characteristics of function results.
	(gfc_compare_interfaces,gfc_check_typebound_override): Call it.

2012-08-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/35831
	* gfortran.dg/dummy_procedure_5.f90: Modified.
	* gfortran.dg/dummy_procedure_8.f90: New.
	* gfortran.dg/interface_26.f90: Modified.
	* gfortran.dg/proc_ptr_11.f90: Modified.
	* gfortran.dg/proc_ptr_15.f90: Modified.
	* gfortran.dg/proc_ptr_result_5.f90: Modified.
	* gfortran.dg/typebound_override_1.f90: Modified.
	* gfortran.dg/typebound_proc_6.f03: Modified.

From-SVN: r190187
parent ef859c9d
2012-08-06 Janus Weil <janus@gcc.gnu.org>
PR fortran/35831
* interface.c (check_result_characteristics): New function, which checks
the characteristics of function results.
(gfc_compare_interfaces,gfc_check_typebound_override): Call it.
2012-08-02 Thomas König <tkoenig@gcc.gnu.org> 2012-08-02 Thomas König <tkoenig@gcc.gnu.org>
PR fortran/54033 PR fortran/54033
......
...@@ -1006,9 +1006,8 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, ...@@ -1006,9 +1006,8 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
/* Check type and rank. */ /* Check type and rank. */
if (type_must_agree && !compare_type_rank (s2, s1)) if (type_must_agree && !compare_type_rank (s2, s1))
{ {
if (errmsg != NULL) snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'", s1->name);
s1->name);
return FAILURE; return FAILURE;
} }
...@@ -1141,6 +1140,152 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, ...@@ -1141,6 +1140,152 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
} }
/* Check if the characteristics of two function results match,
cf. F08:12.3.3. */
static gfc_try
check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
char *errmsg, int err_len)
{
gfc_symbol *r1, *r2;
r1 = s1->result ? s1->result : s1;
r2 = s2->result ? s2->result : s2;
if (r1->ts.type == BT_UNKNOWN)
return SUCCESS;
/* Check type and rank. */
if (!compare_type_rank (r1, r2))
{
snprintf (errmsg, err_len, "Type/rank mismatch in function result");
return FAILURE;
}
/* Check ALLOCATABLE attribute. */
if (r1->attr.allocatable != r2->attr.allocatable)
{
snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in "
"function result");
return FAILURE;
}
/* Check POINTER attribute. */
if (r1->attr.pointer != r2->attr.pointer)
{
snprintf (errmsg, err_len, "POINTER attribute mismatch in "
"function result");
return FAILURE;
}
/* Check CONTIGUOUS attribute. */
if (r1->attr.contiguous != r2->attr.contiguous)
{
snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in "
"function result");
return FAILURE;
}
/* Check PROCEDURE POINTER attribute. */
if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer)
{
snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in "
"function result");
return FAILURE;
}
/* Check string length. */
if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl)
{
if (r1->ts.deferred != r2->ts.deferred)
{
snprintf (errmsg, err_len, "Character length mismatch "
"in function result");
return FAILURE;
}
if (r1->ts.u.cl->length)
{
int compval = gfc_dep_compare_expr (r1->ts.u.cl->length,
r2->ts.u.cl->length);
switch (compval)
{
case -1:
case 1:
case -3:
snprintf (errmsg, err_len, "Character length mismatch "
"in function result");
return FAILURE;
case -2:
/* FIXME: Implement a warning for this case.
snprintf (errmsg, err_len, "Possible character length mismatch "
"in function result");*/
break;
case 0:
break;
default:
gfc_internal_error ("check_result_characteristics (1): Unexpected "
"result %i of gfc_dep_compare_expr", compval);
break;
}
}
}
/* Check array shape. */
if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as)
{
int i, compval;
gfc_expr *shape1, *shape2;
if (r1->as->type != r2->as->type)
{
snprintf (errmsg, err_len, "Shape mismatch in function result");
return FAILURE;
}
if (r1->as->type == AS_EXPLICIT)
for (i = 0; i < r1->as->rank + r1->as->corank; i++)
{
shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]),
gfc_copy_expr (r1->as->lower[i]));
shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]),
gfc_copy_expr (r2->as->lower[i]));
compval = gfc_dep_compare_expr (shape1, shape2);
gfc_free_expr (shape1);
gfc_free_expr (shape2);
switch (compval)
{
case -1:
case 1:
case -3:
snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
"function result", i + 1);
return FAILURE;
case -2:
/* FIXME: Implement a warning for this case.
gfc_warning ("Possible shape mismatch in return value");*/
break;
case 0:
break;
default:
gfc_internal_error ("check_result_characteristics (2): "
"Unexpected result %i of "
"gfc_dep_compare_expr", compval);
break;
}
}
}
return SUCCESS;
}
/* 'Compare' two formal interfaces associated with a pair of symbols. /* 'Compare' two formal interfaces associated with a pair of symbols.
We return nonzero if there exists an actual argument list that We return nonzero if there exists an actual argument list that
would be ambiguous between the two interfaces, zero otherwise. would be ambiguous between the two interfaces, zero otherwise.
...@@ -1180,18 +1325,10 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, ...@@ -1180,18 +1325,10 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
{ {
if (s1->attr.function && s2->attr.function) if (s1->attr.function && s2->attr.function)
{ {
/* If both are functions, check result type. */ /* If both are functions, check result characteristics. */
if (s1->ts.type == BT_UNKNOWN) if (check_result_characteristics (s1, s2, errmsg, err_len)
return 1; == FAILURE)
if (!compare_type_rank (s1,s2)) return 0;
{
if (errmsg != NULL)
snprintf (errmsg, err_len, "Type/rank mismatch in return value "
"of '%s'", name2);
return 0;
}
/* FIXME: Check array bounds and string length of result. */
} }
if (s1->attr.pure && !s2->attr.pure) if (s1->attr.pure && !s2->attr.pure)
...@@ -3793,7 +3930,7 @@ gfc_try ...@@ -3793,7 +3930,7 @@ gfc_try
gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
{ {
locus where; locus where;
const gfc_symbol *proc_target, *old_target; gfc_symbol *proc_target, *old_target;
unsigned proc_pass_arg, old_pass_arg, argpos; unsigned proc_pass_arg, old_pass_arg, argpos;
gfc_formal_arglist *proc_formal, *old_formal; gfc_formal_arglist *proc_formal, *old_formal;
bool check_type; bool check_type;
...@@ -3872,45 +4009,13 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) ...@@ -3872,45 +4009,13 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
" FUNCTION", proc->name, &where); " FUNCTION", proc->name, &where);
return FAILURE; return FAILURE;
} }
/* FIXME: Do more comprehensive checking (including, for instance, the
array-shape). */
gcc_assert (proc_target->result && old_target->result);
if (!compare_type_rank (proc_target->result, old_target->result))
{
gfc_error ("'%s' at %L and the overridden FUNCTION should have"
" matching result types and ranks", proc->name, &where);
return FAILURE;
}
/* Check string length. */ if (check_result_characteristics (proc_target, old_target,
if (proc_target->result->ts.type == BT_CHARACTER err, sizeof(err)) == FAILURE)
&& proc_target->result->ts.u.cl && old_target->result->ts.u.cl)
{ {
int compval = gfc_dep_compare_expr (proc_target->result->ts.u.cl->length, gfc_error ("Result mismatch for the overriding procedure "
old_target->result->ts.u.cl->length); "'%s' at %L: %s", proc->name, &where, err);
switch (compval) return FAILURE;
{
case -1:
case 1:
case -3:
gfc_error ("Character length mismatch between '%s' at '%L' and "
"overridden FUNCTION", proc->name, &where);
return FAILURE;
case -2:
gfc_warning ("Possible character length mismatch between '%s' at"
" '%L' and overridden FUNCTION", proc->name, &where);
break;
case 0:
break;
default:
gfc_internal_error ("gfc_check_typebound_override: Unexpected "
"result %i of gfc_dep_compare_expr", compval);
break;
}
} }
} }
......
2012-08-06 Janus Weil <janus@gcc.gnu.org>
PR fortran/35831
* gfortran.dg/dummy_procedure_5.f90: Modified.
* gfortran.dg/dummy_procedure_8.f90: New.
* gfortran.dg/interface_26.f90: Modified.
* gfortran.dg/proc_ptr_11.f90: Modified.
* gfortran.dg/proc_ptr_15.f90: Modified.
* gfortran.dg/proc_ptr_result_5.f90: Modified.
* gfortran.dg/typebound_override_1.f90: Modified.
* gfortran.dg/typebound_proc_6.f03: Modified.
2012-08-06 Marc Glisse <marc.glisse@inria.fr> 2012-08-06 Marc Glisse <marc.glisse@inria.fr>
PR tree-optimization/51938 PR tree-optimization/51938
......
...@@ -15,7 +15,7 @@ program main ...@@ -15,7 +15,7 @@ program main
end type end type
type(u), external :: ufunc type(u), external :: ufunc
call sub(ufunc) ! { dg-error "Type/rank mismatch in return value" } call sub(ufunc) ! { dg-error "Type/rank mismatch in function result" }
contains contains
......
! { dg-do compile }
!
! PR 35831: [F95] Shape mismatch check missing for dummy procedure argument
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
implicit none
call call_a(a1) ! { dg-error "Character length mismatch in function result" }
call call_a(a2) ! { dg-error "Character length mismatch in function result" }
call call_b(b1) ! { dg-error "Shape mismatch" }
call call_c(c1) ! { dg-error "POINTER attribute mismatch in function result" }
call call_d(c1) ! { dg-error "ALLOCATABLE attribute mismatch in function result" }
call call_e(e1) ! { dg-error "CONTIGUOUS attribute mismatch in function result" }
call call_f(c1) ! { dg-error "PROCEDURE POINTER mismatch in function result" }
contains
character(1) function a1()
end function
character(:) function a2()
end function
subroutine call_a(a3)
interface
character(2) function a3()
end function
end interface
end subroutine
function b1()
integer, dimension(1:3) :: b1
end function
subroutine call_b(b2)
interface
function b2()
integer, dimension(0:4) :: b2
end function
end interface
end subroutine
integer function c1()
end function
subroutine call_c(c2)
interface
function c2()
integer, pointer :: c2
end function
end interface
end subroutine
subroutine call_d(d2)
interface
function d2()
integer, allocatable :: d2
end function
end interface
end subroutine
function e1()
integer, dimension(:), pointer :: e1
end function
subroutine call_e(e2)
interface
function e2()
integer, dimension(:), pointer, contiguous :: e2
end function
end interface
end subroutine
subroutine call_f(f2)
interface
function f2()
procedure(integer), pointer :: f2
end function
end interface
end subroutine
end
...@@ -37,7 +37,7 @@ CONTAINS ...@@ -37,7 +37,7 @@ CONTAINS
END INTERFACE END INTERFACE
INTEGER, EXTERNAL :: UserOp INTEGER, EXTERNAL :: UserOp
res = UserFunction( a,b, UserOp ) ! { dg-error "Type/rank mismatch in return value" } res = UserFunction( a,b, UserOp ) ! { dg-error "Type/rank mismatch in function result" }
if( res .lt. 10 ) then if( res .lt. 10 ) then
res = recSum( a, res, UserFunction, UserOp ) res = recSum( a, res, UserFunction, UserOp )
......
...@@ -40,11 +40,11 @@ program bsp ...@@ -40,11 +40,11 @@ program bsp
p2 => p1 p2 => p1
p1 => p2 p1 => p2
p1 => abs ! { dg-error "Type/rank mismatch in return value" } p1 => abs ! { dg-error "Type/rank mismatch in function result" }
p2 => abs ! { dg-error "Type/rank mismatch in return value" } p2 => abs ! { dg-error "Type/rank mismatch in function result" }
p3 => dsin p3 => dsin
p3 => sin ! { dg-error "Type/rank mismatch in return value" } p3 => sin ! { dg-error "Type/rank mismatch in function result" }
contains contains
......
...@@ -19,10 +19,10 @@ p4 => p3 ...@@ -19,10 +19,10 @@ p4 => p3
p6 => p1 p6 => p1
! invalid ! invalid
p1 => iabs ! { dg-error "Type/rank mismatch in return value" } p1 => iabs ! { dg-error "Type/rank mismatch in function result" }
p1 => p2 ! { dg-error "Type/rank mismatch in return value" } p1 => p2 ! { dg-error "Type/rank mismatch in function result" }
p1 => p5 ! { dg-error "Type/rank mismatch in return value" } p1 => p5 ! { dg-error "Type/rank mismatch in function result" }
p6 => iabs ! { dg-error "Type/rank mismatch in return value" } p6 => iabs ! { dg-error "Type/rank mismatch in function result" }
p4 => p2 ! { dg-error "is not a subroutine" } p4 => p2 ! { dg-error "is not a subroutine" }
contains contains
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
program test program test
procedure(real), pointer :: p procedure(real), pointer :: p
p => f() ! { dg-error "Type/rank mismatch in return value" } p => f() ! { dg-error "Type/rank mismatch in function result" }
contains contains
function f() function f()
pointer :: f pointer :: f
...@@ -17,4 +17,3 @@ contains ...@@ -17,4 +17,3 @@ contains
f = .true._1 f = .true._1
end function f end function f
end program test end program test
...@@ -19,11 +19,11 @@ module m ...@@ -19,11 +19,11 @@ module m
type, extends(t1) :: t2 type, extends(t1) :: t2
contains contains
procedure, nopass :: a => a2 ! { dg-error "Character length mismatch" } procedure, nopass :: a => a2 ! { dg-error "Character length mismatch in function result" }
procedure, nopass :: b => b2 ! { dg-error "should have matching result types and ranks" } procedure, nopass :: b => b2 ! { dg-error "Type/rank mismatch in function result" }
procedure, nopass :: c => c2 ! { dg-warning "Possible character length mismatch" } procedure, nopass :: c => c2 ! FIXME: dg-warning "Possible character length mismatch"
procedure, nopass :: d => d2 ! valid, check for commutativity (+,*) procedure, nopass :: d => d2 ! valid, check for commutativity (+,*)
procedure, nopass :: e => e2 ! { dg-error "Character length mismatch" } procedure, nopass :: e => e2 ! { dg-error "Character length mismatch in function result" }
end type end type
contains contains
...@@ -110,7 +110,7 @@ module w2 ...@@ -110,7 +110,7 @@ module w2
type, extends(tt1) :: tt2 type, extends(tt1) :: tt2
contains contains
procedure, nopass :: aa => aa2 ! { dg-warning "Possible character length mismatch" } procedure, nopass :: aa => aa2 ! FIXME: dg-warning "Possible character length mismatch"
end type end type
contains contains
......
...@@ -72,7 +72,7 @@ MODULE testmod ...@@ -72,7 +72,7 @@ MODULE testmod
PROCEDURE, NOPASS :: subroutine2 => proc_intfunc ! { dg-error "must also be a SUBROUTINE" } PROCEDURE, NOPASS :: subroutine2 => proc_intfunc ! { dg-error "must also be a SUBROUTINE" }
PROCEDURE, NOPASS :: intfunction1 => proc_intfunc ! Ok, matching functions. PROCEDURE, NOPASS :: intfunction1 => proc_intfunc ! Ok, matching functions.
PROCEDURE, NOPASS :: intfunction2 => proc_sub ! { dg-error "must also be a FUNCTION" } PROCEDURE, NOPASS :: intfunction2 => proc_sub ! { dg-error "must also be a FUNCTION" }
PROCEDURE, NOPASS :: intfunction3 => proc_realfunc ! { dg-error "matching result types" } PROCEDURE, NOPASS :: intfunction3 => proc_realfunc ! { dg-error "Type/rank mismatch in function result" }
! For access-based checks. ! For access-based checks.
PROCEDURE, NOPASS, PUBLIC :: priv => proc_sub ! Ok, increases visibility. PROCEDURE, NOPASS, PUBLIC :: priv => proc_sub ! Ok, increases visibility.
......
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