From patchwork Wed Dec 1 10:26:03 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 48345 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 D7943385843F for ; Wed, 1 Dec 2021 10:48:56 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org D7943385843F DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1638355736; bh=/e2AdeZzok+FqW2B3rJal8oWNSE1h/ujEt4ytGlWSjo=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=V7p6+hoOsIOQfaElWNUNqpYmEwPvFlz8Hw7nyW162bAjpFHZNjJIIzcoY7YBBlHyx vn8WR0vBaffjkAgr+BhMUBLgzr5zcvJfzWnegxxRnhTGiqL6FGKJTWzVfPUOIrDw5a 6n5d97ppQ1jP9N0e+PVy7sDMUDTciHclLgiUyBSQ= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x434.google.com (mail-wr1-x434.google.com [IPv6:2a00:1450:4864:20::434]) by sourceware.org (Postfix) with ESMTPS id E2825385800E for ; Wed, 1 Dec 2021 10:26:05 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org E2825385800E Received: by mail-wr1-x434.google.com with SMTP id l16so51044089wrp.11 for ; Wed, 01 Dec 2021 02:26:05 -0800 (PST) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition:content-transfer-encoding; bh=/e2AdeZzok+FqW2B3rJal8oWNSE1h/ujEt4ytGlWSjo=; b=6W/7JGz7rYadaJ6RArO63+DwTlCsup4pni509L5FSahaytKH/YU4JiKfIodsq0jz6D fVfcD9ugq56pGeW+bQinlsfnr/tqv5lOpR7idqZCyVag8U1AhMVQzojs3KQ821EModp9 Tg+BLrjbDDdJEYoGU9bPynvzcku4HFzJ9CcSpnTMpu5t/u1BrJ2wpIGAdL7Fa3jJgfCa loQWZ+p/yy13CEEUtUGbi/k4Cu/HDuYzgNV99753TpB82LOgp+czWUh71/Cq7mZ+SOux mwxt54nvZVyV/6TB9b/tLDqnbSPtI4nu+p+12b25aASbJRL7PkO5wHcZPN4i3XWqPQck E4zg== X-Gm-Message-State: AOAM533SjpYapFP85C2I7WTBHSWusiEScuPLDKTXjrJuwoAL5FWJ6GGM d0s6ItLNVcl365piYbKD4rzdlw8MlriPngkl X-Google-Smtp-Source: ABdhPJza90qOn1y2ICfkC5rHqg6FM5fysjwY64DcozhcreW+V5OPcKwYtChiTDCCVqC0j+iVON8nSA== X-Received: by 2002:a5d:6d06:: with SMTP id e6mr5587578wrq.330.1638354364946; Wed, 01 Dec 2021 02:26:04 -0800 (PST) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id e24sm14997499wra.78.2021.12.01.02.26.03 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 01 Dec 2021 02:26:04 -0800 (PST) Date: Wed, 1 Dec 2021 10:26:03 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Allow formal functions to have a default in the form of an expression function Message-ID: <20211201102603.GA1635710@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-13.1 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, WEIRD_QUOTING autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) 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: Pierre-Marie de Rodat via Gcc-patches From: Pierre-Marie de Rodat Reply-To: Pierre-Marie de Rodat Cc: Gary Dismukes Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" As a language extension, the declaration of a generic formal function is allowed to have a default given by an expression in parentheses, where the expression is of the function's result type and can refer to formal parameters of the function (in direct analogy with expression functions). For example: generic type T is private; with function Copy (Item : T) return T is (Item); -- Defaults to Item package Stacks is type Stack is limited private; procedure Push (S : in out Stack; X : T); -- Calls Copy on X function Pop (S : in out Stack) return T; -- Calls Copy to return item private ... end Stacks; Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * doc/gnat_rm/implementation_defined_pragmas.rst: Add documentation of the new form of formal subprogram default in the section on language extensions (pragma Extensions_Allowed). * gnat_rm.texi: Regenerate. * gen_il-gen-gen_nodes.adb: Add Expression as a syntactic field of N_Formal_(Abstract|Concrete)_Subprogram_Declaration nodes. * par-ch12.adb (P_Formal_Subprogram_Declaration): Add parsing support for the new default of a parenthesized expression for formal functions. Issue an error when extensions are not allowed, suggesting use of -gnatX. Update comment with extended syntax for SUBPROGRAM_DEFAULT. * sem_ch12.adb (Analyze_Formal_Subprogram_Declaration): Issue an error when an expression default is given for an abstract formal function. When a default expression is present for a formal function, install the function's formals and preanalyze the expression. (Instantiate_Formal_Subprogram): Fix typo in RM paragraph in a comment. When a formal function has a default expression, create a body for the function that will evaluate the expression and will be called when the default applies in an instantiation. The implicit function is marked as inlined and as having convention Intrinsic. diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -2401,6 +2401,30 @@ of GNAT specific extensions are recognized as follows: name, preference is given to the component in a selected_component (as is currently the case for tagged types with such component names). +* Expression defaults for generic formal functions + + The declaration of a generic formal function is allowed to specify + an expression as a default, using the syntax of an expression function. + + Here is an example of this feature: + + .. code-block:: ada + + generic + type T is private; + with function Copy (Item : T) return T is (Item); -- Defaults to Item + package Stacks is + + type Stack is limited private; + + procedure Push (S : in out Stack; X : T); -- Calls Copy on X + + function Pop (S : in out Stack) return T; -- Calls Copy to return item + + private + -- ... + end Stacks; + .. _Pragma-Extensions_Visible: Pragma Extensions_Visible diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -1136,11 +1136,13 @@ begin -- Gen_IL.Gen.Gen_Nodes Cc (N_Formal_Abstract_Subprogram_Declaration, N_Formal_Subprogram_Declaration, (Sy (Specification, Node_Id), Sy (Default_Name, Node_Id, Default_Empty), + Sy (Expression, Node_Id, Default_Empty), Sy (Box_Present, Flag))); Cc (N_Formal_Concrete_Subprogram_Declaration, N_Formal_Subprogram_Declaration, (Sy (Specification, Node_Id), Sy (Default_Name, Node_Id, Default_Empty), + Sy (Expression, Node_Id, Default_Empty), Sy (Box_Present, Flag))); Ab (N_Push_Pop_xxx_Label, Node_Kind); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -3853,6 +3853,31 @@ simple name as one of the type’s primitive subprograms, where the component is visible at the point of a selected_component using that name, preference is given to the component in a selected_component (as is currently the case for tagged types with such component names). + +@item +Expression defaults for generic formal functions + +The declaration of a generic formal function is allowed to specify +an expression as a default, using the syntax of an expression function. + +Here is an example of this feature: + +@example +generic + type T is private; + with function Copy (Item : T) return T is (Item); -- Defaults to Item +package Stacks is + + type Stack is limited private; + + procedure Push (S : in out Stack; X : T); -- Calls Copy on X + + function Pop (S : in out Stack) return T; -- Calls Copy to return item + +private + -- ... +end Stacks; +@end example @end itemize @node Pragma Extensions_Visible,Pragma External,Pragma Extensions_Allowed,Implementation Defined Pragmas diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -1165,6 +1165,7 @@ package body Ch12 is -- [ASPECT_SPECIFICATIONS]; -- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <> + -- | ( EXPRESSION ) -- Allowed as extension (-gnatX) -- DEFAULT_NAME ::= NAME | null @@ -1219,6 +1220,29 @@ package body Ch12 is Scan; -- past NULL + -- When extensions are enabled, a formal function can have a default + -- given by a parenthesized expression (expression function syntax). + + elsif Token = Tok_Left_Paren then + Error_Msg_GNAT_Extension + ("expression default for formal subprograms"); + + if Nkind (Spec_Node) = N_Function_Specification then + Scan; -- past "(" + + Set_Expression (Def_Node, P_Expression); + + if Token /= Tok_Right_Paren then + Error_Msg_SC ("missing "")"" at end of expression default"); + else + Scan; -- past ")" + end if; + + else + Error_Msg_SP + ("only functions can specify a default expression"); + end if; + else Set_Default_Name (Def_Node, P_Name); end if; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3278,6 +3278,7 @@ package body Sem_Ch12 is procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is Spec : constant Node_Id := Specification (N); Def : constant Node_Id := Default_Name (N); + Expr : constant Node_Id := Expression (N); Nam : constant Entity_Id := Defining_Unit_Name (Spec); Subp : Entity_Id; @@ -3310,6 +3311,18 @@ package body Sem_Ch12 is ("a formal abstract subprogram cannot default to null", Spec); end if; + -- A formal abstract function cannot have an expression default + -- (expression defaults are allowed for nonabstract formal functions + -- when extensions are enabled). + + if Nkind (Spec) = N_Function_Specification + and then Present (Expr) + then + Error_Msg_N + ("a formal abstract subprogram cannot default to an expression", + Spec); + end if; + declare Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam); begin @@ -3336,7 +3349,7 @@ package body Sem_Ch12 is if Box_Present (N) then null; - -- Else default is bound at the point of generic declaration + -- Default name is bound at the point of generic declaration elsif Present (Def) then if Nkind (Def) = N_Operator_Symbol then @@ -3461,6 +3474,16 @@ package body Sem_Ch12 is Error_Msg_N ("no visible subprogram matches specification", N); end if; end if; + + -- When extensions are enabled, an expression can be given as default + -- for a formal function. The expression must be of the function result + -- type and can reference formal parameters of the function. + + elsif Present (Expr) then + Push_Scope (Nam); + Install_Formals (Nam); + Preanalyze_Spec_Expression (Expr, Etype (Nam)); + End_Scope; end if; <> @@ -11101,7 +11124,7 @@ package body Sem_Ch12 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Make_Null_Statement (Loc)))); - -- RM 12.6 (16 2/2): The procedure has convention Intrinsic + -- RM 12.6 (16.2/2): The procedure has convention Intrinsic Set_Convention (Defining_Unit_Name (New_Spec), Convention_Intrinsic); @@ -11110,6 +11133,40 @@ package body Sem_Ch12 is Set_Is_Inlined (Defining_Unit_Name (New_Spec)); return Decl_Node; + -- Handle case of a formal function with an expression default (allowed + -- when extensions are enabled). + + elsif Nkind (Specification (Formal)) = N_Function_Specification + and then Present (Expression (Formal)) + then + -- Generate body for function, for use in the instance + + declare + Expr : constant Node_Id := New_Copy (Expression (Formal)); + Stmt : constant Node_Id := Make_Simple_Return_Statement (Loc); + begin + Set_Sloc (Expr, Loc); + Set_Expression (Stmt, Expr); + + Decl_Node := + Make_Subprogram_Body (Loc, + Specification => New_Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Stmt))); + end; + + -- RM 12.6 (16.2/2): Like a null procedure default, the function + -- has convention Intrinsic. + + Set_Convention (Defining_Unit_Name (New_Spec), Convention_Intrinsic); + + -- Inline calls to it when optimization is enabled + + Set_Is_Inlined (Defining_Unit_Name (New_Spec)); + return Decl_Node; + else Error_Msg_Sloc := Sloc (Scope (Analyzed_S)); Error_Msg_NE