From 619395467573f4cc869e441d99b112f5c1df9bbe Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Thu, 28 May 2020 16:16:06 -0400 Subject: [PATCH] [Ada] Ada2020: AI12-0368 Declare expressions can be static gcc/ada/ * sem_res.adb (Resolve_Expression_With_Actions): Check the rules of AI12-0368, and mark the declare expression as static or known at compile time as appropriate. * sem_ch4.adb: Minor reformatting. * libgnat/a-stoufo.ads, libgnat/a-stoufo.adb: Allow up to 9 replacement parameters. I'm planning to use this in the test case for this ticket. --- gcc/ada/libgnat/a-stoufo.adb | 34 +++++++++--- gcc/ada/libgnat/a-stoufo.ads | 8 +-- gcc/ada/sem_ch4.adb | 2 - gcc/ada/sem_res.adb | 100 ++++++++++++++++++++++++++++++++--- 4 files changed, 122 insertions(+), 22 deletions(-) diff --git a/gcc/ada/libgnat/a-stoufo.adb b/gcc/ada/libgnat/a-stoufo.adb index 3b99cf7d03b..58d7f5a4be1 100644 --- a/gcc/ada/libgnat/a-stoufo.adb +++ b/gcc/ada/libgnat/a-stoufo.adb @@ -38,10 +38,10 @@ package body Ada.Strings.Text_Output.Formatting is procedure Put (S : in out Sink'Class; T : Template; - X1, X2, X3, X4, X5, X6 : UTF_8_Lines := "") + X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "") is J : Positive := T'First; - Used : array (1 .. 6) of Boolean := (others => False); + Used : array (1 .. 9) of Boolean := (others => False); begin while J <= T'Last loop if T (J) = '\' then @@ -78,6 +78,15 @@ package body Ada.Strings.Text_Output.Formatting is when '6' => Used (6) := True; Put_UTF_8_Lines (S, X6); + when '7' => + Used (7) := True; + Put_UTF_8_Lines (S, X7); + when '8' => + Used (8) := True; + Put_UTF_8_Lines (S, X8); + when '9' => + Used (9) := True; + Put_UTF_8_Lines (S, X9); when others => raise Program_Error; @@ -107,32 +116,41 @@ package body Ada.Strings.Text_Output.Formatting is if not Used (6) then pragma Assert (X6 = ""); end if; + if not Used (7) then + pragma Assert (X7 = ""); + end if; + if not Used (8) then + pragma Assert (X8 = ""); + end if; + if not Used (9) then + pragma Assert (X9 = ""); + end if; Flush (S); end Put; procedure Put (T : Template; - X1, X2, X3, X4, X5, X6 : UTF_8_Lines := "") is + X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "") is begin - Put (Files.Standard_Output.all, T, X1, X2, X3, X4, X5, X6); + Put (Files.Standard_Output.all, T, X1, X2, X3, X4, X5, X6, X7, X8, X9); end Put; procedure Err (T : Template; - X1, X2, X3, X4, X5, X6 : UTF_8_Lines := "") is + X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "") is begin - Put (Files.Standard_Error.all, T, X1, X2, X3, X4, X5, X6); + Put (Files.Standard_Error.all, T, X1, X2, X3, X4, X5, X6, X7, X8, X9); end Err; function Format (T : Template; - X1, X2, X3, X4, X5, X6 : UTF_8_Lines := "") + X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "") return UTF_8_Lines is Buf : Buffer := New_Buffer; begin - Put (Buf, T, X1, X2, X3, X4, X5, X6); + Put (Buf, T, X1, X2, X3, X4, X5, X6, X7, X8, X9); return Get_UTF_8 (Buf); end Format; diff --git a/gcc/ada/libgnat/a-stoufo.ads b/gcc/ada/libgnat/a-stoufo.ads index dd80dff3160..a31ed2d4c12 100644 --- a/gcc/ada/libgnat/a-stoufo.ads +++ b/gcc/ada/libgnat/a-stoufo.ads @@ -43,7 +43,7 @@ package Ada.Strings.Text_Output.Formatting is type Template is new UTF_8; procedure Put (S : in out Sink'Class; T : Template; - X1, X2, X3, X4, X5, X6 : UTF_8_Lines := ""); + X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := ""); -- Prints the template as is, except for the following escape sequences: -- "\n" is end of line. -- "\i" indents by the default amount, and "\o" outdents. @@ -57,17 +57,17 @@ package Ada.Strings.Text_Output.Formatting is procedure Put (T : Template; - X1, X2, X3, X4, X5, X6 : UTF_8_Lines := ""); + X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := ""); -- Sends to standard output procedure Err (T : Template; - X1, X2, X3, X4, X5, X6 : UTF_8_Lines := ""); + X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := ""); -- Sends to standard error function Format (T : Template; - X1, X2, X3, X4, X5, X6 : UTF_8_Lines := "") + X1, X2, X3, X4, X5, X6, X7, X8, X9 : UTF_8_Lines := "") return UTF_8_Lines; -- Returns a UTF-8-encoded String diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 3559a15c152..517f5fc8bec 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -2217,8 +2217,6 @@ package body Sem_Ch4 is -- Analyze_Expression_With_Actions -- ------------------------------------- - -- Start of processing for Analyze_Quantified_Expression - procedure Analyze_Expression_With_Actions (N : Node_Id) is procedure Check_Action_OK (A : Node_Id); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b5cdbb7593b..bea7a57aaa5 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8818,18 +8818,102 @@ package body Sem_Res is ------------------------------------- procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id) is + + function OK_For_Static (Act : Node_Id) return Boolean; + -- True if Act is an action of a declare_expression that is allowed in a + -- static declare_expression. + + function All_OK_For_Static return Boolean; + -- True if all actions of N are allowed in a static declare_expression. + + function Get_Literal (Expr : Node_Id) return Node_Id; + -- Expr is an expression with compile-time-known value. This returns the + -- literal node that reprsents that value. + + function OK_For_Static (Act : Node_Id) return Boolean is + begin + case Nkind (Act) is + when N_Object_Declaration => + if Constant_Present (Act) + and then Is_Static_Expression (Expression (Act)) + then + return True; + end if; + + when N_Object_Renaming_Declaration => + if Statically_Names_Object (Name (Act)) then + return True; + end if; + + when others => + -- No other declarations, nor even pragmas, are allowed in a + -- declare expression, so if we see something else, it must be + -- an internally generated expression_with_actions. + null; + end case; + + return False; + end OK_For_Static; + + function All_OK_For_Static return Boolean is + Act : Node_Id := First (Actions (N)); + begin + while Present (Act) loop + if not OK_For_Static (Act) then + return False; + end if; + + Next (Act); + end loop; + + return True; + end All_OK_For_Static; + + function Get_Literal (Expr : Node_Id) return Node_Id is + pragma Assert (Compile_Time_Known_Value (Expr)); + Result : Node_Id; + begin + case Nkind (Expr) is + when N_Has_Entity => + if Ekind (Entity (Expr)) = E_Enumeration_Literal then + Result := Expr; + else + Result := Constant_Value (Entity (Expr)); + end if; + when N_Numeric_Or_String_Literal => + Result := Expr; + when others => + raise Program_Error; + end case; + + pragma Assert + (Nkind (Result) in N_Numeric_Or_String_Literal + or else Ekind (Entity (Result)) = E_Enumeration_Literal); + return Result; + end Get_Literal; + + Loc : constant Source_Ptr := Sloc (N); + begin Set_Etype (N, Typ); - -- If N has no actions, and its expression has been constant folded, - -- then rewrite N as just its expression. Note, we can't do this in - -- the general case of Is_Empty_List (Actions (N)) as this would cause - -- Expression (N) to be expanded again. + if Is_Empty_List (Actions (N)) then + pragma Assert (All_OK_For_Static); null; + end if; - if Is_Empty_List (Actions (N)) - and then Compile_Time_Known_Value (Expression (N)) - then - Rewrite (N, Expression (N)); + -- If the value of the expression is known at compile time, and all + -- of the actions (if any) are suitable, then replace the declare + -- expression with its expression. This allows the declare expression + -- as a whole to be static if appropriate. See AI12-0368. + + if Compile_Time_Known_Value (Expression (N)) then + if Is_Empty_List (Actions (N)) then + Rewrite (N, Expression (N)); + elsif All_OK_For_Static then + Rewrite + (N, New_Copy_Tree + (Get_Literal (Expression (N)), New_Sloc => Loc)); + end if; end if; end Resolve_Expression_With_Actions; -- 2.30.2