Index: src/natools-s_expressions-printers-pretty.adb ================================================================== --- src/natools-s_expressions-printers-pretty.adb +++ src/natools-s_expressions-printers-pretty.adb @@ -259,10 +259,11 @@ procedure Newline (Output : in out Printer) is Data : Atom (0 .. 1); Length : Count; + Writer : Printer'Class renames Printer'Class (Output); begin case Output.Param.Newline is when CR => Data (0) := Encodings.CR; Length := 1; @@ -276,23 +277,22 @@ when LF_CR => Data (0) := Encodings.LF; Data (1) := Encodings.CR; Length := 2; end case; - Output.Stream.Write (Data (0 .. Length - 1)); + Writer.Write_Raw (Data (0 .. Length - 1)); if Output.Indent_Level > 0 and Output.Param.Indentation > 0 then case Output.Param.Indent is when Spaces => Output.Cursor := Output.Param.Indentation * Output.Indent_Level + 1; - Output.Stream.Write ((1 .. Count (Output.Cursor) - 1 - => Encodings.Space)); + Writer.Write_Raw + ((1 .. Count (Output.Cursor) - 1 => Encodings.Space)); when Tabs => Output.Cursor := Output.Param.Indentation * Output.Indent_Level; - Output.Stream.Write ((1 .. Count (Output.Cursor) - => Encodings.HT)); + Writer.Write_Raw ((1 .. Count (Output.Cursor) => Encodings.HT)); Output.Cursor := Output.Cursor * Output.Param.Tab_Stop; when Tabs_And_Spaces => Output.Cursor := Output.Param.Indentation * Output.Indent_Level + 1; declare @@ -301,12 +301,12 @@ / Count (Output.Param.Tab_Stop); Space_Count : constant Count := (Count (Output.Cursor) - 1) mod Count (Output.Param.Tab_Stop); begin - Output.Stream.Write ((1 .. Tab_Count => Encodings.HT)); - Output.Stream.Write ((1 .. Space_Count => Encodings.Space)); + Writer.Write_Raw ((1 .. Tab_Count => Encodings.HT)); + Writer.Write_Raw ((1 .. Space_Count => Encodings.Space)); end; end case; else Output.Cursor := 1; end if; @@ -471,38 +471,39 @@ procedure Write_Base64 (Output : in out Printer; Data : in Atom) is Available : Screen_Offset; I : Offset := Data'First; Chunk_Size : Count; + Writer : Printer'Class renames Printer'Class (Output); begin if Output.Param.Width = 0 then - Output.Stream.Write ((0 => Encodings.Base64_Atom_Begin)); - Output.Stream.Write (Encodings.Encode_Base64 (Data)); - Output.Stream.Write ((0 => Encodings.Base64_Atom_End)); + Writer.Write_Raw ((0 => Encodings.Base64_Atom_Begin)); + Writer.Write_Raw (Encodings.Encode_Base64 (Data)); + Writer.Write_Raw ((0 => Encodings.Base64_Atom_End)); else - Output.Stream.Write ((0 => Encodings.Base64_Atom_Begin)); + Writer.Write_Raw ((0 => Encodings.Base64_Atom_Begin)); Output.Cursor := Output.Cursor + 1; loop Available := Output.Param.Width + 1 - Output.Cursor; Chunk_Size := Count'Max (1, Count (Available) / 4) * 3; if Available mod 4 /= 0 and then I in Data'Range then - Output.Stream.Write - ((1 .. Count (Available mod 4) => Encodings.Space)); + Writer.Write_Raw + (((1 .. Count (Available mod 4) => Encodings.Space))); Output.Cursor := Output.Cursor + (Available mod 4); end if; if I + Chunk_Size - 1 in Data'Range then - Output.Stream.Write (Encodings.Encode_Base64 - (Data (I .. I + Chunk_Size - 1))); + Writer.Write_Raw + (Encodings.Encode_Base64 (Data (I .. I + Chunk_Size - 1))); Newline (Output); I := I + Chunk_Size; else - Output.Stream.Write (Encodings.Encode_Base64 - (Data (I .. Data'Last))); - Output.Stream.Write ((0 => Encodings.Base64_Atom_End)); + Writer.Write_Raw + (Encodings.Encode_Base64 (Data (I .. Data'Last))); + Writer.Write_Raw ((0 => Encodings.Base64_Atom_End)); Output.Cursor := Output.Cursor + Screen_Offset (Data'Last - I + 2) / 3 * 4 + 1; exit; end if; end loop; @@ -512,40 +513,43 @@ procedure Write_Hex (Output : in out Printer; Data : in Atom) is Available : Screen_Offset; I : Offset := Data'First; Chunk_Size : Count; + Writer : Printer'Class renames Printer'Class (Output); begin if Output.Param.Width = 0 then - Output.Stream.Write ((0 => Encodings.Hex_Atom_Begin)); - Output.Stream.Write (Encodings.Encode_Hex (Data, - Output.Param.Hex_Casing)); - Output.Stream.Write ((0 => Encodings.Hex_Atom_End)); + Writer.Write_Raw ((0 => Encodings.Hex_Atom_Begin)); + Writer.Write_Raw + (Encodings.Encode_Hex (Data, Output.Param.Hex_Casing)); + Writer.Write_Raw ((0 => Encodings.Hex_Atom_End)); else - Output.Stream.Write ((0 => Encodings.Hex_Atom_Begin)); + Writer.Write_Raw ((0 => Encodings.Hex_Atom_Begin)); Output.Cursor := Output.Cursor + 1; loop Available := Output.Param.Width + 1 - Output.Cursor; Chunk_Size := Count'Max (1, Count (Available) / 2); if Available mod 2 = 1 and then I in Data'Range then - Output.Stream.Write ((0 => Encodings.Space)); + Writer.Write_Raw ((0 => Encodings.Space)); Output.Cursor := Output.Cursor + 1; end if; if I + Chunk_Size - 1 in Data'Range then - Output.Stream.Write (Encodings.Encode_Hex - (Data (I .. I + Chunk_Size - 1), - Output.Param.Hex_Casing)); + Writer.Write_Raw + (Encodings.Encode_Hex + (Data (I .. I + Chunk_Size - 1), + Output.Param.Hex_Casing)); Newline (Output); I := I + Chunk_Size; else - Output.Stream.Write (Encodings.Encode_Hex - (Data (I .. Data'Last), - Output.Param.Hex_Casing)); - Output.Stream.Write ((0 => Encodings.Hex_Atom_End)); + Writer.Write_Raw + (Encodings.Encode_Hex + (Data (I .. Data'Last), + Output.Param.Hex_Casing)); + Writer.Write_Raw ((0 => Encodings.Hex_Atom_End)); Output.Cursor := Output.Cursor + Screen_Offset (Data'Last - I + 1) * 2 + 1; exit; end if; end loop; @@ -753,11 +757,11 @@ end loop; pragma Assert (O = Result'Last); Result (O) := Encodings.Quoted_Atom_End; - Output.Stream.Write (Result); + Write_Raw (Printer'Class (Output), Result); end; end Write_Quoted; procedure Write_Verbatim (Output : in out Printer; Data : in Atom) is @@ -768,12 +772,12 @@ Prefix (Count (I) - Count (Length_Image'First + 1)) := Character'Pos (Length_Image (I)); end loop; Prefix (Prefix'Last) := Encodings.Verbatim_Begin; - Output.Stream.Write (Prefix); - Output.Stream.Write (Data); + Write_Raw (Printer'Class (Output), Prefix); + Write_Raw (Printer'Class (Output), Data); Output.Cursor := Output.Cursor + Screen_Offset (Prefix'Length) + Screen_Offset (Data'Length); end Write_Verbatim; @@ -794,18 +798,18 @@ if not Output.First then if Output.Param.Newline_At (Output.Previous, Opening) then Newline (Output); elsif Output.Param.Space_At (Output.Previous, Opening) then - Output.Stream.Write ((0 => Encodings.Space)); + Write_Raw (Printer'Class (Output), (0 => Encodings.Space)); Output.Cursor := Output.Cursor + 1; end if; else Output.First := False; end if; - Output.Stream.Write ((0 => Encodings.List_Begin)); + Write_Raw (Printer'Class (Output), (0 => Encodings.List_Begin)); Output.Cursor := Output.Cursor + 1; Output.Indent_Level := Output.Indent_Level + 1; Output.Previous := Opening; Output.Need_Blank := False; end Open_List; @@ -853,14 +857,14 @@ if not At_Origin and then not Fit_In_Line (Output, Blank_Width + Width) then Newline (Output); elsif Output.Need_Blank then - Output.Stream.Write ((0 => Encodings.Space)); + Write_Raw (Printer'Class (Output), (0 => Encodings.Space)); Output.Cursor := Output.Cursor + 1; end if; - Output.Stream.Write (Data); + Write_Raw (Printer'Class (Output), Data); Output.Cursor := Output.Cursor + Width; Output.Need_Blank := True; return; end; end if; @@ -872,11 +876,11 @@ Width : constant Screen_Offset := Single_Line_Quoted_Width (Data, Output.Param.Char_Encoding); begin if Fit_In_Line (Output, Blank_Width + Width) then if Output.Need_Blank then - Output.Stream.Write ((0 => Encodings.Space)); + Write_Raw (Printer'Class (Output), (0 => Encodings.Space)); Output.Cursor := Output.Cursor + 1; end if; Write_Quoted (Output, Data, True); Output.Need_Blank := False; return; @@ -915,31 +919,25 @@ if Output.Param.Quoted = When_Shorter and then Multi_Line_Quoted_Size (Output, Data) <= Size then if Output.Need_Blank then - Output.Stream.Write ((0 => Encodings.Space)); + Write_Raw (Printer'Class (Output), (0 => Encodings.Space)); Output.Cursor := Output.Cursor + 1; end if; Write_Quoted (Output, Data, False); Output.Need_Blank := False; return; end if; --- if Output.Param.Quoted = When_Shorter then --- String'Write (Output.Stream, --- "{" & Count'Image (Size) & "|" --- & Count'Image (Multi_Line_Quoted_Size (Output, Data)) & "}"); --- end if; - if not At_Origin and then not Fit_In_Line (Output, Blank_Width + Screen_Offset (Size)) then Newline (Output); elsif Output.Need_Blank then - Output.Stream.Write ((0 => Encodings.Space)); + Write_Raw (Printer'Class (Output), (0 => Encodings.Space)); Output.Cursor := Output.Cursor + 1; end if; case Output.Param.Fallback is when Base64 => @@ -968,18 +966,18 @@ if not Output.First then if Output.Param.Newline_At (Output.Previous, Closing) then Newline (Output); elsif Output.Param.Space_At (Output.Previous, Closing) then - Output.Stream.Write ((0 => Encodings.Space)); + Write_Raw (Printer'Class (Output), (0 => Encodings.Space)); Output.Cursor := Output.Cursor + 1; end if; else Output.First := False; end if; - Output.Stream.Write ((0 => Encodings.List_End)); + Write_Raw (Printer'Class (Output), (0 => Encodings.List_End)); Output.Cursor := Output.Cursor + 1; Output.Previous := Closing; Output.Need_Blank := False; end Close_List; @@ -1102,6 +1100,14 @@ Newline : in Newline_Encoding) is begin Output.Param.Newline := Newline; end Set_Newline; + + overriding procedure Write_Raw + (Output : in out Stream_Printer; + Data : in Ada.Streams.Stream_Element_Array) is + begin + Output.Stream.Write (Data); + end Write_Raw; + end Natools.S_Expressions.Printers.Pretty; Index: src/natools-s_expressions-printers-pretty.ads ================================================================== --- src/natools-s_expressions-printers-pretty.ads +++ src/natools-s_expressions-printers-pretty.ads @@ -56,12 +56,16 @@ Newline : Newline_Encoding; end record; Canonical : constant Parameters; - type Printer (Stream : access Ada.Streams.Root_Stream_Type'Class) is - new Printers.Printer with private; + type Printer is abstract limited new Printers.Printer with private; + + procedure Write_Raw + (Output : in out Printer; + Data : in Ada.Streams.Stream_Element_Array) + is abstract; overriding procedure Open_List (Output : in out Printer); overriding procedure Append_Atom (Output : in out Printer; Data : in Atom); @@ -108,14 +112,17 @@ Fallback : in Atom_Encoding); procedure Set_Newline (Output : in out Printer; Newline : in Newline_Encoding); + + type Stream_Printer (Stream : access Ada.Streams.Root_Stream_Type'Class) is + limited new Printers.Printer with private; + private - type Printer (Stream : access Ada.Streams.Root_Stream_Type'Class) is - new Printers.Printer with record + type Printer is abstract limited new Printers.Printer with record Param : Parameters; Cursor : Screen_Column := 1; Previous : Entity; First : Boolean := True; Indent_Level : Screen_Offset := 0; @@ -134,7 +141,14 @@ Hex_Casing => Encodings.Upper, -- unused Quoted_Escape => Octal_Escape, -- unused Char_Encoding => ASCII, -- unused Fallback => Verbatim, Newline => LF); -- unused + + type Stream_Printer (Stream : access Ada.Streams.Root_Stream_Type'Class) is + new Printer with null record; + + overriding procedure Write_Raw + (Output : in out Stream_Printer; + Data : in Ada.Streams.Stream_Element_Array); end Natools.S_Expressions.Printers.Pretty; Index: tests/natools-s_expressions-printers-pretty-tests.adb ================================================================== --- tests/natools-s_expressions-printers-pretty-tests.adb +++ tests/natools-s_expressions-printers-pretty-tests.adb @@ -43,11 +43,11 @@ Expected : in Atom) is begin declare Input, Output : aliased Test_Tools.Memory_Stream; Parser : Parsers.Stream_Parser (Input'Access); - Pretty_Printer : Printer (Output'Access); + Pretty_Printer : Stream_Printer (Output'Access); begin Input.Set_Data (Expected); Output.Set_Expected (Expected); Pretty_Printer.Set_Parameters (Param); Parser.Next; @@ -137,11 +137,11 @@ Fallback => Hexadecimal, Newline => LF); begin declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Output.Set_Expected (To_Atom ("(" & Latin_1.LF & " #303132" & Latin_1.LF & " 333435" & Latin_1.LF & " 3637#)")); @@ -156,11 +156,11 @@ Param.Fallback := Base64; declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Output.Set_Expected (To_Atom ("(" & Latin_1.LF & " | YWJj" & Latin_1.LF & " REVG" & Latin_1.LF & " Z2hp" & Latin_1.LF @@ -182,11 +182,11 @@ procedure Basic_Printing (Report : in out NT.Reporter'Class) is Test : NT.Test := Report.Item ("Basic printing"); begin declare Output : aliased Test_Tools.Memory_Stream; - P : Printer (Output'Access); + P : Stream_Printer (Output'Access); begin Output.Set_Expected (To_Atom ("(7:command(6:subarg)3:arg)3:end")); P.Set_Parameters (Canonical); P.Open_List; @@ -259,13 +259,13 @@ procedure Newline_Formats (Report : in out NT.Reporter'Class) is Test : NT.Test := Report.Item ("Newline formats"); - procedure Print (Pr : in out Printer); + procedure Print (Pr : in out Stream_Printer); - procedure Print (Pr : in out Printer) is + procedure Print (Pr : in out Stream_Printer) is begin Pr.Open_List; Pr.Append_Atom (To_Atom ("begin")); Pr.Append_Atom (To_Atom ("quoted" & Latin_1.CR & Latin_1.LF & Latin_1.CR & "str")); @@ -289,11 +289,11 @@ begin Param.Newline_At (Atom_Data, Atom_Data) := True; declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Pr.Set_Parameters (Param); Output.Set_Expected (To_Atom ("(begin" & Latin_1.CR & " ""quot\" & Latin_1.CR @@ -306,11 +306,11 @@ Param.Newline := LF; declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Pr.Set_Parameters (Param); Output.Set_Expected (To_Atom ("(begin" & Latin_1.LF & " ""quot\" & Latin_1.LF @@ -322,11 +322,11 @@ Param.Newline := CR_LF; declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Pr.Set_Parameters (Param); Output.Set_Expected (To_Atom ("(begin" & Latin_1.CR & Latin_1.LF & " ""quot\" & Latin_1.CR & Latin_1.LF @@ -338,11 +338,11 @@ Param.Newline := LF_CR; declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Pr.Set_Parameters (Param); Output.Set_Expected (To_Atom ("(begin" & Latin_1.LF & Latin_1.CR & " ""quot\" & Latin_1.LF & Latin_1.CR @@ -387,11 +387,11 @@ Fallback => Hexadecimal, Newline => CR_LF); begin declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Pr.Set_Parameters (Initial); Pr.Set_Width (Final.Width); Pr.Set_Newline_At (Final.Newline_At); @@ -462,11 +462,11 @@ Fallback => Hexadecimal, Newline => CR_LF); begin declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin -- Check that the first quoted string encoding is exactly as long as -- fallback (hexadecimal) encoding, by trying with one less char. Output.Set_Expected (Encodings.Hex_Atom_Begin @@ -478,11 +478,11 @@ Output.Check_Stream (Test); end; declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Output.Set_Expected (To_Atom ("""Special: \b\t\n\v\f\r\\\""\x00" & "UTF-8 sequences: \xC3\xA9, \xE2\x88\x92, \xF0\x9F\x81\xA1, " & "\xF9\x88\xB4\x95\xA7, \xFD\xB6\x95\x83\x88\x90" @@ -498,11 +498,11 @@ Param.Char_Encoding := Latin; Param.Hex_Casing := Encodings.Lower; declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Output.Set_Expected (To_Atom ("""Special: \b\t\n\v\f\r\\\""\x00" & "UTF-8 sequences: " & Character'Val (16#C3#) & Character'Val (16#A9#) @@ -533,11 +533,11 @@ Param.Char_Encoding := UTF_8; Param.Quoted_Escape := Octal_Escape; declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Output.Set_Expected (To_Atom ("""Special: \b\t\n\v\f\r\\\""\000") & Source (18 .. 62) & To_Atom ("Invalid UTF-8 sequences: " & "\252, \303, \342\210, \360\237\201, " @@ -551,11 +551,11 @@ Param.Width := 31; declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Output.Set_Expected (To_Atom ("""Special: \b\t\n\v\f\r\\\""\000" & '\' & Latin_1.CR & Latin_1.LF) & Source (18 .. 62) & To_Atom ('\' & Latin_1.CR & Latin_1.LF @@ -573,13 +573,13 @@ when Error : others => Test.Report_Exception (Error); end Quoted_String_Escapes; procedure Separators (Report : in out NT.Reporter'Class) is - procedure Test_Exp (Pr : in out Printer); + procedure Test_Exp (Pr : in out Stream_Printer); - procedure Test_Exp (Pr : in out Printer) is + procedure Test_Exp (Pr : in out Stream_Printer) is begin Pr.Append_Atom (To_Atom ("begin")); Pr.Open_List; Pr.Open_List; Pr.Close_List; @@ -594,11 +594,11 @@ Test : NT.Test := Report.Item ("Separators"); Param : Parameters := Canonical; begin declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Output.Set_Expected (To_Atom ("5:begin(()(4:head4:tail))3:end")); Pr.Set_Parameters (Param); Test_Exp (Pr); Output.Check_Stream (Test); @@ -606,11 +606,11 @@ Param.Space_At := (others => (others => True)); declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Output.Set_Expected (To_Atom ("5:begin ( ( ) ( 4:head 4:tail ) ) 3:end")); Pr.Set_Parameters (Param); Test_Exp (Pr); @@ -620,11 +620,11 @@ Param.Newline_At := (others => (others => True)); Param.Newline := LF; declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Output.Set_Expected (To_Atom ("5:begin" & Latin_1.LF & '(' & Latin_1.LF & '(' & Latin_1.LF & ')' & Latin_1.LF @@ -647,11 +647,11 @@ Test : NT.Test := Report.Item ("Token separation"); Token : constant Atom := To_Atom ("token"); begin declare Output : aliased Test_Tools.Memory_Stream; - Pr : Printer (Output'Access); + Pr : Stream_Printer (Output'Access); begin Output.Set_Expected (To_Atom ("(begin(token ""quoted\n""token token #4865780A#token " & "|QmFzZS02NAo=|token)end)")); Pr.Set_Parameters