From patchwork Fri Oct 16 19:33:05 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 1383522 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=pass (p=none dis=none) header.from=gcc.gnu.org Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=rLT3zhTw; 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 4CCbss5WLdz9sSf for ; Sat, 17 Oct 2020 06:33:19 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 1FEC93861033; Fri, 16 Oct 2020 19:33:14 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 1FEC93861033 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1602876794; bh=thJ9p4DmC8PE2T1UWDceSl1TF9Kb37XYkTnxFDDL62k=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=rLT3zhTwkyqpMDsvNKtYbSSsB4Pevz8YmgrkAxrVSonHUcpe/H5kSTLJYKVEdAEec iNCrqe7fPTktLsL1QoOsltVVts26YZOWvVYZZWH0aKV/KbHxbJd9JydCeNYh99N2pr w37CZkpPAx3lHI9HW6vW8emhB6UAsOJVDwYxRfiY= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from cc-smtpout3.netcologne.de (cc-smtpout3.netcologne.de [IPv6:2001:4dd0:100:1062:25:2:0:3]) by sourceware.org (Postfix) with ESMTPS id 14E483857839; Fri, 16 Oct 2020 19:33:10 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 14E483857839 Received: from cc-smtpin1.netcologne.de (cc-smtpin1.netcologne.de [89.1.8.201]) by cc-smtpout3.netcologne.de (Postfix) with ESMTP id A560412BF3; Fri, 16 Oct 2020 21:33:07 +0200 (CEST) Received: from localhost (localhost [127.0.0.1]) by cc-smtpin1.netcologne.de (Postfix) with ESMTP id 976C711D92; Fri, 16 Oct 2020 21:33:07 +0200 (CEST) Received: from [2001:4dd7:e271:0:48c0:9b2a:c350:887c] (helo=cc-smtpin1.netcologne.de) by localhost with ESMTP (eXpurgate 4.11.6) (envelope-from ) id 5f89f573-02f5-7f0000012729-7f000001a432-1 for ; Fri, 16 Oct 2020 21:33:07 +0200 Received: from linux-p51k.fritz.box (2001-4dd7-e271-0-48c0-9b2a-c350-887c.ipv6dyn.netcologne.de [IPv6:2001:4dd7:e271:0:48c0:9b2a:c350:887c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (2048 bits) server-digest SHA256) (No client certificate requested) by cc-smtpin1.netcologne.de (Postfix) with ESMTPSA; Fri, 16 Oct 2020 21:33:06 +0200 (CEST) To: "fortran@gcc.gnu.org" , gcc-patches Subject: [patch, fortran] Partial fix for PR97454, declarations of some library functions Message-ID: <8996d806-0694-5563-af5f-2f0a9978ab34@netcologne.de> Date: Fri, 16 Oct 2020 21:33:05 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.12.0 MIME-Version: 1.0 Content-Language: de-DE X-Spam-Status: No, score=-9.5 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_STOCKGEN, RCVD_IN_DNSWL_LOW, 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: , X-Patchwork-Original-From: Thomas Koenig via Gcc-patches From: Thomas Koenig Reply-To: Thomas Koenig Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" Hello world, here's a patch which corrects some wrong declarations (and fixes the segfault for FINDLOC on Darwin ARM). Regression-tested. OK for trunk? Best regards Thomas Correct decls for functions which do not pass actual arguments. A wrong decl for findloc caused segfaults at runtime on Darwin for ARM; however, this is only a symptom of a larger disease: The declarations for our library functions are often inconsistent. This patch solves that problem for the functions specifically for the functions for which we do not pass optional arguments, i.e. findloc and (min|max)loc. It works by saving the symbols of the specific functions in gfc_intrinsic_namespace and by generating the formal argument lists from the actual argument lists. Because symbols are re-used, so are the backend decls. gcc/fortran/ChangeLog: PR fortran/97454 * gfortran.h (gfc_symbol): Add pass_as_value flag. (gfc_copy_formal_args_intr): Add optional argument copy_type. (gfc_get_intrinsic_function_symbol): Add prototype. (gfc_find_intrinsic_symbol): Add prototype. * intrinsic.c (gfc_get_intrinsic_function_symbol): New function. (gfc_find_intrinsic_symbol): New function. * symbol.c (gfc_copy_formal_args_intr): Add argument. Handle case where the type needs to be copied from the actual argument. * trans-intrinsic.c (remove_empty_actual_arguments): New function. (specific_intrinsic_symbol): New function. (gfc_conv_intrinsic_funcall): Use it. (strip_kind_from_actual): Adjust so that the expression pointer is set to NULL. (gfc_conv_intrinsic_minmaxloc): Likewise. (gfc_conv_intrinsic_minmaxval): Adjust removal of dim. * trans-types.c (gfc_sym_type): If sym->pass_as_value is set, do not pass by reference. diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index d0cea838444..37fed61a679 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1664,6 +1664,9 @@ typedef struct gfc_symbol /* Set if the dummy argument of a procedure could be an array despite being called with a scalar actual argument. */ unsigned maybe_array:1; + /* Set if this should be passed by value, but is not a VALUE argument + according to the Fortran standard. */ + unsigned pass_as_value:1; int refs; struct gfc_namespace *ns; /* namespace containing this symbol */ @@ -3239,7 +3242,7 @@ bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *); bool gfc_type_compatible (gfc_typespec *, gfc_typespec *); void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *, - gfc_actual_arglist *); + gfc_actual_arglist *, bool copy_type = false); void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */ @@ -3264,6 +3267,8 @@ void gfc_intrinsic_done_1 (void); char gfc_type_letter (bt, bool logical_equals_int = false); gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *); +gfc_symbol *gfc_get_intrinsic_function_symbol (gfc_expr *); +gfc_symbol *gfc_find_intrinsic_symbol (gfc_expr *); bool gfc_convert_type (gfc_expr *, gfc_typespec *, int); bool gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int, bool array = false); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index ef33587a774..938a2f3606b 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -122,6 +122,43 @@ gfc_get_intrinsic_sub_symbol (const char *name) return sym; } +/* Get a symbol for a resolved function, with its special name. The + actual argument list needs to be set by the caller. */ + +gfc_symbol * +gfc_get_intrinsic_function_symbol (gfc_expr *expr) +{ + gfc_symbol *sym; + + gfc_get_symbol (expr->value.function.name, gfc_intrinsic_namespace, &sym); + sym->attr.external = 1; + sym->attr.function = 1; + sym->attr.always_explicit = 1; + sym->attr.proc = PROC_INTRINSIC; + sym->attr.flavor = FL_PROCEDURE; + sym->result = sym; + if (expr->rank > 0) + { + sym->attr.dimension = 1; + sym->as = gfc_get_array_spec (); + sym->as->type = AS_ASSUMED_SHAPE; + sym->as->rank = expr->rank; + } + return sym; +} + +/* Find a symbol for a resolved intrinsic procedure, return NULL if + not found. */ + +gfc_symbol * +gfc_find_intrinsic_symbol (gfc_expr *expr) +{ + gfc_symbol *sym; + gfc_find_symbol (expr->value.function.name, gfc_intrinsic_namespace, + 0, &sym); + return sym; +} + /* Return a pointer to the name of a conversion function given two typespecs. */ diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index df1e8965daa..a112c813124 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4645,12 +4645,13 @@ add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal) declaration statement (see match_proc_decl()) to create the formal args based on the args of a given named interface. - When an actual argument list is provided, skip the absent arguments. + When an actual argument list is provided, skip the absent arguments + unless copy_type is true. To be used together with gfc_se->ignore_optional. */ void gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src, - gfc_actual_arglist *actual) + gfc_actual_arglist *actual, bool copy_type) { gfc_formal_arglist *head = NULL; gfc_formal_arglist *tail = NULL; @@ -4677,13 +4678,27 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src, act_arg = act_arg->next; continue; } - act_arg = act_arg->next; } formal_arg = gfc_get_formal_arglist (); gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym)); /* May need to copy more info for the symbol. */ - formal_arg->sym->ts = curr_arg->ts; + if (copy_type && act_arg->expr != NULL) + { + formal_arg->sym->ts = act_arg->expr->ts; + if (act_arg->expr->rank > 0) + { + formal_arg->sym->attr.dimension = 1; + formal_arg->sym->as = gfc_get_array_spec(); + formal_arg->sym->as->rank = -1; + formal_arg->sym->as->type = AS_ASSUMED_RANK; + } + if (act_arg->name && strcmp (act_arg->name, "%VAL") == 0) + formal_arg->sym->pass_as_value = 1; + } + else + formal_arg->sym->ts = curr_arg->ts; + formal_arg->sym->attr.optional = curr_arg->optional; formal_arg->sym->attr.value = curr_arg->value; formal_arg->sym->attr.intent = curr_arg->intent; @@ -4708,6 +4723,8 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src, /* Validate changes. */ gfc_commit_symbol (formal_arg->sym); + if (actual) + act_arg = act_arg->next; } /* Add the interface to the symbol. */ diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 8729bc12152..e0afc10d105 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -4238,12 +4238,60 @@ gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional) return sym; } +/* Remove empty actual arguments. */ + +static void +remove_empty_actual_arguments (gfc_actual_arglist **ap) +{ + while (*ap) + { + if ((*ap)->expr == NULL) + { + gfc_actual_arglist *r = *ap; + *ap = r->next; + r->next = NULL; + gfc_free_actual_arglist (r); + } + else + ap = &((*ap)->next); + } +} + +/* Generate the right symbol for the specific intrinsic function and + modify the expr accordingly. This assumes that absent optional + arguments should be removed. FIXME: This should be extended for + procedures which do not ignore optional arguments (PR 97454). */ + +gfc_symbol * +specific_intrinsic_symbol (gfc_expr *expr) +{ + gfc_symbol *sym; + + sym = gfc_find_intrinsic_symbol (expr); + if (sym == NULL) + { + sym = gfc_get_intrinsic_function_symbol (expr); + sym->ts = expr->ts; + if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl) + sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); + + gfc_copy_formal_args_intr (sym, expr->value.function.isym, + expr->value.function.actual, true); + sym->backend_decl + = gfc_get_extern_function_decl (sym, expr->value.function.actual); + } + remove_empty_actual_arguments (&(expr->value.function.actual)); + + return sym; +} + /* Generate a call to an external intrinsic function. */ static void gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) { gfc_symbol *sym; vec *append_args; + bool specific_symbol; gcc_assert (!se->ss || se->ss->info->expr == expr); @@ -4252,7 +4300,28 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) else gcc_assert (expr->rank == 0); - sym = gfc_get_symbol_for_expr (expr, se->ignore_optional); + switch (expr->value.function.isym->id) + { + case GFC_ISYM_FINDLOC: + case GFC_ISYM_MAXLOC: + case GFC_ISYM_MINLOC: + case GFC_ISYM_MAXVAL: + case GFC_ISYM_MINVAL: + specific_symbol = true; + break; + default: + specific_symbol = false; + } + + if (specific_symbol) + { + /* Need to copy here because specific_intrinsic_symbol modifies + expr to omit the absent optional arguments. */ + expr = gfc_copy_expr (expr); + sym = specific_intrinsic_symbol (expr); + } + else + sym = gfc_get_symbol_for_expr (expr, se->ignore_optional); /* Calls to libgfortran_matmul need to be appended special arguments, to be able to call the BLAS ?gemm functions if required and possible. */ @@ -4302,7 +4371,11 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, append_args); - gfc_free_symbol (sym); + + if (specific_symbol) + gfc_free_expr (expr); + else + gfc_free_symbol (sym); } /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR. @@ -5081,12 +5154,10 @@ strip_kind_from_actual (gfc_actual_arglist * actual) { for (gfc_actual_arglist *a = actual; a; a = a->next) { - gfc_actual_arglist *b = a->next; - if (b && b->name && strcmp (b->name, "kind") == 0) + if (a && a->name && strcmp (a->name, "kind") == 0) { - a->next = b->next; - b->next = NULL; - gfc_free_actual_arglist (b); + gfc_free_expr (a->expr); + a->expr = NULL; } } } @@ -5224,20 +5295,17 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (arrayexpr->ts.type == BT_CHARACTER) { - gfc_actual_arglist *a, *b; + gfc_actual_arglist *a; a = actual; strip_kind_from_actual (a); - while (a->next) + while (a) { - b = a->next; - if (b->expr == NULL || strcmp (b->name, "dim") == 0) + if (a->name && strcmp (a->name, "dim") == 0) { - a->next = b->next; - b->next = NULL; - gfc_free_actual_arglist (b); + gfc_free_expr (a->expr); + a->expr = NULL; } - else - a = b; + a = a->next; } gfc_conv_intrinsic_funcall (se, expr); return; @@ -5996,29 +6064,16 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) if (arrayexpr->ts.type == BT_CHARACTER) { - gfc_actual_arglist *a2, *a3; - a2 = actual->next; /* dim */ - a3 = a2->next; /* mask */ - if (a2->expr == NULL || expr->rank == 0) + gfc_actual_arglist *dim = actual->next; + if (expr->rank == 0 && dim->expr != 0) { - if (a3->expr == NULL) - actual->next = NULL; - else - { - actual->next = a3; - a2->next = NULL; - } - gfc_free_actual_arglist (a2); + gfc_free_expr (dim->expr); + dim->expr = NULL; } - else - if (a3->expr == NULL) - { - a2->next = NULL; - gfc_free_actual_arglist (a3); - } gfc_conv_intrinsic_funcall (se, expr); return; } + type = gfc_typenode_for_spec (&expr->ts); /* Initialize the result. */ limit = gfc_create_var (type, "limit"); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 17f3ccc1d4e..b15ea667411 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2246,7 +2246,8 @@ gfc_sym_type (gfc_symbol * sym) else type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension); - if (sym->attr.dummy && !sym->attr.function && !sym->attr.value) + if (sym->attr.dummy && !sym->attr.function && !sym->attr.value + && !sym->pass_as_value) byref = 1; else byref = 0;