From 8cd5951d68b98425beec4a632abcdc3c559074a4 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 27 May 2020 06:10:35 -0400 Subject: [PATCH] [Ada] Extend static functions gcc/ada/ * inline.adb, inline.ads (Inline_Static_Expression_Function_Call): Renamed Inline_Static_Function_Call. * sem_ch13.adb (Analyze_Aspect_Static): Allow static intrinsic imported functions under -gnatX. * sem_util.ads, sem_util.adb (Is_Static_Expression_Function): Renamed Is_Static_Function. (Is_Static_Expression_Function_Call): Renamed Is_Static_Function_Call. * sem_ch6.adb, sem_elab.adb, sem_res.adb: Update calls to Is_Static_Function*. * sem_eval.adb (Fold_Dummy, Eval_Intrinsic_Call, Fold_Shift): New. (Eval_Call): Add support for intrinsic calls, code refactoring. (Eval_Entity_Name): Code refactoring. (Eval_Logical_Op): Update comment. (Eval_Shift): Call Fold_Shift. Update comments. * par-prag.adb (Par [Pragma_Extensions_Allowed]): Set Ada_Version to Ada_Version_Type'Last to handle Extensions_Allowed (On) consistently. * opt.ads (Extensions_Allowed): Update documentation. * sem_attr.adb: Update comment. * doc/gnat_rm/implementation_defined_pragmas.rst: Update documentation of Extensions_Allowed. * gnat_rm.texi: Regenerate. --- .../implementation_defined_pragmas.rst | 22 +- gcc/ada/gnat_rm.texi | 28 +- gcc/ada/inline.adb | 16 +- gcc/ada/inline.ads | 8 +- gcc/ada/opt.ads | 2 +- gcc/ada/par-prag.adb | 2 +- gcc/ada/sem_attr.adb | 2 +- gcc/ada/sem_ch13.adb | 66 ++++- gcc/ada/sem_ch6.adb | 2 +- gcc/ada/sem_elab.adb | 2 +- gcc/ada/sem_eval.adb | 270 ++++++++++++++---- gcc/ada/sem_res.adb | 17 +- gcc/ada/sem_util.adb | 43 +-- gcc/ada/sem_util.ads | 12 +- 14 files changed, 362 insertions(+), 130 deletions(-) diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 2f60db506bf..737bc60230a 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -2193,16 +2193,32 @@ extension mode (the use of Off as a parameter cancels the effect of the *-gnatX* command switch). In extension mode, the latest version of the Ada language is -implemented (currently Ada 2012), and in addition a small number +implemented (currently Ada 202x), and in addition a small number of GNAT specific extensions are recognized as follows: +* Constrained attribute for generic objects - -*Constrained attribute for generic objects* The ``Constrained`` attribute is permitted for objects of generic types. The result indicates if the corresponding actual is constrained. +* ``Static`` aspect on intrinsic functions + + The Ada 202x ``Static`` aspect can be specified on Intrinsic imported + functions and the compiler will evaluate some of these intrinsic statically, + in particular the ``Shift_Left`` and ``Shift_Right`` intrinsics. + +* ``'Reduce`` attribute + + This attribute part of the Ada 202x language definition is provided for + now under -gnatX to confirm and potentially refine its usage and syntax. + +* ``[]`` aggregates + + This new aggregate syntax for arrays and containers is provided under -gnatX + to experiment and confirm this new language syntax. + + .. _Pragma-Extensions_Visible: Pragma Extensions_Visible diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 5f36a4792a8..882f9e22b6d 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -3610,18 +3610,38 @@ extension mode (the use of Off as a parameter cancels the effect of the @emph{-gnatX} command switch). In extension mode, the latest version of the Ada language is -implemented (currently Ada 2012), and in addition a small number +implemented (currently Ada 202x), and in addition a small number of GNAT specific extensions are recognized as follows: -@table @asis +@itemize * -@item @emph{Constrained attribute for generic objects} +@item +Constrained attribute for generic objects The @code{Constrained} attribute is permitted for objects of generic types. The result indicates if the corresponding actual is constrained. -@end table + +@item +@code{Static} aspect on intrinsic functions + +The Ada 202x @code{Static} aspect can be specified on Intrinsic imported +functions and the compiler will evaluate some of these intrinsic statically, +in particular the @code{Shift_Left} and @code{Shift_Right} intrinsics. + +@item +@code{'Reduce} attribute + +This attribute part of the Ada 202x language definition is provided for +now under -gnatX to confirm and potentially refine its usage and syntax. + +@item +@code{[]} aggregates + +This new aggregate syntax for arrays and containers is provided under -gnatX +to experiment and confirm this new language syntax. +@end itemize @node Pragma Extensions_Visible,Pragma External,Pragma Extensions_Allowed,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas id12}@anchor{66}@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-visible}@anchor{67} diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 53ca6853673..b08634e78e0 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -4632,13 +4632,11 @@ package body Inline is Backend_Not_Inlined_Subps := No_Elist; end Initialize; - -------------------------------------------- - -- Inline_Static_Expression_Function_Call -- - -------------------------------------------- + --------------------------------- + -- Inline_Static_Function_Call -- + --------------------------------- - procedure Inline_Static_Expression_Function_Call - (N : Node_Id; Subp : Entity_Id) - is + procedure Inline_Static_Function_Call (N : Node_Id; Subp : Entity_Id) is function Replace_Formal (N : Node_Id) return Traverse_Result; -- Replace each occurrence of a formal with the corresponding actual, @@ -4697,10 +4695,10 @@ package body Inline is procedure Reset_Slocs is new Traverse_Proc (Reset_Sloc); - -- Start of processing for Inline_Static_Expression_Function_Call + -- Start of processing for Inline_Static_Function_Call begin - pragma Assert (Is_Static_Expression_Function_Call (N)); + pragma Assert (Is_Static_Function_Call (N)); declare Decls : constant List_Id := New_List; @@ -4759,7 +4757,7 @@ package body Inline is Reset_Actual_Mapping_For_Inlined_Call (Subp); end; - end Inline_Static_Expression_Function_Call; + end Inline_Static_Function_Call; ------------------------ -- Instantiate_Bodies -- diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index a7f4aabfe59..51eab9c7318 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -227,11 +227,11 @@ package Inline is -- Check a list of statements, Stats, that make inlining of Subp not -- worthwhile, including any tasking statement, nested at any level. - procedure Inline_Static_Expression_Function_Call + procedure Inline_Static_Function_Call (N : Node_Id; Subp : Entity_Id); - -- Evaluate static call to a static expression function Subp, substituting - -- actuals in place of references to their corresponding formals and - -- rewriting the call N as a fully folded and static result expression. + -- Evaluate static call to a static function Subp, substituting actuals in + -- place of references to their corresponding formals and rewriting the + -- call N as a fully folded and static result expression. procedure List_Inlining_Info; -- Generate listing of calls inlined by the frontend plus listing of diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 37f3d030e3f..78b2b50e033 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -620,7 +620,7 @@ package Opt is Extensions_Allowed : Boolean := False; -- GNAT -- Set to True by switch -gnatX if GNAT specific language extensions - -- are allowed. Currently there are no such defined extensions. + -- are allowed. See GNAT RM for details. type External_Casing_Type is ( As_Is, -- External names cased as they appear in the Ada source diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 0e5a32b6273..1f25ec8fbf0 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -435,7 +435,7 @@ begin if Chars (Expression (Arg1)) = Name_On then Extensions_Allowed := True; - Ada_Version := Ada_2012; + Ada_Version := Ada_Version_Type'Last; else Extensions_Allowed := False; Ada_Version := Ada_Version_Explicit; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 1d4ef0bfb7a..80e8f099e37 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -3540,7 +3540,7 @@ package body Sem_Attr is return; -- Also allow an object of a generic type if extensions allowed - -- and allow this for any type at all. (this may be obsolete ???) + -- and allow this for any type at all. elsif (Is_Generic_Type (P_Type) or else Is_Generic_Actual_Type (P_Type)) diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 4bdd2cf8bd3..5c3cc48f08d 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2405,6 +2405,35 @@ package body Sem_Ch13 is --------------------------- procedure Analyze_Aspect_Static is + function Has_Convention_Intrinsic (L : List_Id) return Boolean; + -- Return True if L contains a pragma argument association + -- node representing a convention Intrinsic. + + ------------------------------ + -- Has_Convention_Intrinsic -- + ------------------------------ + + function Has_Convention_Intrinsic + (L : List_Id) return Boolean + is + Arg : Node_Id := First (L); + begin + while Present (Arg) loop + if Nkind (Arg) = N_Pragma_Argument_Association + and then Chars (Arg) = Name_Convention + and then Chars (Expression (Arg)) = Name_Intrinsic + then + return True; + end if; + + Next (Arg); + end loop; + + return False; + end Has_Convention_Intrinsic; + + Is_Imported_Intrinsic : Boolean; + begin if Ada_Version < Ada_2020 then Error_Msg_N @@ -2412,21 +2441,44 @@ package body Sem_Ch13 is Error_Msg_N ("\compile with -gnat2020", Aspect); return; + end if; + + Is_Imported_Intrinsic := Is_Imported (E) + and then + Has_Convention_Intrinsic + (Pragma_Argument_Associations (Import_Pragma (E))); -- The aspect applies only to expression functions that -- statisfy the requirements for a static expression function - -- (such as having an expression that is predicate-static). + -- (such as having an expression that is predicate-static) as + -- well as Intrinsic imported functions as a -gnatX extension. - elsif not Is_Expression_Function (E) then - Error_Msg_N - ("aspect % requires expression function", Aspect); + if not Is_Expression_Function (E) + and then + not (Extensions_Allowed and then Is_Imported_Intrinsic) + then + if Extensions_Allowed then + Error_Msg_N + ("aspect % requires intrinsic or expression function", + Aspect); + + elsif Is_Imported_Intrinsic then + Error_Msg_N + ("aspect % on intrinsic function is an extension: " & + "use -gnatX", + Aspect); + + else + Error_Msg_N + ("aspect % requires expression function", Aspect); + end if; return; -- Ada 202x (AI12-0075): Check that the function satisfies - -- several requirements of static expression functions as - -- specified in RM 6.8(5.1-5.8). Note that some of the - -- requirements given there are checked elsewhere. + -- several requirements of static functions as specified in + -- RM 6.8(5.1-5.8). Note that some of the requirements given + -- there are checked elsewhere. else -- The expression of the expression function must be a diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index fb14cbd68cf..6651671e747 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -580,7 +580,7 @@ package body Sem_Ch6 is -- requirements of the Ada 202x RM in 4.9(3.2/5-3.4/5) and -- we flag an error. - if Is_Static_Expression_Function (Def_Id) then + if Is_Static_Function (Def_Id) then if not Is_Static_Expression (Expr) then declare Exp_Copy : constant Node_Id := New_Copy_Tree (Expr); diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index e17e927eec4..3cbc27fc507 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -3687,7 +3687,7 @@ package body Sem_Elab is -- Static expression functions require no ABE processing - elsif Is_Static_Expression_Function (Subp_Id) then + elsif Is_Static_Function (Subp_Id) then return; -- Source calls to source targets are always considered because they diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 57dbaba886d..6707aaa5ded 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -45,6 +45,7 @@ with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Elab; use Sem_Elab; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sem_Type; use Sem_Type; @@ -171,6 +172,9 @@ package body Sem_Eval is -- discrete, real, or string type and must be a compile-time-known value -- (it is an error to make the call if these conditions are not met). + procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id); + -- Evaluate a call N to an intrinsic subprogram E. + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id; -- Check whether an arithmetic operation with universal operands which is a -- rewritten function call with an explicit scope indication is ambiguous: @@ -179,6 +183,22 @@ package body Sem_Eval is -- (e.g. in the expression of a type conversion). If ambiguous, emit an -- error and return Empty, else return the result type of the operator. + procedure Fold_Dummy (N : Node_Id; Typ : Entity_Id); + -- Rewrite N as a constant dummy value in the relevant type if possible. + + procedure Fold_Shift + (N : Node_Id; + Left : Node_Id; + Right : Node_Id; + Op : Node_Kind; + Static : Boolean := False; + Check_Elab : Boolean := False); + -- Rewrite N as the result of evaluating Left Right if possible. + -- Op represents the shift operation. + -- Static indicates whether the resulting node should be marked static. + -- Check_Elab indicates whether checks for elaboration calls should be + -- inserted when relevant. + function From_Bits (B : Bits; T : Entity_Id) return Uint; -- Converts a bit string of length B'Length to a Uint value to be used for -- a target of type T, which is a modular type. This procedure includes the @@ -2217,9 +2237,8 @@ package body Sem_Eval is -- Only the latter case is handled here, predefined operators are -- constant-folded elsewhere. - -- If the function is itself inherited (see 7423-001) the literal of - -- the parent type must be explicitly converted to the return type - -- of the function. + -- If the function is itself inherited the literal of the parent type must + -- be explicitly converted to the return type of the function. procedure Eval_Call (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -2246,37 +2265,22 @@ package body Sem_Eval is Resolve (N, Typ); end if; + elsif Nkind (N) = N_Function_Call + and then Is_Entity_Name (Name (N)) + and then Is_Intrinsic_Subprogram (Entity (Name (N))) + then + Eval_Intrinsic_Call (N, Entity (Name (N))); + -- Ada 202x (AI12-0075): If checking for potentially static expressions - -- is enabled and we have a call to a static expression function, - -- substitute a static value for the call, to allow folding the - -- expression. This supports checking the requirement of RM 6.8(5.3/5) - -- in Analyze_Expression_Function. + -- is enabled and we have a call to a static function, substitute a + -- static value for the call, to allow folding the expression. This + -- supports checking the requirement of RM 6.8(5.3/5) in + -- Analyze_Expression_Function. elsif Checking_Potentially_Static_Expression - and then Is_Static_Expression_Function_Call (N) + and then Is_Static_Function_Call (N) then - if Is_Integer_Type (Typ) then - Fold_Uint (N, Uint_1, Static => True); - return; - - elsif Is_Real_Type (Typ) then - Fold_Ureal (N, Ureal_1, Static => True); - return; - - elsif Is_Enumeration_Type (Typ) then - Fold_Uint - (N, - Expr_Value (Type_Low_Bound (Base_Type (Typ))), - Static => True); - return; - - elsif Is_String_Type (Typ) then - Fold_Str - (N, - Strval (Make_String_Literal (Sloc (N), "")), - Static => True); - return; - end if; + Fold_Dummy (N, Typ); end if; end Eval_Call; @@ -2566,30 +2570,9 @@ package body Sem_Eval is elsif Ekind (Def_Id) = E_In_Parameter and then Checking_Potentially_Static_Expression - and then Is_Static_Expression_Function (Scope (Def_Id)) + and then Is_Static_Function (Scope (Def_Id)) then - if Is_Integer_Type (Etype (Def_Id)) then - Fold_Uint (N, Uint_1, Static => True); - return; - - elsif Is_Real_Type (Etype (Def_Id)) then - Fold_Ureal (N, Ureal_1, Static => True); - return; - - elsif Is_Enumeration_Type (Etype (Def_Id)) then - Fold_Uint - (N, - Expr_Value (Type_Low_Bound (Base_Type (Etype (Def_Id)))), - Static => True); - return; - - elsif Is_String_Type (Etype (Def_Id)) then - Fold_Str - (N, - Strval (Make_String_Literal (Sloc (N), "")), - Static => True); - return; - end if; + Fold_Dummy (N, Etype (Def_Id)); end if; -- Fall through if the name is not static @@ -2893,6 +2876,80 @@ package body Sem_Eval is end if; end Eval_Integer_Literal; + ------------------------- + -- Eval_Intrinsic_Call -- + ------------------------- + + procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id) is + + procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind); + -- Evaluate an intrinsic shift call N on the given subprogram E. + -- Op is the kind for the shift node. + + ---------------- + -- Eval_Shift -- + ---------------- + + procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind) is + Left : constant Node_Id := First_Actual (N); + Right : constant Node_Id := Next_Actual (Left); + Static : constant Boolean := Is_Static_Function (E); + + begin + if Static then + if Checking_Potentially_Static_Expression then + Fold_Dummy (N, Etype (N)); + return; + end if; + end if; + + Fold_Shift + (N, Left, Right, Op, Static => Static, Check_Elab => not Static); + end Eval_Shift; + + Nam : Name_Id; + + begin + -- Nothing to do if the intrinsic is handled by the back end. + + if Present (Interface_Name (E)) then + return; + end if; + + -- Intrinsic calls as part of a static function is a language extension. + + if Checking_Potentially_Static_Expression + and then not Extensions_Allowed + then + return; + end if; + + -- If we have a renaming, expand the call to the original operation, + -- which must itself be intrinsic, since renaming requires matching + -- conventions and this has already been checked. + + if Present (Alias (E)) then + Eval_Intrinsic_Call (N, Alias (E)); + return; + end if; + + -- If the intrinsic subprogram is generic, gets its original name + + if Present (Parent (E)) + and then Present (Generic_Parent (Parent (E))) + then + Nam := Chars (Generic_Parent (Parent (E))); + else + Nam := Chars (E); + end if; + + case Nam is + when Name_Shift_Left => Eval_Shift (N, E, N_Op_Shift_Left); + when Name_Shift_Right => Eval_Shift (N, E, N_Op_Shift_Right); + when others => null; + end case; + end Eval_Intrinsic_Call; + --------------------- -- Eval_Logical_Op -- --------------------- @@ -2932,7 +2989,9 @@ package body Sem_Eval is To_Bits (Right_Int, Right_Bits); -- Note: should really be able to use array ops instead of - -- these loops, but they weren't working at the time ??? + -- these loops, but they break the build with a cryptic error + -- during the bind of gnat1 likely due to a wrong computation + -- of a date or checksum. if Nkind (N) = N_Op_And then for J in Left_Bits'Range loop @@ -3761,16 +3820,13 @@ package body Sem_Eval is -- Eval_Shift -- ---------------- - -- Shift operations are intrinsic operations that can never be static, so - -- the only processing required is to perform the required check for a non - -- static context for the two operands. - - -- Actually we could do some compile time evaluation here some time ??? - procedure Eval_Shift (N : Node_Id) is begin - Check_Non_Static_Context (Left_Opnd (N)); - Check_Non_Static_Context (Right_Opnd (N)); + -- This procedure is only called for compiler generated code (e.g. + -- packed arrays), so there is nothing to do except attempting to fold + -- the expression. + + Fold_Shift (N, Left_Opnd (N), Right_Opnd (N), Nkind (N)); end Eval_Shift; ------------------------ @@ -4688,6 +4744,96 @@ package body Sem_Eval is end if; end Flag_Non_Static_Expr; + ---------------- + -- Fold_Dummy -- + ---------------- + + procedure Fold_Dummy (N : Node_Id; Typ : Entity_Id) is + begin + if Is_Integer_Type (Typ) then + Fold_Uint (N, Uint_1, Static => True); + + elsif Is_Real_Type (Typ) then + Fold_Ureal (N, Ureal_1, Static => True); + + elsif Is_Enumeration_Type (Typ) then + Fold_Uint + (N, + Expr_Value (Type_Low_Bound (Base_Type (Typ))), + Static => True); + + elsif Is_String_Type (Typ) then + Fold_Str + (N, + Strval (Make_String_Literal (Sloc (N), "")), + Static => True); + end if; + end Fold_Dummy; + + ---------------- + -- Fold_Shift -- + ---------------- + + procedure Fold_Shift + (N : Node_Id; + Left : Node_Id; + Right : Node_Id; + Op : Node_Kind; + Static : Boolean := False; + Check_Elab : Boolean := False) + is + Typ : constant Entity_Id := Etype (Left); + + procedure Check_Elab_Call; + -- Add checks related to calls in elaboration code + + --------------------- + -- Check_Elab_Call -- + --------------------- + + procedure Check_Elab_Call is + begin + if Check_Elab then + if Legacy_Elaboration_Checks then + Check_Elab_Call (N); + end if; + + Build_Call_Marker (N); + end if; + end Check_Elab_Call; + + begin + -- Evaluate logical shift operators on binary modular types + + if Is_Modular_Integer_Type (Typ) + and then not Non_Binary_Modulus (Typ) + and then Compile_Time_Known_Value (Left) + and then Compile_Time_Known_Value (Right) + then + if Op = N_Op_Shift_Left then + Check_Elab_Call; + + -- Fold Shift_Left (X, Y) by computing (X * 2**Y) rem modulus + + Fold_Uint + (N, + (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right))) + rem Modulus (Typ), + Static => Static); + + elsif Op = N_Op_Shift_Right then + Check_Elab_Call; + + -- Fold Shift_Right (X, Y) by computing X / 2**Y + + Fold_Uint + (N, + Expr_Value (Left) / (Uint_2 ** Expr_Value (Right)), + Static => Static); + end if; + end if; + end Fold_Shift; + -------------- -- Fold_Str -- -------------- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index bea7a57aaa5..dc11a0886c1 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3035,7 +3035,7 @@ package body Sem_Res is Resolution_Failed; return; - -- Only one intepretation + -- Only one interpretation else -- In Ada 2005, if we have something like "X : T := 2 + 2;", where @@ -6573,7 +6573,7 @@ package body Sem_Res is if Same_Or_Aliased_Subprograms (Nam, Scop) and then not Restriction_Active (No_Recursion) - and then not Is_Static_Expression_Function (Scop) + and then not Is_Static_Function (Scop) and then Check_Infinite_Recursion (N) then -- Here we detected and flagged an infinite recursion, so we do @@ -6591,11 +6591,10 @@ package body Sem_Res is Scope_Loop : while Scop /= Standard_Standard loop if Same_Or_Aliased_Subprograms (Nam, Scop) then - -- Ada 202x (AI12-0075): Static expression function are - -- never allowed to make a recursive call, as specified - -- by 6.8(5.4/5). + -- Ada 202x (AI12-0075): Static functions are never allowed + -- to make a recursive call, as specified by 6.8(5.4/5). - if Is_Static_Expression_Function (Scop) then + if Is_Static_Function (Scop) then Error_Msg_N ("recursive call not allowed in static expression " & "function", N); @@ -6758,7 +6757,7 @@ package body Sem_Res is or else Is_Build_In_Place_Function (Nam) or else Is_Intrinsic_Subprogram (Nam) or else Is_Inlinable_Expression_Function (Nam) - or else Is_Static_Expression_Function_Call (N) + or else Is_Static_Function_Call (N) then null; @@ -7032,10 +7031,10 @@ package body Sem_Res is -- when doing the inlining). if not Checking_Potentially_Static_Expression - and then Is_Static_Expression_Function_Call (N) + and then Is_Static_Function_Call (N) and then not Error_Posted (Ultimate_Alias (Nam)) then - Inline_Static_Expression_Function_Call (N, Ultimate_Alias (Nam)); + Inline_Static_Function_Call (N, Ultimate_Alias (Nam)); -- In GNATprove mode, expansion is disabled, but we want to inline some -- subprograms to facilitate formal verification. Indirect calls through diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 643eb216294..782337346bb 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -18729,30 +18729,31 @@ package body Sem_Util is or else Nkind (N) = N_Procedure_Call_Statement; end Is_Statement; - ------------------------------------ - -- Is_Static_Expression_Function -- - ------------------------------------ + ------------------------ + -- Is_Static_Function -- + ------------------------ - function Is_Static_Expression_Function (Subp : Entity_Id) return Boolean is + function Is_Static_Function (Subp : Entity_Id) return Boolean is begin - return Is_Expression_Function (Subp) - and then Has_Aspect (Subp, Aspect_Static) + return Has_Aspect (Subp, Aspect_Static) and then (No (Find_Value_Of_Aspect (Subp, Aspect_Static)) or else Is_True (Static_Boolean (Find_Value_Of_Aspect (Subp, Aspect_Static)))); - end Is_Static_Expression_Function; - - ----------------------------------------- - -- Is_Static_Expression_Function_Call -- - ----------------------------------------- + end Is_Static_Function; - function Is_Static_Expression_Function_Call (Call : Node_Id) return Boolean - is + ------------------------------ + -- Is_Static_Function_Call -- + ------------------------------ + function Is_Static_Function_Call (Call : Node_Id) return Boolean is function Has_All_Static_Actuals (Call : Node_Id) return Boolean; -- Return whether all actual parameters of Call are static expressions + ---------------------------- + -- Has_All_Static_Actuals -- + ---------------------------- + function Has_All_Static_Actuals (Call : Node_Id) return Boolean is Actual : Node_Id := First_Actual (Call); String_Result : constant Boolean := @@ -18765,12 +18766,12 @@ package body Sem_Util is -- ??? In the string-returning case we want to avoid a call -- being made to Establish_Transient_Scope in Resolve_Call, -- but at the point where that's tested for (which now includes - -- a call to test Is_Static_Expression_Function_Call), the - -- actuals of the call haven't been resolved, so expressions - -- of the actuals may not have been marked Is_Static_Expression - -- yet, so we force them to be resolved here, so we can tell if - -- they're static. Calling Resolve here is admittedly a kludge, - -- and we limit this call to string-returning cases. ??? + -- a call to test Is_Static_Function_Call), the actuals of the + -- call haven't been resolved, so expressions of the actuals + -- may not have been marked Is_Static_Expression yet, so we + -- force them to be resolved here, so we can tell if they're + -- static. Calling Resolve here is admittedly a kludge, and we + -- limit this call to string-returning cases. if String_Result then Resolve (Actual); @@ -18792,9 +18793,9 @@ package body Sem_Util is begin return Nkind (Call) = N_Function_Call and then Is_Entity_Name (Name (Call)) - and then Is_Static_Expression_Function (Entity (Name (Call))) + and then Is_Static_Function (Entity (Name (Call))) and then Has_All_Static_Actuals (Call); - end Is_Static_Expression_Function_Call; + end Is_Static_Function_Call; ---------------------------------------- -- Is_Subcomponent_Of_Atomic_Object -- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 017a42a45e0..cc28eedc565 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2081,13 +2081,13 @@ package Sem_Util is -- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo). -- Note that a label is *not* a statement, and will return False. - function Is_Static_Expression_Function (Subp : Entity_Id) return Boolean; - -- Determine whether subprogram Subp denotes a static expression function, - -- which is an expression function with the aspect Static with value True. + function Is_Static_Function (Subp : Entity_Id) return Boolean; + -- Determine whether subprogram Subp denotes a static function, + -- which is a function with the aspect Static with value True. - function Is_Static_Expression_Function_Call (Call : Node_Id) return Boolean; - -- Determine whether Call is a static call to a static expression function, - -- meaning that the name of the call denotes a static expression function + function Is_Static_Function_Call (Call : Node_Id) return Boolean; + -- Determine whether Call is a static call to a static function, + -- meaning that the name of the call denotes a static function -- and all of the call's actual parameters are given by static expressions. function Is_Subcomponent_Of_Atomic_Object (N : Node_Id) return Boolean; -- 2.30.2