From 5a26ea7e0f8b9a00a2eb0a5e8f70efa04056f167 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Tue, 5 May 2020 22:16:50 +0200 Subject: [PATCH] PR fortran/93366 - ICE on invalid, reject invalid use of NULL() as argument gcc/fortran/ChangeLog: 2020-05-05 Steve Kargl Harald Anlauf PR fortran/93366 * check.c (gfc_check_associated, invalid_null_arg): Factorize check for presence of invalid NULL() argument. (gfc_check_kind, gfc_check_merge, gfc_check_shape) (gfc_check_sizeof, gfc_check_spread, gfc_check_transfer): Use this check for presence of invalid NULL() arguments. gcc/testsuite/ChangeLog: 2020-05-05 Harald Anlauf PR fortran/93366 * gfortran.dg/pr93366.f90: New test. --- gcc/fortran/ChangeLog | 10 +++++++ gcc/fortran/check.c | 55 +++++++++++++++++++++++++---------- gcc/testsuite/ChangeLog | 5 ++++ gcc/testsuite/gfortran.dg/pr93366.f90 | 18 ++++++++++++ 4 files changed, 73 insertions(+), 15 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr93366.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f245cb4..beeabfa 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2020-05-05 Steve Kargl + Harald Anlauf + + PR fortran/93366 + * check.c (gfc_check_associated, invalid_null_arg): Factorize + check for presence of invalid NULL() argument. + (gfc_check_kind, gfc_check_merge, gfc_check_shape) + (gfc_check_sizeof, gfc_check_spread, gfc_check_transfer): Use this + check for presence of invalid NULL() arguments. + 2020-04-29 Stefan Schulze Frielinghaus PR fortran/94769 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index cdabbf5..0afb96c 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1431,6 +1431,18 @@ gfc_check_x_yd (gfc_expr *x, gfc_expr *y) return true; } +static bool +invalid_null_arg (gfc_expr *x) +{ + if (x->expr_type == EXPR_NULL) + { + gfc_error ("NULL at %L is not permitted as actual argument " + "to %qs intrinsic function", &x->where, + gfc_current_intrinsic); + return true; + } + return false; +} bool gfc_check_associated (gfc_expr *pointer, gfc_expr *target) @@ -1438,12 +1450,9 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) symbol_attribute attr1, attr2; int i; bool t; - locus *where; - where = &pointer->where; - - if (pointer->expr_type == EXPR_NULL) - goto null_arg; + if (invalid_null_arg (pointer)) + return false; attr1 = gfc_expr_attr (pointer); @@ -1468,9 +1477,8 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) if (target == NULL) return true; - where = &target->where; - if (target->expr_type == EXPR_NULL) - goto null_arg; + if (invalid_null_arg (target)) + return false; if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION) attr2 = gfc_expr_attr (target); @@ -1518,13 +1526,6 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) } } return t; - -null_arg: - - gfc_error ("NULL pointer at %L is not permitted as actual argument " - "of %qs intrinsic function", where, gfc_current_intrinsic); - return false; - } @@ -3373,6 +3374,9 @@ 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)) + return false; + if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS) { gfc_error ("%qs argument of %qs intrinsic at %L must be of " @@ -4134,6 +4138,12 @@ 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)) + return false; + + if (invalid_null_arg (fsource)) + return false; + if (!same_type_check (tsource, 0, fsource, 1)) return false; @@ -5051,6 +5061,9 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind) { gfc_array_ref *ar; + if (invalid_null_arg (source)) + return false; + if (source->rank == 0 || source->expr_type != EXPR_VARIABLE) return true; @@ -5133,6 +5146,9 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) bool gfc_check_sizeof (gfc_expr *arg) { + if (invalid_null_arg (arg)) + return false; + if (arg->ts.type == BT_PROCEDURE) { gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure", @@ -5618,6 +5634,9 @@ gfc_check_sngl (gfc_expr *a) bool gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) { + if (invalid_null_arg (source)) + return false; + if (source->rank >= GFC_MAX_DIMENSIONS) { gfc_error ("%qs argument of %qs intrinsic at %L must be less " @@ -6148,6 +6167,9 @@ 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)) + return false; + /* SOURCE shall be a scalar or array of any type. */ if (source->ts.type == BT_PROCEDURE && source->symtree->n.sym->attr.subroutine == 1) @@ -6164,6 +6186,9 @@ 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)) + return false; + /* MOLD shall be a scalar or array of any type. */ if (mold->ts.type == BT_PROCEDURE && mold->symtree->n.sym->attr.subroutine == 1) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index eeb502b..b36f874 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2020-05-05 Harald Anlauf + + PR fortran/93366 + * gfortran.dg/pr93366.f90: New test. + 2020-05-05 Michael Meissner * gcc.dg/nextafter-2.c: Delete changes meant for a private branch. diff --git a/gcc/testsuite/gfortran.dg/pr93366.f90 b/gcc/testsuite/gfortran.dg/pr93366.f90 new file mode 100644 index 0000000..3cb6d1d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr93366.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR fortran/93366 - ICE on invalid, reject invalid use of NULL() as argument + +program p + print *, kind (null()) ! { dg-error "NULL at" } + print *, [ merge(null(), [1] ,.true.) ] ! { dg-error "NULL at" } + print *, [ merge([1] , null(),.true.) ] ! { dg-error "NULL at" } + print *, [ merge(null(), null(),.true.) ] ! { dg-error "NULL at" } + print *, shape (null()) ! { dg-error "NULL at" } + print *, sizeof (null()) ! { dg-error "NULL at" } + print *, spread (null(),1,1) ! { dg-error "NULL at" } + print *, transfer ( 1 , null()) ! { dg-error "NULL at" } + print *, transfer ([1], null()) ! { dg-error "NULL at" } + print *, transfer (null(), 1) ! { dg-error "NULL at" } + print *, transfer (null(), [1]) ! { dg-error "NULL at" } + print *, transfer (null(), null()) ! { dg-error "NULL at" } +end -- 2.7.4