diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/exp_ch2.adb | 117 | ||||
| -rw-r--r-- | gcc/ada/exp_ch2.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_put_image.adb | 43 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/expander.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/gen_il-gen-gen_nodes.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/gen_il-types.ads | 1 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stbubo.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-stbuun.adb | 68 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-sttebu.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-sttebu.ads | 16 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-putima.adb | 50 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-putima.ads | 16 | ||||
| -rw-r--r-- | gcc/ada/par-ch2.adb | 73 | ||||
| -rw-r--r-- | gcc/ada/par-ch4.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/par-tchk.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/par.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/scans.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/scng.adb | 136 | ||||
| -rw-r--r-- | gcc/ada/sem.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_ch2.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_ch2.ads | 11 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 42 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 27 | ||||
| -rw-r--r-- | gcc/ada/sprint.adb | 32 |
27 files changed, 689 insertions, 77 deletions
diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 8f97b43..f5cebb7 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -34,9 +35,11 @@ with Exp_Smem; use Exp_Smem; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Namet; use Namet; +with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; +with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; @@ -47,6 +50,7 @@ with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; with Sinput; use Sinput; with Snames; use Snames; +with Stand; with Tbuild; use Tbuild; package body Exp_Ch2 is @@ -711,4 +715,117 @@ package body Exp_Ch2 is Analyze_And_Resolve (N, T); end Expand_Renaming; + ------------------------------------------ + -- Expand_N_Interpolated_String_Literal -- + ------------------------------------------ + + procedure Expand_N_Interpolated_String_Literal (N : Node_Id) is + + function Build_Interpolated_String_Image (N : Node_Id) return Node_Id; + -- Build the following Expression_With_Actions node: + -- do + -- Sink : Buffer; + -- [ Set_Trim_Leading_Spaces (Sink); ] + -- Type'Put_Image (Sink, X); + -- { [ Set_Trim_Leading_Spaces (Sink); ] + -- Type'Put_Image (Sink, X); } + -- Result : constant String := Get (Sink); + -- Destroy (Sink); + -- in Result end + + ------------------------------------- + -- Build_Interpolated_String_Image -- + ------------------------------------- + + function Build_Interpolated_String_Image (N : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Sink_Entity : constant Entity_Id := Make_Temporary (Loc, 'S'); + Sink_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Sink_Entity, + Object_Definition => + New_Occurrence_Of (RTE (RE_Buffer_Type), Loc)); + + Get_Id : constant RE_Id := + (if Etype (N) = Stand.Standard_String then + RE_Get + elsif Etype (N) = Stand.Standard_Wide_String then + RE_Wide_Get + else + RE_Wide_Wide_Get); + + Result_Entity : constant Entity_Id := Make_Temporary (Loc, 'R'); + Result_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Entity, + Object_Definition => + New_Occurrence_Of (Etype (N), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Get_Id), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Sink_Entity, Loc)))); + + Actions : constant List_Id := New_List; + Elem_Typ : Entity_Id; + Str_Elem : Node_Id; + + begin + pragma Assert (Etype (N) /= Stand.Any_String); + + Append_To (Actions, Sink_Decl); + + Str_Elem := First (Expressions (N)); + while Present (Str_Elem) loop + Elem_Typ := Etype (Str_Elem); + + -- If the type is numeric or has a specified Integer_Literal or + -- Real_Literal aspect, then prior to invoking Put_Image, the + -- Trim_Leading_Spaces flag is set on the text buffer. + + if Is_Numeric_Type (Underlying_Type (Elem_Typ)) + or else Has_Aspect (Elem_Typ, Aspect_Integer_Literal) + or else Has_Aspect (Elem_Typ, Aspect_Real_Literal) + then + Append_To (Actions, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Set_Trim_Leading_Spaces), Loc), + Parameter_Associations => New_List ( + Convert_To (RTE (RE_Root_Buffer_Type), + New_Occurrence_Of (Sink_Entity, Loc)), + New_Occurrence_Of (Stand.Standard_True, Loc)))); + end if; + + Append_To (Actions, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Elem_Typ, Loc), + Attribute_Name => Name_Put_Image, + Expressions => New_List ( + New_Occurrence_Of (Sink_Entity, Loc), + Duplicate_Subexpr (Str_Elem)))); + + Next (Str_Elem); + end loop; + + Append_To (Actions, Result_Decl); + + return Make_Expression_With_Actions (Loc, + Actions => Actions, + Expression => New_Occurrence_Of (Result_Entity, Loc)); + end Build_Interpolated_String_Image; + + -- Local variables + + Typ : constant Entity_Id := Etype (N); + + -- Start of processing for Expand_N_Interpolated_String_Literal + + begin + Rewrite (N, Build_Interpolated_String_Image (N)); + Analyze_And_Resolve (N, Typ); + end Expand_N_Interpolated_String_Literal; + end Exp_Ch2; diff --git a/gcc/ada/exp_ch2.ads b/gcc/ada/exp_ch2.ads index 8845aa7..40df79c 100644 --- a/gcc/ada/exp_ch2.ads +++ b/gcc/ada/exp_ch2.ads @@ -28,8 +28,9 @@ with Types; use Types; package Exp_Ch2 is - procedure Expand_N_Expanded_Name (N : Node_Id); - procedure Expand_N_Identifier (N : Node_Id); - procedure Expand_N_Real_Literal (N : Node_Id); + procedure Expand_N_Expanded_Name (N : Node_Id); + procedure Expand_N_Identifier (N : Node_Id); + procedure Expand_N_Interpolated_String_Literal (N : Node_Id); + procedure Expand_N_Real_Literal (N : Node_Id); end Exp_Ch2; diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index eaedebe..9c2554f 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -338,7 +338,8 @@ package body Exp_Put_Image is -- For other elementary types, generate: -- - -- Wide_Wide_Put (Sink, U_Type'Wide_Wide_Image (Item)); + -- Wide_Wide_Put (Root_Buffer_Type'Class (Sink), + -- U_Type'Wide_Wide_Image (Item)); -- -- It would be more elegant to do it the other way around (define -- '[[Wide_]Wide_]Image in terms of 'Put_Image). But this is easier @@ -362,13 +363,23 @@ package body Exp_Put_Image is Prefix => New_Occurrence_Of (U_Type, Loc), Attribute_Name => Name_Wide_Wide_Image, Expressions => New_List (Relocate_Node (Item))); + Sink_Exp : constant Node_Id := + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of + (Class_Wide_Type (RTE (RE_Root_Buffer_Type)), Loc), + Expression => Relocate_Node (Sink)); Put_Call : constant Node_Id := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Wide_Wide_Put), Loc), Parameter_Associations => New_List - (Relocate_Node (Sink), Image)); + (Sink_Exp, Image)); begin + -- We have built a dispatching call to handle calls to + -- descendants (since they are not available through rtsfind). + -- Further details available in the body of Put_String_Exp. + return Put_Call; end; end if; @@ -427,12 +438,28 @@ package body Exp_Put_Image is (Etype (Next_Formal (First_Formal (Libent))), Relocate_Node (Item)); begin - return - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Libent, Loc), - Parameter_Associations => New_List ( - Relocate_Node (Sink), - Conv)); + -- Do not output string delimiters if this is part of an + -- interpolated string literal. + + if Nkind (Parent (N)) = N_Expression_With_Actions + and then Nkind (Original_Node (Parent (N))) + = N_Interpolated_String_Literal + then + return + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Libent, Loc), + Parameter_Associations => New_List ( + Relocate_Node (Sink), + Conv, + New_Occurrence_Of (Stand.Standard_False, Loc))); + else + return + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Libent, Loc), + Parameter_Associations => New_List ( + Relocate_Node (Sink), + Conv)); + end if; end; end Build_String_Put_Image_Call; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index c8829ca..74cd99c 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -7913,6 +7913,7 @@ package body Exp_Util is | N_Indexed_Component | N_Integer_Literal | N_Iterator_Specification + | N_Interpolated_String_Literal | N_Itype_Reference | N_Label | N_Loop_Parameter_Specification diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 13ec869..4687cedc 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -515,6 +515,9 @@ package body Expander is when N_Variant_Part => Expand_N_Variant_Part (N); + when N_Interpolated_String_Literal => + Expand_N_Interpolated_String_Literal (N); + -- For all other node kinds, no expansion activity required when others => diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index ec0eba7..fa73b6f 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -441,6 +441,9 @@ begin -- Gen_IL.Gen.Gen_Nodes Sm (Has_Wide_Character, Flag), Sm (Has_Wide_Wide_Character, Flag))); + Cc (N_Interpolated_String_Literal, N_Numeric_Or_String_Literal, + (Sy (Expressions, List_Id, Default_No_List))); + Cc (N_Explicit_Dereference, N_Subexpr, (Sy (Prefix, Node_Id), Sm (Actual_Designated_Subtype, Node_Id), diff --git a/gcc/ada/gen_il-types.ads b/gcc/ada/gen_il-types.ads index ca85ecf..8634a05 100644 --- a/gcc/ada/gen_il-types.ads +++ b/gcc/ada/gen_il-types.ads @@ -250,6 +250,7 @@ package Gen_IL.Types is N_Expression_With_Actions, N_If_Expression, N_Indexed_Component, + N_Interpolated_String_Literal, N_Null, N_Qualified_Expression, N_Quantified_Expression, diff --git a/gcc/ada/libgnat/a-stbubo.adb b/gcc/ada/libgnat/a-stbubo.adb index 3e941b8..3f4bd90 100644 --- a/gcc/ada/libgnat/a-stbubo.adb +++ b/gcc/ada/libgnat/a-stbubo.adb @@ -29,6 +29,7 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Characters.Handling; with Ada.Strings.UTF_Encoding.Conversions; with Ada.Strings.UTF_Encoding.Strings; with Ada.Strings.UTF_Encoding.Wide_Strings; @@ -91,9 +92,16 @@ package body Ada.Strings.Text_Buffers.Bounded is -- forget to add corresponding assignment statement below. Dummy : array (1 .. 0) of Buffer_Type (0) := [others => - (Max_Characters => 0, Chars => <>, Indentation => <>, - Indent_Pending => <>, UTF_8_Length => <>, UTF_8_Column => <>, - All_7_Bits => <>, All_8_Bits => <>, Truncated => <>)]; + (Max_Characters => 0, + Chars => <>, + Indentation => <>, + Indent_Pending => <>, + UTF_8_Length => <>, + UTF_8_Column => <>, + Trim_Leading_White_Spaces => <>, + All_7_Bits => <>, + All_8_Bits => <>, + Truncated => <>)]; begin Buffer.Indentation := Defaulted.Indentation; Buffer.Indent_Pending := Defaulted.Indent_Pending; @@ -131,7 +139,10 @@ package body Ada.Strings.Text_Buffers.Bounded is return; end if; - Buffer.All_7_Bits := @ and then Character'Pos (Char) < 128; + Buffer.All_7_Bits := + @ and then Character'Pos (Char) < 128; + Buffer.Trim_Leading_White_Spaces := + @ and then Characters.Handling.Is_Space (Char); Buffer.UTF_8_Length := @ + 1; Buffer.UTF_8_Column := @ + 1; diff --git a/gcc/ada/libgnat/a-stbuun.adb b/gcc/ada/libgnat/a-stbuun.adb index eabcad1..54449fb 100644 --- a/gcc/ada/libgnat/a-stbuun.adb +++ b/gcc/ada/libgnat/a-stbuun.adb @@ -29,6 +29,7 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Characters.Handling; with Ada.Unchecked_Deallocation; with Ada.Strings.UTF_Encoding.Conversions; with Ada.Strings.UTF_Encoding.Strings; @@ -104,9 +105,15 @@ package body Ada.Strings.Text_Buffers.Unbounded is -- forget to add corresponding assignment statement below. Dummy : array (1 .. 0) of Buffer_Type := [others => - (Indentation => <>, Indent_Pending => <>, UTF_8_Length => <>, - UTF_8_Column => <>, All_7_Bits => <>, All_8_Bits => <>, - List => <>, Last_Used => <>)]; + (Indentation => <>, + Indent_Pending => <>, + UTF_8_Length => <>, + UTF_8_Column => <>, + All_7_Bits => <>, + All_8_Bits => <>, + Trim_Leading_White_Spaces => <>, + List => <>, + Last_Used => <>)]; begin Buffer.Indentation := Defaulted.Indentation; Buffer.Indent_Pending := Defaulted.Indent_Pending; @@ -140,28 +147,41 @@ package body Ada.Strings.Text_Buffers.Unbounded is procedure Buffer_Type_Implementation (Buffer : in out Buffer_Type) is begin for Char of Item loop - Buffer.All_7_Bits := @ and then Character'Pos (Char) < 128; - - if Buffer.Last_Used = Buffer.List.Current_Chunk.Length then - -- Current chunk is full; allocate a new one with doubled size - - declare - Cc : Chunk renames Buffer.List.Current_Chunk.all; - Max : constant Positive := Integer'Last / 2; - Length : constant Natural := - Integer'Min (Max, 2 * Cc.Length); - begin - pragma Assert (Cc.Next = null); - Cc.Next := new Chunk (Length => Length); - Buffer.List.Current_Chunk := Cc.Next; - Buffer.Last_Used := 0; - end; - end if; - Buffer.UTF_8_Length := @ + 1; - Buffer.UTF_8_Column := @ + 1; - Buffer.Last_Used := @ + 1; - Buffer.List.Current_Chunk.Chars (Buffer.Last_Used) := Char; + -- The Trim_Leading_Space flag, which can be set prior to calling + -- any of the Put operations, which will cause white space + -- characters to be discarded by any Put operation until a + -- non-white-space character is encountered, at which point + -- the flag will be reset. + + if not Buffer.Trim_Leading_White_Spaces + or else not Characters.Handling.Is_Space (Char) + then + Buffer.All_7_Bits := @ and then Character'Pos (Char) < 128; + Buffer.Trim_Leading_White_Spaces := False; + + if Buffer.Last_Used = Buffer.List.Current_Chunk.Length then + -- Current chunk is full; allocate a new one with doubled + -- size + + declare + Cc : Chunk renames Buffer.List.Current_Chunk.all; + Max : constant Positive := Integer'Last / 2; + Length : constant Natural := + Integer'Min (Max, 2 * Cc.Length); + begin + pragma Assert (Cc.Next = null); + Cc.Next := new Chunk (Length => Length); + Buffer.List.Current_Chunk := Cc.Next; + Buffer.Last_Used := 0; + end; + end if; + + Buffer.UTF_8_Length := @ + 1; + Buffer.UTF_8_Column := @ + 1; + Buffer.Last_Used := @ + 1; + Buffer.List.Current_Chunk.Chars (Buffer.Last_Used) := Char; + end if; end loop; end Buffer_Type_Implementation; begin diff --git a/gcc/ada/libgnat/a-sttebu.adb b/gcc/ada/libgnat/a-sttebu.adb index acca292..182c131 100644 --- a/gcc/ada/libgnat/a-sttebu.adb +++ b/gcc/ada/libgnat/a-sttebu.adb @@ -54,6 +54,19 @@ package body Ada.Strings.Text_Buffers is Buffer.Indentation := @ - Natural (Amount); end Decrease_Indent; + procedure Set_Trim_Leading_Spaces + (Buffer : in out Root_Buffer_Type; + Trim : Boolean := True) is + begin + Buffer.Trim_Leading_White_Spaces := Trim; + end Set_Trim_Leading_Spaces; + + function Trim_Leading_Spaces + (Buffer : Root_Buffer_Type) return Boolean is + begin + return Buffer.Trim_Leading_White_Spaces; + end Trim_Leading_Spaces; + package body Output_Mapping is -- Implement indentation in Put_UTF_8 and New_Line. -- Implement other output procedures using Put_UTF_8. @@ -91,7 +104,9 @@ package body Ada.Strings.Text_Buffers is return; end if; - if Buffer.Indent_Pending then + if Buffer.Indent_Pending + and then not Buffer.Trim_Leading_White_Spaces + then Buffer.Indent_Pending := False; if Buffer.Indentation > 0 then Put_UTF_8_Implementation @@ -113,8 +128,9 @@ package body Ada.Strings.Text_Buffers is begin Buffer.Indent_Pending := False; -- just for a moment Put (Buffer, [ASCII.LF]); - Buffer.Indent_Pending := True; - Buffer.UTF_8_Column := 1; + Buffer.Indent_Pending := True; + Buffer.UTF_8_Column := 1; + Buffer.Trim_Leading_White_Spaces := False; end New_Line; end Output_Mapping; diff --git a/gcc/ada/libgnat/a-sttebu.ads b/gcc/ada/libgnat/a-sttebu.ads index 39144a6..a97477d 100644 --- a/gcc/ada/libgnat/a-sttebu.ads +++ b/gcc/ada/libgnat/a-sttebu.ads @@ -64,6 +64,16 @@ is Post'Class => Current_Indent (Buffer) = Current_Indent (Buffer)'Old - Amount; + procedure Set_Trim_Leading_Spaces + (Buffer : in out Root_Buffer_Type; + Trim : Boolean := True) with + Post => Trim_Leading_Spaces (Buffer) = Trim, + Inline => True; + + function Trim_Leading_Spaces + (Buffer : Root_Buffer_Type) return Boolean + with Inline; + private type Root_Buffer_Type is abstract tagged limited record @@ -85,6 +95,12 @@ private All_8_Bits : Boolean := True; -- True if all characters seen so far fit in 8 bits + Trim_Leading_White_Spaces : Boolean := False; + -- Flag set prior to calling any of the Put operations, which will + -- cause white space characters to be discarded by any Put operation + -- until a non-white-space character is encountered, at which point + -- the flag will be reset. + end record; generic diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb index 10d8b84..d3261fd 100644 --- a/gcc/ada/libgnat/s-putima.adb +++ b/gcc/ada/libgnat/s-putima.adb @@ -174,41 +174,67 @@ package body System.Put_Images is Thin_Instance (S, X, "access protected subprogram"); end Put_Image_Access_Prot_Subp; - procedure Put_Image_String (S : in out Sink'Class; X : String) is + procedure Put_Image_String + (S : in out Sink'Class; + X : String; + With_Delimiters : Boolean := True) is begin - Put_UTF_8 (S, """"); + if With_Delimiters then + Put_UTF_8 (S, """"); + end if; + for C of X loop - if C = '"' then + if C = '"' and then With_Delimiters then Put_UTF_8 (S, """"); end if; Put_Character (S, C); end loop; - Put_UTF_8 (S, """"); + + if With_Delimiters then + Put_UTF_8 (S, """"); + end if; end Put_Image_String; - procedure Put_Image_Wide_String (S : in out Sink'Class; X : Wide_String) is + procedure Put_Image_Wide_String + (S : in out Sink'Class; + X : Wide_String; + With_Delimiters : Boolean := True) is begin - Put_UTF_8 (S, """"); + if With_Delimiters then + Put_UTF_8 (S, """"); + end if; + for C of X loop - if C = '"' then + if C = '"' and then With_Delimiters then Put_UTF_8 (S, """"); end if; Put_Wide_Character (S, C); end loop; - Put_UTF_8 (S, """"); + + if With_Delimiters then + Put_UTF_8 (S, """"); + end if; end Put_Image_Wide_String; procedure Put_Image_Wide_Wide_String - (S : in out Sink'Class; X : Wide_Wide_String) is + (S : in out Sink'Class; + X : Wide_Wide_String; + With_Delimiters : Boolean := True) is begin - Put_UTF_8 (S, """"); + if With_Delimiters then + Put_UTF_8 (S, """"); + end if; + for C of X loop - if C = '"' then + if C = '"' and then With_Delimiters then Put_UTF_8 (S, """"); end if; Put_Wide_Wide_Character (S, C); end loop; - Put_UTF_8 (S, """"); + + if With_Delimiters then + Put_UTF_8 (S, """"); + end if; end Put_Image_Wide_Wide_String; procedure Array_Before (S : in out Sink'Class) is diff --git a/gcc/ada/libgnat/s-putima.ads b/gcc/ada/libgnat/s-putima.ads index b51e6a9..1bcec31 100644 --- a/gcc/ada/libgnat/s-putima.ads +++ b/gcc/ada/libgnat/s-putima.ads @@ -84,10 +84,20 @@ package System.Put_Images with Pure is (S : in out Sink'Class; X : Thin_Pointer); -- For access-to-protected-subprogram types - procedure Put_Image_String (S : in out Sink'Class; X : String); - procedure Put_Image_Wide_String (S : in out Sink'Class; X : Wide_String); + procedure Put_Image_String + (S : in out Sink'Class; + X : String; + With_Delimiters : Boolean := True); + + procedure Put_Image_Wide_String + (S : in out Sink'Class; + X : Wide_String; + With_Delimiters : Boolean := True); + procedure Put_Image_Wide_Wide_String - (S : in out Sink'Class; X : Wide_Wide_String); + (S : in out Sink'Class; + X : Wide_Wide_String; + With_Delimiters : Boolean := True); procedure Array_Before (S : in out Sink'Class); procedure Array_Between (S : in out Sink'Class); diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index 060bb41..3d369ba 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -199,6 +199,79 @@ package body Ch2 is -- Handled by scanner as part of string literal handling (see 2.4) + --------------------------------------- + -- 2.6 Interpolated String Literal -- + --------------------------------------- + + -- INTERPOLATED_STRING_LITERAL ::= + -- 'f' "{INTERPOLATED_STRING_ELEMENT}" { + -- "{INTERPOLATED_STRING_ELEMENT}" } + + -- INTERPOLATED_STRING_ELEMENT ::= + -- ESCAPED_CHARACTER | INTERPOLATED_EXPRESSION + -- | non_quotation_mark_non_left_brace_GRAPHIC_CHARACTER + + -- ESCAPED_CHARACTER ::= '\GRAPHIC_CHARACTER' + + -- INTERPOLATED_EXPRESSION ::= '{' EXPRESSION '}' + + -- Interpolated string element and escaped character rules are handled by + -- scanner as part of string literal handling. + + ----------------------------------- + -- P_Interpolated_String_Literal -- + ----------------------------------- + + function P_Interpolated_String_Literal return Node_Id is + Elements_List : constant List_Id := New_List; + NL_Node : Node_Id; + String_Node : Node_Id; + + begin + String_Node := New_Node (N_Interpolated_String_Literal, Token_Ptr); + Inside_Interpolated_String_Literal := True; + + Scan; -- past 'f' + + if Token /= Tok_String_Literal then + Error_Msg_SC ("string literal expected"); + + else + Append_To (Elements_List, Token_Node); + Scan; -- past string_literal + + while Token in Tok_Left_Curly_Bracket | Tok_String_Literal loop + + -- Interpolated expression + + if Token = Tok_Left_Curly_Bracket then + Scan; -- past '{' + Append_To (Elements_List, P_Expression); + T_Right_Curly_Bracket; + else + if Prev_Token = Tok_String_Literal then + NL_Node := New_Node (N_String_Literal, Token_Ptr); + Set_Has_Wide_Character (NL_Node, False); + Set_Has_Wide_Wide_Character (NL_Node, False); + + Start_String; + Store_String_Char (Get_Char_Code (ASCII.LF)); + Set_Strval (NL_Node, End_String); + Append_To (Elements_List, NL_Node); + end if; + + Append_To (Elements_List, Token_Node); + Scan; -- past string_literal + end if; + end loop; + end if; + + Inside_Interpolated_String_Literal := False; + Set_Expressions (String_Node, Elements_List); + + return String_Node; + end P_Interpolated_String_Literal; + ------------------ -- 2.7 Comment -- ------------------ diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 82b09b2..f5a34ec 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -2319,6 +2319,14 @@ package body Ch4 is if Token in Token_Class_Sterm then null; + -- Handle '}' as expression terminator of an interpolated + -- expression. + + elsif Inside_Interpolated_String_Literal + and then Token = Tok_Right_Curly_Bracket + then + null; + -- If we do not have an expression terminator, then complete the -- scan of a simple expression. This code duplicates the code -- found in P_Term and P_Factor. @@ -2557,8 +2565,13 @@ package body Ch4 is -- an expression terminator, and is not in Token_Class_Sterm, but -- in this special case we know that the expression is complete. + -- We disable this error recovery machinery when we are processing an + -- interpolated string and we reach the expression terminator '}'. + if not Token_Is_At_Start_Of_Line and then Token not in Token_Class_Sterm + and then not (Inside_Interpolated_String_Literal + and then Token = Tok_Right_Curly_Bracket) then -- Normally the right error message is indeed that we expected a -- binary operator, but in the case of being between a right and left @@ -2851,6 +2864,9 @@ package body Ch4 is when Tok_Left_Bracket => return P_Aggregate; + when Tok_Left_Interpolated_String => + return P_Interpolated_String_Literal; + -- Allocator when Tok_New => diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb index 3989cd2..24ab75b 100644 --- a/gcc/ada/par-tchk.adb +++ b/gcc/ada/par-tchk.adb @@ -402,6 +402,20 @@ package body Tchk is Check_Token (Tok_Record, AP); end T_Record; + --------------------------- + -- T_Right_Curly_Bracket -- + --------------------------- + + procedure T_Right_Curly_Bracket is + begin + if Token = Tok_Right_Curly_Bracket then + Scan; + else + Error_Msg_AP + ("|missing ""'}'"""); + end if; + end T_Right_Curly_Bracket; + --------------------- -- T_Right_Bracket -- --------------------- diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 01e3c4b..5fbdbbd 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -48,6 +48,7 @@ with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; with Snames; use Snames; +with Stringt; use Stringt; with Style; with Stylesw; use Stylesw; with Table; @@ -652,6 +653,8 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- if either this is the first occurrence of misuse of this identifier, -- or if Force_Msg is True. + function P_Interpolated_String_Literal return Node_Id; + function P_Pragmas_Opt return List_Id; -- This function scans for a sequence of pragmas in other than a -- declaration sequence or statement sequence context. All pragmas @@ -1238,6 +1241,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is procedure T_Range; procedure T_Record; procedure T_Right_Bracket; + procedure T_Right_Curly_Bracket; procedure T_Right_Paren; procedure T_Semicolon; procedure T_Then; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index ce49e2d..86dbb62 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -605,6 +605,7 @@ package Rtsfind is RE_Root_Buffer_Type, -- Ada.Strings.Text_Buffers RE_Put_UTF_8, -- Ada.Strings.Text_Buffers + RE_Set_Trim_Leading_Spaces, -- Ada.Strings.Text_Buffers RE_Wide_Wide_Put, -- Ada.Strings.Text_Buffers RE_Buffer_Type, -- Ada.Strings.Text_Buffers.Unbounded @@ -2243,6 +2244,7 @@ package Rtsfind is RE_Root_Buffer_Type => Ada_Strings_Text_Buffers, RE_Put_UTF_8 => Ada_Strings_Text_Buffers, + RE_Set_Trim_Leading_Spaces => Ada_Strings_Text_Buffers, RE_Wide_Wide_Put => Ada_Strings_Text_Buffers, RE_Buffer_Type => Ada_Strings_Text_Buffers_Unbounded, diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index ddb4c3e..c59ff18 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -84,12 +84,19 @@ package Scans is -- Ada 2022 introduces square brackets as delimiters for array and -- container aggregates. - Tok_Raise, -- RAISE + -- The left delimiter token of interpolated strings, and tokens { and } + -- of interpolated expressions are currently placed in no category since + -- they don't fit well in the existing categories. + + Tok_Left_Interpolated_String, -- f" + Tok_Left_Curly_Bracket, -- { + Tok_Raise, -- RAISE + Tok_Right_Curly_Bracket, -- } Tok_Dot, -- . Namext Tok_Apostrophe, -- ' Namext - Tok_Left_Bracket, -- [ Namest + Tok_Left_Bracket, -- [ Namext Tok_Left_Paren, -- ( Namext, Consk Tok_Delta, -- DELTA Atkwd, Sterm, Consk @@ -475,6 +482,9 @@ package Scans is -- or aspect. Used to allow/require nonstandard style rules for =>+ with -- -gnatyt. + Inside_Interpolated_String_Literal : Boolean := False; + -- True while parsing an interpolated string literal + Inside_If_Expression : Nat := 0; -- This is a counter that is set non-zero while scanning out an if -- expression (incremented on entry, decremented on exit). It is used to diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index b6698a6..0ee71fb 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -1077,8 +1077,20 @@ package body Scng is String_Start := Scan_Ptr; - Delimiter := Source (Scan_Ptr); - Accumulate_Checksum (Delimiter); + -- Continuation of interpolated string literal + + if Inside_Interpolated_String_Literal + and then Prev_Token = Tok_Right_Curly_Bracket + then + Scan_Ptr := Scan_Ptr - 1; + Delimiter := '"'; + + -- Common case + + else + Delimiter := Source (Scan_Ptr); + Accumulate_Checksum (Delimiter); + end if; Start_String; Wide_Character_Found := False; @@ -1094,6 +1106,15 @@ package body Scng is Accumulate_Checksum (C); Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) /= Delimiter; + + -- Unlike normal string literals, doubled delimiter has no + -- special significance in interpolated string literals. + + if Inside_Interpolated_String_Literal then + Error_Msg_S + ("double quotations not allowed in interpolated string"); + end if; + Code := Get_Char_Code (C); Accumulate_Checksum (C); Scan_Ptr := Scan_Ptr + 1; @@ -1105,6 +1126,40 @@ package body Scng is Code := Get_Char_Code (C); Scan_Ptr := Scan_Ptr + 1; + -- Found interpolated expression + + elsif Inside_Interpolated_String_Literal + and then C = '{' + then + Accumulate_Checksum (C); + exit; + + -- Escaped character in interpolated string literal + + elsif Inside_Interpolated_String_Literal + and then C = '\' + then + Accumulate_Checksum (C); + Scan_Ptr := Scan_Ptr + 1; + C := Source (Scan_Ptr); + Accumulate_Checksum (C); + Scan_Ptr := Scan_Ptr + 1; + + case C is + when 'a' => Code := Get_Char_Code (ASCII.BEL); + when 'b' => Code := Get_Char_Code (ASCII.BS); + when 'f' => Code := Get_Char_Code (ASCII.FF); + when 'n' => Code := Get_Char_Code (ASCII.LF); + when 'r' => Code := Get_Char_Code (ASCII.CR); + when 't' => Code := Get_Char_Code (ASCII.HT); + when 'v' => Code := Get_Char_Code (ASCII.VT); + when '0' => Code := Get_Char_Code (ASCII.NUL); + when '\' | '"' | '{' | '}' + => Code := Get_Char_Code (C); + when others => + Error_Msg_S ("illegal escaped character"); + end case; + elsif Start_Of_Wide_Character then Wptr := Scan_Ptr; Scan_Wide (Source, Scan_Ptr, Code, Err); @@ -1234,6 +1289,29 @@ package body Scng is Prev_Token_Ptr := Token_Ptr; Token_Name := Error_Name; + if Inside_Interpolated_String_Literal + and then Prev_Token = Tok_Right_Curly_Bracket + then + -- Consecutive interpolated expressions + + if Source (Scan_Ptr) = '{' then + null; + + -- Ending delimiter placed immediately after interpolated expression + + elsif Source (Scan_Ptr) = '"' then + Scan_Ptr := Scan_Ptr + 1; + Prev_Token := Tok_String_Literal; + + -- String literal placed after interpolated expression + + else + Slit; + Post_Scan; + return; + end if; + end if; + -- The following loop runs more than once only if a format effector -- (tab, vertical tab, form feed, line feed, carriage return) is -- encountered and skipped, or some error situation, such as an @@ -1448,12 +1526,20 @@ package body Scng is return; end if; - -- Left brace + -- Left curly bracket, treated as right paren but proper delimiter + -- of interpolated string literals when all extensions are allowed. when '{' => - Error_Msg_S ("illegal character, replaced by ""("""); - Scan_Ptr := Scan_Ptr + 1; - Token := Tok_Left_Paren; + if All_Extensions_Allowed then + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Left_Curly_Bracket; + + else + Error_Msg_S ("illegal character, replaced by ""("""); + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Left_Paren; + end if; + return; -- Comma @@ -1863,7 +1949,7 @@ package body Scng is -- Right bracket or right brace, treated as right paren but proper -- aggregate delimiter in Ada 2022. - when ']' | '}' => + when ']' => if Ada_Version >= Ada_2022 then Token := Tok_Right_Bracket; @@ -1875,6 +1961,21 @@ package body Scng is Scan_Ptr := Scan_Ptr + 1; return; + -- Right curly bracket, treated as right paren but proper delimiter + -- of interpolated string literals when all extensions are allowed. + + when '}' => + if All_Extensions_Allowed then + Token := Tok_Right_Curly_Bracket; + + else + Error_Msg_S ("illegal character, replaced by "")"""); + Token := Tok_Right_Paren; + end if; + + Scan_Ptr := Scan_Ptr + 1; + return; + -- Slash (can be division operator or first character of not equal) when '/' => @@ -2024,6 +2125,16 @@ package body Scng is -- Lower case letters when 'a' .. 'z' => + if All_Extensions_Allowed + and then Source (Scan_Ptr) = 'f' + and then Source (Scan_Ptr + 1) = '"' + then + Scan_Ptr := Scan_Ptr + 1; + Accumulate_Checksum (Source (Scan_Ptr)); + Token := Tok_Left_Interpolated_String; + return; + end if; + Name_Len := 1; Underline_Found := False; Name_Buffer (1) := Source (Scan_Ptr); @@ -2034,6 +2145,17 @@ package body Scng is -- Upper case letters when 'A' .. 'Z' => + if All_Extensions_Allowed + and then Source (Scan_Ptr) = 'F' + and then Source (Scan_Ptr + 1) = '"' + then + Error_Msg_S + ("delimiter of interpolated string must be in lowercase"); + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_Left_Interpolated_String; + return; + end if; + Token_Contains_Uppercase := True; Name_Len := 1; Underline_Found := False; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 6c1e9d7..42dca13 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -557,6 +557,9 @@ package body Sem is when N_String_Literal => Analyze_String_Literal (N); + when N_Interpolated_String_Literal => + Analyze_Interpolated_String_Literal (N); + when N_Subprogram_Body => Analyze_Subprogram_Body (N); diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb index 6b84af4..69a65c4 100644 --- a/gcc/ada/sem_ch2.adb +++ b/gcc/ada/sem_ch2.adb @@ -28,9 +28,11 @@ with Einfo; use Einfo; with Einfo.Utils; use Einfo.Utils; with Ghost; use Ghost; with Namet; use Namet; +with Nlists; use Nlists; with Opt; use Opt; with Restrict; use Restrict; with Rident; use Rident; +with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sem_Dim; use Sem_Dim; with Sinfo; use Sinfo; @@ -119,6 +121,23 @@ package body Sem_Ch2 is Set_Is_Static_Expression (N); end Analyze_Integer_Literal; + ----------------------------------------- + -- Analyze_Interpolated_String_Literal -- + ----------------------------------------- + + procedure Analyze_Interpolated_String_Literal (N : Node_Id) is + Str_Elem : Node_Id; + + begin + Set_Etype (N, Any_String); + + Str_Elem := First (Expressions (N)); + while Present (Str_Elem) loop + Analyze (Str_Elem); + Next (Str_Elem); + end loop; + end Analyze_Interpolated_String_Literal; + -------------------------- -- Analyze_Real_Literal -- -------------------------- diff --git a/gcc/ada/sem_ch2.ads b/gcc/ada/sem_ch2.ads index a199fef..fb64a33 100644 --- a/gcc/ada/sem_ch2.ads +++ b/gcc/ada/sem_ch2.ads @@ -27,11 +27,12 @@ with Types; use Types; package Sem_Ch2 is - procedure Analyze_Character_Literal (N : Node_Id); - procedure Analyze_Identifier (N : Node_Id); - procedure Analyze_Integer_Literal (N : Node_Id); - procedure Analyze_Real_Literal (N : Node_Id); - procedure Analyze_String_Literal (N : Node_Id); + procedure Analyze_Character_Literal (N : Node_Id); + procedure Analyze_Identifier (N : Node_Id); + procedure Analyze_Integer_Literal (N : Node_Id); + procedure Analyze_Interpolated_String_Literal (N : Node_Id); + procedure Analyze_Real_Literal (N : Node_Id); + procedure Analyze_String_Literal (N : Node_Id); private pragma Inline (Analyze_Character_Literal); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 348d272..9fcbba73 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -212,6 +212,9 @@ package body Sem_Res is procedure Resolve_Generalized_Indexing (N : Node_Id; Typ : Entity_Id); procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id); procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Interpolated_String_Literal + (N : Node_Id; + Typ : Entity_Id); procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Null (N : Node_Id; Typ : Entity_Id); @@ -449,9 +452,10 @@ package body Sem_Res is Loc : constant Source_Ptr := Sloc (N); Literal_Aspect_Map : constant array (N_Numeric_Or_String_Literal) of Aspect_Id := - (N_Integer_Literal => Aspect_Integer_Literal, - N_Real_Literal => Aspect_Real_Literal, - N_String_Literal => Aspect_String_Literal); + (N_Integer_Literal => Aspect_Integer_Literal, + N_Interpolated_String_Literal => No_Aspect, + N_Real_Literal => Aspect_Real_Literal, + N_String_Literal => Aspect_String_Literal); Named_Number_Aspect_Map : constant array (Named_Kind) of Aspect_Id := (E_Named_Integer => Aspect_Integer_Literal, @@ -3437,6 +3441,9 @@ package body Sem_Res is when N_String_Literal => Resolve_String_Literal (N, Ctx_Type); + when N_Interpolated_String_Literal => + Resolve_Interpolated_String_Literal (N, Ctx_Type); + when N_Target_Name => Resolve_Target_Name (N, Ctx_Type); @@ -9672,6 +9679,35 @@ package body Sem_Res is Eval_Integer_Literal (N); end Resolve_Integer_Literal; + ----------------------------------------- + -- Resolve_Interpolated_String_Literal -- + ----------------------------------------- + + procedure Resolve_Interpolated_String_Literal (N : Node_Id; Typ : Entity_Id) + is + Str_Elem : Node_Id; + + begin + Str_Elem := First (Expressions (N)); + pragma Assert (Nkind (Str_Elem) = N_String_Literal); + + while Present (Str_Elem) loop + + -- Resolve string elements using the context type; for interpolated + -- expressions there is no need to check if their type has a suitable + -- image function because under Ada 2022 all the types have such + -- function available. + + if Etype (Str_Elem) = Any_String then + Resolve (Str_Elem, Typ); + end if; + + Next (Str_Elem); + end loop; + + Set_Etype (N, Typ); + end Resolve_Interpolated_String_Literal; + -------------------------------- -- Resolve_Intrinsic_Operator -- -------------------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a05ac74..934979e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -20785,9 +20785,10 @@ package body Sem_Util is is Literal_Aspect_Map : constant array (N_Numeric_Or_String_Literal) of Aspect_Id := - (N_Integer_Literal => Aspect_Integer_Literal, - N_Real_Literal => Aspect_Real_Literal, - N_String_Literal => Aspect_String_Literal); + (N_Integer_Literal => Aspect_Integer_Literal, + N_Interpolated_String_Literal => No_Aspect, + N_Real_Literal => Aspect_Real_Literal, + N_String_Literal => Aspect_String_Literal); begin -- Return True when N is either a literal or a named number and the diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 104ee66..722e6d4 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -2618,6 +2618,33 @@ package Sinfo is -- Is_Folded_In_Parser -- plus fields for expression + --------------------------------------- + -- 2.6 Interpolated String Literal -- + --------------------------------------- + + -- INTERPOLATED_STRING_LITERAL ::= + -- '{' "{INTERPOLATED_STRING_ELEMENT}" { + -- "{INTERPOLATED_STRING_ELEMENT}" } '}' + + -- INTERPOLATED_STRING_ELEMENT ::= + -- ESCAPED_CHARACTER | INTERPOLATED_EXPRESSION + -- | non_quotation_mark_non_left_brace_GRAPHIC_CHARACTER + + -- ESCAPED_CHARACTER ::= '\GRAPHIC_CHARACTER' + + -- INTERPOLATED_EXPRESSION ::= '{' EXPRESSION '}' + + -- Most of these syntax rules are omitted as tree nodes to simplify + -- semantic processing. The scanner handles escaped characters as part + -- of processing an interpolated string literal, and the parser stores + -- in the Expressions field of this node a list containing the sequence + -- of string literals and the roots of the interpolated expressions. + + -- N_Interpolated_String_Literal + -- Sloc points to literal + -- Expressions + -- plus fields for expression + ------------------ -- 2.7 Comment -- ------------------ diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 0f292c8..19a9a43 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -3313,6 +3313,38 @@ package body Sprint is Set_Debug_Sloc; Write_String_Table_Entry (Strval (Node)); + when N_Interpolated_String_Literal => + Write_Char ('{'); + + declare + Str_Elem : Node_Id := First (Expressions (Node)); + Is_First : Boolean := True; + + begin + while Present (Str_Elem) loop + if not Is_First then + Write_Str (" & "); + end if; + + if Nkind (Str_Elem) = N_String_Literal then + Sprint_Node (Str_Elem); + + else + Write_Char ('"'); + Write_Char ('{'); + Sprint_Node (Str_Elem); + Write_Char ('}'); + Write_Char ('"'); + end if; + + Is_First := False; + + Next (Str_Elem); + end loop; + end; + + Write_Char ('}'); + when N_Subprogram_Body => -- Output extra blank line unless we are in freeze actions |