PR fortran/48958 - Add runtime diagnostics for SIZE intrinsic function
Add code for runtime checking of status of ALLOCATABLE and POINTER arguments to the SIZE intrinsic when -fcheck=pointer is specified. gcc/fortran/ChangeLog: * trans-intrinsic.c (gfc_conv_intrinsic_size): Generate runtime checking code for status of argument. gcc/testsuite/ChangeLog: * gfortran.dg/pr48958.f90: New test.
This commit is contained in:
parent
a71a2255bc
commit
0c81ccc3d8
|
@ -7929,6 +7929,35 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
|
|||
&& strcmp (e->ref->u.c.component->name, "_data") == 0)
|
||||
sym = e->symtree->n.sym;
|
||||
|
||||
if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
|
||||
&& e
|
||||
&& (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
|
||||
{
|
||||
symbol_attribute attr;
|
||||
char *msg;
|
||||
|
||||
attr = gfc_expr_attr (e);
|
||||
if (attr.allocatable)
|
||||
msg = xasprintf ("Allocatable argument '%s' is not allocated",
|
||||
e->symtree->n.sym->name);
|
||||
else if (attr.pointer)
|
||||
msg = xasprintf ("Pointer argument '%s' is not associated",
|
||||
e->symtree->n.sym->name);
|
||||
else
|
||||
goto end_arg_check;
|
||||
|
||||
argse.descriptor_only = 1;
|
||||
gfc_conv_expr_descriptor (&argse, actual->expr);
|
||||
tree temp = gfc_conv_descriptor_data_get (argse.expr);
|
||||
tree cond = fold_build2_loc (input_location, EQ_EXPR,
|
||||
logical_type_node, temp,
|
||||
fold_convert (TREE_TYPE (temp),
|
||||
null_pointer_node));
|
||||
gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
|
||||
free (msg);
|
||||
}
|
||||
end_arg_check:
|
||||
|
||||
argse.data_not_needed = 1;
|
||||
if (gfc_is_class_array_function (e))
|
||||
{
|
||||
|
|
|
@ -0,0 +1,25 @@
|
|||
! { dg-do run }
|
||||
! { dg-options "-fcheck=pointer -fdump-tree-original" }
|
||||
! { dg-shouldfail "Fortran runtime error: Allocatable argument 'a' is not allocated" }
|
||||
! { dg-output "At line 13 .*" }
|
||||
! PR48958 - Add runtime diagnostics for SIZE intrinsic function
|
||||
|
||||
program p
|
||||
integer :: n
|
||||
integer, allocatable :: a(:)
|
||||
integer, pointer :: b(:)
|
||||
class(*), allocatable :: c(:)
|
||||
integer :: d(10)
|
||||
print *, size (a)
|
||||
print *, size (b)
|
||||
print *, size (c)
|
||||
print *, size (d)
|
||||
print *, size (f(n))
|
||||
contains
|
||||
function f (n)
|
||||
integer, intent(in) :: n
|
||||
real, allocatable :: f(:)
|
||||
end function f
|
||||
end
|
||||
|
||||
! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 4 "original" } }
|
Loading…
Reference in New Issue