From 7fd614ee818983274eb5e47cbb8ec68b20994963 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Thu, 11 Jun 2020 20:29:45 +0200 Subject: [PATCH] PR fortran/95544 - Fix ICE in NULL() argument to intrinsics 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 Harald Anlauf 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. --- gcc/fortran/check.c | 30 ++++++++++++++++----------- gcc/fortran/gfortran.h | 1 + gcc/fortran/intrinsic.c | 12 +++++++++++ gcc/testsuite/gfortran.dg/pr95544.f90 | 15 ++++++++++++++ 4 files changed, 46 insertions(+), 12 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr95544.f90 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 0afb96c0414..148a3269815 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 0ef7b1b0eff..6d76efb5298 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 */ diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 17f5efc6566..60d91f658bd 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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) { diff --git a/gcc/testsuite/gfortran.dg/pr95544.f90 b/gcc/testsuite/gfortran.dg/pr95544.f90 new file mode 100644 index 00000000000..01b9fc5cc9f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr95544.f90 @@ -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 -- 2.30.2