From patchwork Thu Jun 11 14:39:02 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 1307590 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=gmx.de Authentication-Results: ozlabs.org; dkim=fail reason="signature verification failed" (1024-bit key; secure) header.d=gmx.net header.i=@gmx.net header.a=rsa-sha256 header.s=badeba3b8450 header.b=i52hdyqX; dkim-atps=neutral Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 49jRM70CqWz9sR4 for ; Fri, 12 Jun 2020 00:39:12 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id AC0DF39540F4; Thu, 11 Jun 2020 14:39:07 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mout.gmx.net (mout.gmx.net [212.227.17.22]) by sourceware.org (Postfix) with ESMTPS id C319F393C8B4; Thu, 11 Jun 2020 14:39:04 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org C319F393C8B4 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=gmx.de Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=anlauf@gmx.de DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.net; s=badeba3b8450; t=1591886342; bh=FCz7njxU9teMw03IoEEdbmRItgGdZnC6rB6F+cuL0+0=; h=X-UI-Sender-Class:From:To:Cc:Subject:Date:In-Reply-To:References; b=i52hdyqXxPJga8For7pF8MN/URfGxzu/VXtdL5UP/24ZydTgmZRZo5w0w0gBXBN9f N3UBSMZAiYpAFVNrGOUMhlPS311JP++SFRgNQHC6WgDbWD0dH24eDnUHF7+tYcVVTd t8s4SKDSeRDhUcYVNmbYNXw6806d3smHpnjrEB5I= X-UI-Sender-Class: 01bb95c1-4bf8-414a-932a-4f6e2808ef9c Received: from [93.207.81.85] ([93.207.81.85]) by web-mail.gmx.net (3c-app-gmx-bap74.server.lan [172.19.172.174]) (via HTTP); Thu, 11 Jun 2020 16:39:02 +0200 MIME-Version: 1.0 Message-ID: From: Harald Anlauf To: Harald Anlauf Subject: [PATCH] PR fortran/95544 - ICE in gfc_can_put_var_on_stack, at fortran/trans-decl.c:494 Date: Thu, 11 Jun 2020 16:39:02 +0200 Importance: normal Sensitivity: Normal In-Reply-To: References: X-UI-Message-Type: mail X-Priority: 3 X-Provags-ID: V03:K1:hNKn6upNj+deyyKqTkEHSvlz5JJ0AnKMLozEC3L7ZAJ+hgRRD1ILu1xyRlWc8SVF3RzsP 1SE9w9JP76txQ/Q+VndwImavqrVrJRYXJ9jbxvmuBtbLbiDSe80VHsAr1lKfenB09fm2GbsCBYmR OWS6zYEFExVVTKxX0PtIjzuI+SN7nZ0OqK6v23d34OAHYU7FV5aErmBIANRLlkPgOGZxmjdC9/mq NnPdu3+FXa6SChAeAg/sYo1eKCGZTw06+gYHxuOVs5xuczqZT8ev5MJHdWshXKlHW9oK/tRH6wUS w0= X-UI-Out-Filterresults: notjunk:1;V03:K0:UlkidGzueLM=:r+mGjeuqauZ7vHNUiE5M/Q T/UQ4qgyJXTrr5sR69bQ8t6fjfAvgkZEIc8ji0KAph+t1Z8RKBgKDDYViATkT7bCwD7SCVLqQ Q92ZgZxpOOHFxbNcrZzuxc5Qbhqqo9mg4BG+O9116OTre98lbmewfAzWau6eSZClmFEGXygJw Znt/DxPBwWv3r9AJcdrp0O/1AL5y72cs3juTqDt6RWPAwbFRYSF12T3fg/+sXcRFQdns84sNk R8dzm+hHcqNct3vYTEiVA+/Ezh3ghvrX8Y4YUzclox4vZyYFu5eaK/xBuxQ2F9kKDXccbn+YE DLTRf0JmHECm7QyrTXaN5FSxQEULOXqoLf8G/fNKzeH2flyV2zPWs0Gjds1p18VGtXxA6/jEj Ci0NeVHmjpCCgYHTM/ih+jLhj/WuvbPll6RZJhQpkp573+jJeMD6kIp6MibOUQAoqjifRFI+v P1UOFlTabxQwIPR8/l0lYR04cBF+R2WHrQgeDbK7HpjQMmRBsPUCog/8tExoIvhKBkQXxMIHU XgaVUt/QkkIiMbZ4AEf5/qjZ3HGp26ifiJpPe1jadGVRulv+VUauDHzoyFgJMcsvK8HewFEcX fDsh5TKcgP2nGK9pKjjQ2Bx2G5VuN/3jas4pk4qB0O7/qZ5hGQpiYzc0U6YVGcFWcjgIS9WEe l62uwBwvTBPeICiyn9aPrC/TTfyM+uGk7V3qcml774bOxh0PWBYWMjyrFM41pMKFo664= X-Spam-Status: No, score=-11.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, FREEMAIL_FROM, GIT_PATCH_0, KAM_NUMSUBJECT, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H2, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: gcc-patches , fortran Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" > Gesendet: Montag, 08. Juni 2020 um 22:25 Uhr > Von: "Harald Anlauf" > An: "fortran" , "gcc-patches" > Betreff: [PATCH] PR fortran/95544 - ICE in gfc_can_put_var_on_stack, at fortran/trans-decl.c:494 OK, now with a brown bag over my head, here comes the patch instead of just the testcase. Thanks to Thomas for pointing that out in private. Harald 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..95150c8b6ce 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 + && !(strcmp(gfc_current_intrinsic, "associated") == 0 + || strcmp(gfc_current_intrinsic, "null") == 0 + || strcmp(gfc_current_intrinsic, "present") == 0)) + { + 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