mirror of git://gcc.gnu.org/git/gcc.git
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
This commit is contained in:
Janus Weil
parent
ef859c9d3c
commit
edc802c796
|
|
@ -1,3 +1,10 @@
|
|||
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>
|
||||
|
||||
PR fortran/54033
|
||||
|
|
|
|||
|
|
@ -1006,7 +1006,6 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
|
|||
/* Check type and rank. */
|
||||
if (type_must_agree && !compare_type_rank (s2, s1))
|
||||
{
|
||||
if (errmsg != NULL)
|
||||
snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
|
||||
s1->name);
|
||||
return FAILURE;
|
||||
|
|
@ -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.
|
||||
We return nonzero if there exists an actual argument list that
|
||||
would be ambiguous between the two interfaces, zero otherwise.
|
||||
|
|
@ -1180,20 +1325,12 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
|
|||
{
|
||||
if (s1->attr.function && s2->attr.function)
|
||||
{
|
||||
/* If both are functions, check result type. */
|
||||
if (s1->ts.type == BT_UNKNOWN)
|
||||
return 1;
|
||||
if (!compare_type_rank (s1,s2))
|
||||
{
|
||||
if (errmsg != NULL)
|
||||
snprintf (errmsg, err_len, "Type/rank mismatch in return value "
|
||||
"of '%s'", name2);
|
||||
/* If both are functions, check result characteristics. */
|
||||
if (check_result_characteristics (s1, s2, errmsg, err_len)
|
||||
== FAILURE)
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* FIXME: Check array bounds and string length of result. */
|
||||
}
|
||||
|
||||
if (s1->attr.pure && !s2->attr.pure)
|
||||
{
|
||||
snprintf (errmsg, err_len, "Mismatch in PURE attribute");
|
||||
|
|
@ -3793,7 +3930,7 @@ gfc_try
|
|||
gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
|
||||
{
|
||||
locus where;
|
||||
const gfc_symbol *proc_target, *old_target;
|
||||
gfc_symbol *proc_target, *old_target;
|
||||
unsigned proc_pass_arg, old_pass_arg, argpos;
|
||||
gfc_formal_arglist *proc_formal, *old_formal;
|
||||
bool check_type;
|
||||
|
|
@ -3873,45 +4010,13 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
|
|||
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))
|
||||
if (check_result_characteristics (proc_target, old_target,
|
||||
err, sizeof(err)) == FAILURE)
|
||||
{
|
||||
gfc_error ("'%s' at %L and the overridden FUNCTION should have"
|
||||
" matching result types and ranks", proc->name, &where);
|
||||
gfc_error ("Result mismatch for the overriding procedure "
|
||||
"'%s' at %L: %s", proc->name, &where, err);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* Check string length. */
|
||||
if (proc_target->result->ts.type == BT_CHARACTER
|
||||
&& 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,
|
||||
old_target->result->ts.u.cl->length);
|
||||
switch (compval)
|
||||
{
|
||||
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;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/* If the overridden binding is PUBLIC, the overriding one must not be
|
||||
|
|
|
|||
|
|
@ -1,3 +1,15 @@
|
|||
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>
|
||||
|
||||
PR tree-optimization/51938
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ program main
|
|||
end type
|
||||
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,88 @@
|
|||
! { 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
|
|||
END INTERFACE
|
||||
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
|
||||
res = recSum( a, res, UserFunction, UserOp )
|
||||
|
|
|
|||
|
|
@ -40,11 +40,11 @@ program bsp
|
|||
p2 => p1
|
||||
p1 => p2
|
||||
|
||||
p1 => abs ! { dg-error "Type/rank mismatch in return value" }
|
||||
p2 => 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 function result" }
|
||||
|
||||
p3 => dsin
|
||||
p3 => sin ! { dg-error "Type/rank mismatch in return value" }
|
||||
p3 => sin ! { dg-error "Type/rank mismatch in function result" }
|
||||
|
||||
contains
|
||||
|
||||
|
|
|
|||
|
|
@ -19,10 +19,10 @@ p4 => p3
|
|||
p6 => p1
|
||||
|
||||
! invalid
|
||||
p1 => iabs ! { dg-error "Type/rank mismatch in return value" }
|
||||
p1 => p2 ! { dg-error "Type/rank mismatch in return value" }
|
||||
p1 => p5 ! { dg-error "Type/rank mismatch in return value" }
|
||||
p6 => 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 function result" }
|
||||
p1 => p5 ! { dg-error "Type/rank mismatch in function result" }
|
||||
p6 => iabs ! { dg-error "Type/rank mismatch in function result" }
|
||||
p4 => p2 ! { dg-error "is not a subroutine" }
|
||||
|
||||
contains
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
|
||||
program test
|
||||
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
|
||||
function f()
|
||||
pointer :: f
|
||||
|
|
@ -17,4 +17,3 @@ contains
|
|||
f = .true._1
|
||||
end function f
|
||||
end program test
|
||||
|
||||
|
|
|
|||
|
|
@ -19,11 +19,11 @@ module m
|
|||
|
||||
type, extends(t1) :: t2
|
||||
contains
|
||||
procedure, nopass :: a => a2 ! { dg-error "Character length mismatch" }
|
||||
procedure, nopass :: b => b2 ! { dg-error "should have matching result types and ranks" }
|
||||
procedure, nopass :: c => c2 ! { dg-warning "Possible character length mismatch" }
|
||||
procedure, nopass :: a => a2 ! { dg-error "Character length mismatch in function result" }
|
||||
procedure, nopass :: b => b2 ! { dg-error "Type/rank mismatch in function result" }
|
||||
procedure, nopass :: c => c2 ! FIXME: dg-warning "Possible character length mismatch"
|
||||
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
|
||||
|
||||
contains
|
||||
|
|
@ -110,7 +110,7 @@ module w2
|
|||
|
||||
type, extends(tt1) :: tt2
|
||||
contains
|
||||
procedure, nopass :: aa => aa2 ! { dg-warning "Possible character length mismatch" }
|
||||
procedure, nopass :: aa => aa2 ! FIXME: dg-warning "Possible character length mismatch"
|
||||
end type
|
||||
|
||||
contains
|
||||
|
|
|
|||
|
|
@ -72,7 +72,7 @@ MODULE testmod
|
|||
PROCEDURE, NOPASS :: subroutine2 => proc_intfunc ! { dg-error "must also be a SUBROUTINE" }
|
||||
PROCEDURE, NOPASS :: intfunction1 => proc_intfunc ! Ok, matching functions.
|
||||
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.
|
||||
PROCEDURE, NOPASS, PUBLIC :: priv => proc_sub ! Ok, increases visibility.
|
||||
|
|
|
|||
Loading…
Reference in New Issue