From patchwork Tue Nov 21 21:54:50 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 80511 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 5A3E53858C2F for ; Tue, 21 Nov 2023 21:55:19 +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.21]) by sourceware.org (Postfix) with ESMTPS id A920A3858D33; Tue, 21 Nov 2023 21:54:58 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org A920A3858D33 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=gmx.de Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmx.de ARC-Filter: OpenARC Filter v1.0.0 sourceware.org A920A3858D33 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=212.227.17.21 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1700603701; cv=none; b=xc8isopyxSXUsrakDTVswLnQKWt1EUVILTroqIYamHOcs3LHSJ1QsS/o9zKnM3OttRUfxEjLrZD5GMlsgx40zEbTcmJ2KSnTR4WhDp16JyWo3++vshgqhr+NLUeG2kMEhM+dGJIvRiShBtv9BfuyQh4yCPX/DAfQQgEcqBNbEqE= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1700603701; c=relaxed/simple; bh=NsZ29Ivs5VXcmxgAZHQUO5W+W5/ZMiodz4latEr7BlM=; h=DKIM-Signature:Message-ID:Date:MIME-Version:Subject:To:From; b=rBYkwpfdZ2Dg+VlkEjvVJ6XMqLnN/2yjkvX5wRLBg49ugIOQAtk5Q3vNDnfv/g3pMB9u9remWXvaUlwoqZ9IMqPSNXisnrfGkhYuYDZl6IRBoglp5o889M7pDd6L8LYq3NmQWPzk7QEkCYqR70YdfLzqcP5dEcKpu+/UPLgX5tA= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.de; s=s31663417; t=1700603694; x=1701208494; i=anlauf@gmx.de; bh=NsZ29Ivs5VXcmxgAZHQUO5W+W5/ZMiodz4latEr7BlM=; h=X-UI-Sender-Class:Date:Subject:To:Cc:References:From: In-Reply-To; b=lJfcJz35Uu+lPfaEm7UERWipMv4s1ONZocHevWoXZ18DykDze5AsNpVNe/yYQp1X vY58pKJmowkKFtO0TXUg25ufYDPHHlCF1Luk8ZG5LxzeyKMEhWoRkZU3OTfDn174l psnvc2Ykcf+Ua6F75gHXZZF5yAzAc62nBLd5YFpjkCKvcrnInsrg7s5PhDjgGCjiw WZUlemWlGao5IVsyUIpxg0h/xfACVmRK34b75stSUxp+cqfBWvwc/mMx2HPEL0Mgn X+ZzrpFS3uhZ7MrrTjSqM9UpPh+kX7rQ7ZNDMjy7gEsBG3PtciEJn4L/VUpgdJkZr XgHKCaiL/BM8UG1iMg== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [192.168.178.29] ([79.251.1.100]) by mail.gmx.net (mrgmx105 [212.227.17.168]) with ESMTPSA (Nemesis) id 1M8hVB-1r0tsV1NRp-004ftZ; Tue, 21 Nov 2023 22:54:54 +0100 Message-ID: <06b5440b-fdab-4c02-988a-ea849aadfd48@gmx.de> Date: Tue, 21 Nov 2023 22:54:50 +0100 MIME-Version: 1.0 User-Agent: Mozilla Thunderbird Subject: [PATCH, v3] Fortran: restrictions on integer arguments to SYSTEM_CLOCK [PR112609] To: Mikael Morin , sgk@troutmask.apl.washington.edu Cc: fortran , gcc-patches Newsgroups: gmane.comp.gcc.patches,gmane.comp.gcc.fortran References: <2898e351-eee8-45dd-a05d-0280378ba872@gmx.de> <84f48fee-a5b8-4bef-aa9b-f176d3cfbfa6@orange.fr> Content-Language: en-US From: Harald Anlauf In-Reply-To: <84f48fee-a5b8-4bef-aa9b-f176d3cfbfa6@orange.fr> X-Provags-ID: V03:K1:9ntUx+g4SbzENSyVrAa28iuOx7uHgjz3PTp6eee3SYZAek9g1oi 1yYQ9FzBQJzxJUvldSgrTPuyI5Kg49DGhAqgwa47AB+ekyI9ONYDVL1HW95/lW93iKYL/GS QiypOHyMo9FfW9+bC9lrRLWKFoq+WLyQ20GR3WpvIZeaue+ESkBw5Q+fcPsWBwk1aLzZD4l hoP6Zc2EoH9uei5FyroqQ== UI-OutboundReport: notjunk:1;M01:P0:lQiU4DrqhZI=;r0Gnq1trzFV185CI/fnDC5hFbfO oq/w84Sum2ZvHvrg2E5OKO+E+sGussuKyrqKisAxYL4DyYvyORaor3VPEnvuZKuIYNfsXpcX5 a5MHiojyADoA3EqlXG6KGDJ2syk/yk3DtVXMrgZInh5Ii7Yf7bw94roZlKJLF0vucfSUPKKY8 QDpUOgJMvi8N/wXj1K1tqsvO2BTrqhIV0zxxs5JNhe0eyABd4BFIwUoDWUniLofaJd4CcLb7e rFHDiuaIazWJVgJw8h2K8dJZctvRL33YMJ9bNx4jsHT4mk5VPB1xSMRssRWXV0hmUbIepwS27 cOORn+buN5hnTMTVyEpSaOmJhSR4Od1PUMuE3Cg77i+QLYWVpHAGkYgJ+x6bxRwOEB50jeyIY ZIsBRdo1Bmah88YgBq8bZm+GkGjuOHtuVt9303hR+rsSoJTH7GSRmVISmbaRTDXlRkfdL7zwY BvNFG+a1WJC4QhM+Gak55gdczaJGou2dsS0y/RzPMaUMCG47n2NREHWvbojGtE47+IRP4h4nV 2IxqQtDt5GUjgjS1aRd8BYDrf0Xm52YTHuo4XvOZ0edK7Xgj0CzCtJ3tWWuLs3E5yGcd77a5X wEjJMCIuAr3iO5kQzrTO21hK4hc5BWog4uwqHRbA0yVnA3hOwFdPootBJwZdqfATEiMwWWA1z Jt2nIzJ2x18UbZ24mzVqOpeDDHMIMYL2p3ko6lDM6w9cKIUjSSLSc6xDehueRNdZtrnS8B5QU it7zqQpriGPFKn8X/YECgW7eQ11d4eKq0j/XQdVtOU0jfISAlC3C4R3rMq/btYzZCWLtr8gsO qf7H1kxTI03EKD4+RaYB0Jj8UaVV8uXRXs3+8F3YvV468sqKgcM+oO/Bi8oQibKXbJwP/noVV hSfiMQky9HFc9WkDULr6Wtktsv207lmSqikqTLA0U/u3v5CQ+Cxy1IAgt0coBIdxNvOi9VkV/ HyHbOwIVvmEujgfYRIsq3O53ohw= X-Spam-Status: No, score=-12.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H4, RCVD_IN_MSPIKE_WL, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Hi Mikael, Steve, On 11/21/23 12:33, Mikael Morin wrote: > Harald, you mentioned the lack of GFC_STD_F2023_DEL feature group in > your first message, but I don't quite understand why you didn't add one. >  It seems to me the most natural way to do this. thanks for insisting on this variant. In my first attack at this problem, I overlooked one place in libgfortran.h, which I now was able to find and adjust. Now everything falls into place. > I suggest we emit a warning by default, error with -std=f2023 (I agree > with Steve that we should push towards strict f2023 conformance), and no > diagnostic with -std=gnu or -std=f2018 or lower. As the majority agrees on this, I accept it. The attached patch now does this and fixes the testcases accordingly. >> It seems that the solution is to fix the code in the testsuite. > > Agreed, these seem to explicitly test mismatching kinds, so add an > option to prevent error. Done. I also fixed a few issues in the documentation in gfortran.texi . As I currently cannot build a full compiler (see PR112643), patch V3 is not properly regtested yet, but appears to give results as discussed. Comments? > Mikael Thanks, Harald diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 6c45e6542f0..e5cf6a495b5 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -4357,6 +4357,9 @@ gfc_check_null (gfc_expr *mold) if (mold == NULL) return true; + if (mold->expr_type == EXPR_NULL) + return true; + if (!variable_check (mold, 0, true)) return false; @@ -5189,7 +5192,7 @@ is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr) { *msg = NULL; - if (expr->expr_type == EXPR_NULL) + if (expr->expr_type == EXPR_NULL && expr->ts.type == BT_UNKNOWN) { *msg = "NULL() is not interoperable"; return false; diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index fc4fe662eab..641edf9d059 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -2387,6 +2387,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, gfc_component *ppc; bool codimension = false; gfc_array_spec *formal_as; + bool pointer_arg, allocatable_arg; + bool pre2018 = ((gfc_option.allow_std & GFC_STD_F2018) == 0); /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding procs c_f_pointer or c_f_procpointer, and we need to accept most @@ -2564,13 +2566,20 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, } } + pointer_arg = gfc_expr_attr (actual).pointer; + allocatable_arg = gfc_expr_attr (actual).allocatable; + /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this is necessary also for F03, so retain error for both. + F2018:15.5.2.5 relaxes this constraint to same attributes. NOTE: Other type/kind errors pre-empt this error. Since they are F03 compatible, no attempt has been made to channel to this one. */ if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual) && (CLASS_DATA (formal)->attr.allocatable - ||CLASS_DATA (formal)->attr.class_pointer)) + || CLASS_DATA (formal)->attr.class_pointer) + && (pre2018 + || (allocatable_arg && CLASS_DATA (formal)->attr.allocatable) + || (pointer_arg && CLASS_DATA (formal)->attr.class_pointer))) { if (where) gfc_error ("Actual argument to %qs at %L must be unlimited " @@ -2710,7 +2719,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, rank_check = where != NULL && !is_elemental && formal_as && (formal_as->type == AS_ASSUMED_SHAPE || formal_as->type == AS_DEFERRED) - && actual->expr_type != EXPR_NULL; + && !(actual->expr_type == EXPR_NULL + && actual->ts.type == BT_UNKNOWN); /* Skip rank checks for NO_ARG_CHECK. */ if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) @@ -3184,8 +3194,10 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, gfc_array_ref *actual_arr_ref; gfc_array_spec *fas, *aas; bool pointer_dummy, pointer_arg, allocatable_arg; + bool procptr_dummy, optional_dummy, allocatable_dummy; bool ok = true; + bool pre2018 = ((gfc_option.allow_std & GFC_STD_F2018) == 0); actual = *ap; @@ -3296,15 +3308,66 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && a->expr->ts.type != BT_ASSUMED) gfc_find_vtab (&a->expr->ts); + /* Checks for NULL() actual arguments without MOLD. */ + if (a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN) + { + /* Interp J3/22-146: + "If the context of the reference to NULL is an + corresponding to an dummy argument, MOLD shall be + present." */ + fas = (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym) + ? CLASS_DATA (f->sym)->as + : f->sym->as); + if (fas && fas->type == AS_ASSUMED_RANK) + { + gfc_error ("Intrinsic % without % argument " + "at %L passed to assumed-rank dummy %qs", + &a->expr->where, f->sym->name); + ok = false; + goto match; + } + + /* Asummed-length dummy argument. */ + if (f->sym->ts.type == BT_CHARACTER + && !f->sym->ts.deferred + && f->sym->ts.u.cl + && f->sym->ts.u.cl->length == NULL) + { + gfc_error ("Intrinsic % without % argument " + "at %L passed to assumed-length dummy %qs", + &a->expr->where, f->sym->name); + ok = false; + goto match; + } + } + + /* Allow passing of NULL() as disassociated pointer, procedure + pointer, or unallocated allocatable (F2008+) to a respective dummy + argument. */ + pointer_dummy = ((f->sym->ts.type != BT_CLASS + && f->sym->attr.pointer) + || (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->attr.class_pointer)); + + procptr_dummy = ((f->sym->ts.type != BT_CLASS + && f->sym->attr.proc_pointer) + || (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->attr.proc_pointer)); + + optional_dummy = f->sym->attr.optional; + + allocatable_dummy = ((f->sym->ts.type != BT_CLASS + && f->sym->attr.allocatable) + || (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->attr.allocatable)); + if (a->expr->expr_type == EXPR_NULL - && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer - && (f->sym->attr.allocatable || !f->sym->attr.optional - || (gfc_option.allow_std & GFC_STD_F2008) == 0)) - || (f->sym->ts.type == BT_CLASS - && !CLASS_DATA (f->sym)->attr.class_pointer - && (CLASS_DATA (f->sym)->attr.allocatable - || !f->sym->attr.optional - || (gfc_option.allow_std & GFC_STD_F2008) == 0)))) + && !pointer_dummy + && !procptr_dummy + && !(optional_dummy + && (gfc_option.allow_std & GFC_STD_F2008) != 0) + && !(allocatable_dummy + && (gfc_option.allow_std & GFC_STD_F2008) != 0)) { if (where && (!f->sym->attr.optional @@ -3409,6 +3472,9 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (f->sym->ts.type == BT_CLASS) goto skip_size_check; + if (a->expr->expr_type == EXPR_NULL) + goto skip_size_check; + actual_size = get_expr_storage_size (a->expr); formal_size = get_sym_storage_size (f->sym); if (actual_size != 0 && actual_size < formal_size @@ -3606,6 +3672,71 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, } } + /* Check conditions on allocatable and pointer dummy variables: + + "The actual argument shall be polymorphic if and only if the + associated dummy argument is polymorphic, and either both the + actual and dummy arguments shall be unlimited polymorphic, or the + declared type of the actual argument shall be the same as the + declared type of the dummy argument." + + with a minor difference from F2008:15.5.2.5 to F2018:15.5.2.5, + where the latter applies only to same (ALLOCATABLE or POINTER) + attributes. Note that checks related to unlimited polymorphism + are also done in compare_parameter(). */ + if ((pointer_dummy || allocatable_dummy) + && (pointer_arg || allocatable_arg) + && (pre2018 + || (pointer_dummy && pointer_arg) + || (allocatable_dummy && allocatable_arg)) + && (f->sym->ts.type == BT_CLASS + || a->expr->ts.type == BT_CLASS)) + { + if (f->sym->ts.type == BT_CLASS && a->expr->ts.type != BT_CLASS + && pointer_dummy) + { + if (where) + gfc_error ("Actual argument to %qs at %L must be a " + "CLASS POINTER", + f->sym->name, &a->expr->where); + ok = false; + goto match; + } + + if (f->sym->ts.type != BT_CLASS && a->expr->ts.type == BT_CLASS + && pointer_arg) + { + if (where) + gfc_error ("Actual argument to %qs at %L cannot be a " + "CLASS POINTER", + f->sym->name, &a->expr->where); + ok = false; + goto match; + } + + if (f->sym->ts.type == BT_CLASS && a->expr->ts.type != BT_CLASS + && allocatable_dummy) + { + if (where) + gfc_error ("Actual argument to %qs at %L must be a " + "CLASS ALLOCATABLE", + f->sym->name, &a->expr->where); + ok = false; + goto match; + } + + if (f->sym->ts.type != BT_CLASS && a->expr->ts.type == BT_CLASS + && allocatable_arg) + { + if (where) + gfc_error ("Actual argument to %qs at %L cannot be a " + "CLASS ALLOCATABLE", + f->sym->name, &a->expr->where); + ok = false; + goto match; + } + } + /* Fortran 2008, C1242. */ if (f->sym->attr.pointer && gfc_is_coindexed (a->expr)) diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 50c4604a025..30b941356b6 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -6288,16 +6288,37 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && (fsym->ts.type != BT_CLASS || !CLASS_DATA (fsym)->attr.class_pointer)) { - /* Pass a NULL pointer to denote an absent arg. */ - gcc_assert (fsym->attr.optional && !fsym->attr.allocatable - && (fsym->ts.type != BT_CLASS - || !CLASS_DATA (fsym)->attr.allocatable)); - gfc_init_se (&parmse, NULL); - parmse.expr = null_pointer_node; - if (arg->associated_dummy - && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type - == BT_CHARACTER) - parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); + if ((fsym->ts.type != BT_CLASS + && fsym->attr.allocatable) + || (fsym->ts.type == BT_CLASS + && CLASS_DATA (fsym)->attr.allocatable)) + { + /* Pass descriptor equivalent to an unallocated allocatable + actual argument. */ + if (e->rank != 0) + gfc_internal_error ("gfc_conv_procedure_call() TODO: " + "NULL(allocatable(rank != 0))"); + /* Scalar version below. */ + gfc_init_se (&parmse, NULL); + gfc_conv_expr_reference (&parmse, e); + tmp = parmse.expr; + if (TREE_CODE (tmp) == ADDR_EXPR) + tmp = TREE_OPERAND (tmp, 0); + parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp, + fsym->attr); + parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); + } + else + { + /* Pass a NULL pointer to denote an absent optional arg. */ + gcc_assert (fsym->attr.optional); + gfc_init_se (&parmse, NULL); + parmse.expr = null_pointer_node; + if (arg->associated_dummy + && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type + == BT_CHARACTER) + parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); + } } else if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_DERIVED) @@ -6852,7 +6873,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, we can assign it to the data field. */ if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK - && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL) + && fsym->ts.type != BT_CLASS + && !(e->expr_type == EXPR_NULL + && e->ts.type == BT_UNKNOWN)) { tmp = parmse.expr; if (TREE_CODE (tmp) == ADDR_EXPR)