[gcc r12-5682] [Ada] Allow formal functions to have a default in the form of an expression function

[gcc r12-5682] [Ada] Allow formal functions to have a default in the form of an expression function

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:38e7e9ac1591ca3e7b3adc181a0786fd71739b40

commit r12-5682-g38e7e9ac1591ca3e7b3adc181a0786fd71739b40
Author: Gary Dismukes <dismukes@adacore.com>
Date:   Tue Nov 16 16:56:44 2021 -0500

    [Ada] Allow formal functions to have a default in the form of an expression function
    
    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:
---
 .../doc/gnat_rm/implementation_defined_pragmas.rst | 24 +++++++++
 gcc/ada/gen_il-gen-gen_nodes.adb                   |  2 +
 gcc/ada/gnat_rm.texi                               | 25 +++++++++
 gcc/ada/par-ch12.adb                               | 24 +++++++++
 gcc/ada/sem_ch12.adb                               | 61 +++++++++++++++++++++-
 5 files changed, 134 insertions(+), 2 deletions(-)

diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
index 768dd668e57..b0b99170709 100644
--- 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
index 712577325a0..9937919f8ac 100644
--- 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
index 547d5b9e208..9f92812a6f3 100644
--- 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
index eac3643bdc0..2604a17d129 100644
--- 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
index f10967a01fc..e0f72494faa 100644
--- 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;
 
    <<Leave>>
@@ -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