procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

PR fortran/95544 - Fix ICE in NULL() argument to intrinsics

Browse source 
Fortran 2018: An argument to an intrinsic procedure other than ASSOCIATED,
NULL, or PRESENT shall be a data object.  An EXPR_NULL is not a data
object.  Add checks for intrinsics.

2020-06-11  Steven G. Kargl  <kargl@gcc.gnu.org>
	    Harald Anlauf  <anlauf@gmx.de>

gcc/fortran/
	PR fortran/95544
	* check.c (invalid_null_arg): Rename to gfc_invalid_null_arg.
	(gfc_check_associated, gfc_check_kind, gfc_check_merge)
	(gfc_check_shape, gfc_check_size, gfc_check_spread)
	(gfc_check_transfer): Adjust.
	(gfc_check_len_lentrim, gfc_check_trim): Check for NULL() argument.
	* gfortran.h: Declare gfc_invalid_null_arg ().
	* intrinsic.c (check_arglist): Check for NULL() argument.
This commit is contained in:
Harald Anlauf 2020-06-11 20:29:45 +02:00
parent 1c140cfbfa
commit 7fd614ee81
4 changed files with 46 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
gcc/fortran/check.c
View file

@ -1431,8 +1431,8 @@ gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
return true;
}
static bool
invalid_null_arg (gfc_expr *x)
bool
gfc_invalid_null_arg (gfc_expr *x)
{
if (x->expr_type == EXPR_NULL)
{
@ -1451,7 +1451,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
int i;
bool t;
if (invalid_null_arg (pointer))
if (gfc_invalid_null_arg (pointer))
return false;
attr1 = gfc_expr_attr (pointer);
@ -1477,7 +1477,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
if (target == NULL)
return true;
if (invalid_null_arg (target))
if (gfc_invalid_null_arg (target))
return false;
if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
@ -3374,7 +3374,7 @@ gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
bool
gfc_check_kind (gfc_expr *x)
{
if (invalid_null_arg (x))
if (gfc_invalid_null_arg (x))
return false;
if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS)
@ -3453,6 +3453,9 @@ gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
if (!type_check (s, 0, BT_CHARACTER))
return false;
if (gfc_invalid_null_arg (s))
return false;
if (!kind_check (kind, 1, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
@ -4138,10 +4141,10 @@ gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
bool
gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
{
if (invalid_null_arg (tsource))
if (gfc_invalid_null_arg (tsource))
return false;
if (invalid_null_arg (fsource))
if (gfc_invalid_null_arg (fsource))
return false;
if (!same_type_check (tsource, 0, fsource, 1))
@ -5061,7 +5064,7 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind)
{
gfc_array_ref *ar;
if (invalid_null_arg (source))
if (gfc_invalid_null_arg (source))
return false;
if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
@ -5146,7 +5149,7 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
bool
gfc_check_sizeof (gfc_expr *arg)
{
if (invalid_null_arg (arg))
if (gfc_invalid_null_arg (arg))
return false;
if (arg->ts.type == BT_PROCEDURE)
@ -5634,7 +5637,7 @@ gfc_check_sngl (gfc_expr *a)
bool
gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
{
if (invalid_null_arg (source))
if (gfc_invalid_null_arg (source))
return false;
if (source->rank >= GFC_MAX_DIMENSIONS)
@ -6167,7 +6170,7 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
size_t source_size;
size_t result_size;
if (invalid_null_arg (source))
if (gfc_invalid_null_arg (source))
return false;
/* SOURCE shall be a scalar or array of any type. */
@ -6186,7 +6189,7 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
if (mold->ts.type == BT_BOZ && illegal_boz_arg (mold))
return false;
if (invalid_null_arg (mold))
if (gfc_invalid_null_arg (mold))
return false;
/* MOLD shall be a scalar or array of any type. */
@ -6412,6 +6415,9 @@ gfc_check_trim (gfc_expr *x)
if (!type_check (x, 0, BT_CHARACTER))
return false;
if (gfc_invalid_null_arg (x))
return false;
if (!scalar_check (x, 0))
return false;

1
gcc/fortran/gfortran.h
View file

@ -3553,6 +3553,7 @@ bool gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*,
bool gfc_boz2int (gfc_expr *, int);
bool gfc_boz2real (gfc_expr *, int);
bool gfc_invalid_boz (const char *, locus *);
bool gfc_invalid_null_arg (gfc_expr *);
/* class.c */

12
gcc/fortran/intrinsic.c
View file

@ -4442,6 +4442,18 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
return false;
}
/* F2018, p. 328: An argument to an intrinsic procedure other than
ASSOCIATED, NULL, or PRESENT shall be a data object. An EXPR_NULL
is not a data object. */
if (actual->expr->expr_type == EXPR_NULL
&& (!(sym->id == GFC_ISYM_ASSOCIATED
|| sym->id == GFC_ISYM_NULL
|| sym->id == GFC_ISYM_PRESENT)))
{
gfc_invalid_null_arg (actual->expr);
return false;
}
/* If the formal argument is INTENT([IN]OUT), check for definability. */
if (formal->intent == INTENT_INOUT || formal->intent == INTENT_OUT)
{

15
gcc/testsuite/gfortran.dg/pr95544.f90 Normal file
View file

@ -0,0 +1,15 @@
! { dg-do compile }
! PR fortran/95544 - ICE in gfc_can_put_var_on_stack, at fortran/trans-decl.c:494
program test
character(:), allocatable :: z
character(:), pointer :: p
character(1), pointer :: c
print *, adjustl (null(z)) ! { dg-error "is not permitted as actual argument" }
print *, adjustr (null(z)) ! { dg-error "is not permitted as actual argument" }
print *, len (null(p)) ! { dg-error "is not permitted as actual argument" }
print *, len (null(z)) ! { dg-error "is not permitted as actual argument" }
print *, len_trim(null(c)) ! { dg-error "is not permitted as actual argument" }
print *, len_trim(null(z)) ! { dg-error "is not permitted as actual argument" }
print *, trim (null(z)) ! { dg-error "is not permitted as actual argument" }
end