ADDED tests/natools-s_expressions-test_tools.adb Index: tests/natools-s_expressions-test_tools.adb ================================================================== --- tests/natools-s_expressions-test_tools.adb +++ tests/natools-s_expressions-test_tools.adb @@ -0,0 +1,162 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +package body Natools.S_Expressions.Test_Tools is + + Hex_Digits : constant String := "0123456789ABCDEF"; + + function Encode_Hex (Value : Offset; Length : Positive) return String; + function Hex_Slice + (Address : Offset; + Address_Length : Positive; + Data : Atom; + Width : Positive) + return String; + + function Is_Printable (Data : Octet) return Boolean; + function Is_Printable (Data : Atom) return Boolean; + -- Return whether Data can be dumped directed as a String or Character + + + ------------------------------ + -- Local Helper Subprograms -- + ------------------------------ + + function Encode_Hex (Value : Offset; Length : Positive) return String is + I : Natural := Length; + Digit : Natural; + Current : Offset := Value; + begin + return Result : String (1 .. Length) := (others => '0') do + while Current /= 0 and I /= 0 loop + Digit := Natural (Current mod 16); + Result (I) := Hex_Digits (Hex_Digits'First + Digit); + I := I - 1; + Current := Current / 16; + end loop; + end return; + end Encode_Hex; + + + function Hex_Slice + (Address : Offset; + Address_Length : Positive; + Data : Atom; + Width : Positive) + return String + is + Total_Length : constant Positive + := Address_Length + 4 + 4 * Width; + Hex_Start : constant Positive := Address_Length + 2; + Raw_Start : constant Positive := Hex_Start + 3 * Width + 1; + Digit : Octet; + begin + return Result : String (1 .. Total_Length) := (others => ' ') do + Result (1 .. Address_Length) := Encode_Hex (Address, Address_Length); + + for I in 0 .. Width - 1 loop + exit when Data'First + Offset (I) not in Data'Range; + + Digit := Data (Data'First + Offset (I)); + + Result (Hex_Start + 3 * I) := Hex_Digits (Hex_Digits'First + + Natural (Digit / 16)); + Result (Hex_Start + 3 * I + 1) := Hex_Digits (Hex_Digits'First + + Natural (Digit mod 16)); + + if Is_Printable (Digit) then + Result (Raw_Start + I) := Character'Val (Digit); + else + Result (Raw_Start + I) := '.'; + end if; + end loop; + end return; + end Hex_Slice; + + + function Is_Printable (Data : Octet) return Boolean is + begin + return Data in 32 .. 127; + end Is_Printable; + + + function Is_Printable (Data : Atom) return Boolean is + begin + if Data'Length > 100 then + return False; + end if; + + for I in Data'Range loop + if not Is_Printable (Data (I)) then + return False; + end if; + end loop; + + return True; + end Is_Printable; + + + + ------------------ + -- Public Tools -- + ------------------ + + procedure Dump_Atom + (Report : in out NT.Reporter'Class; + Data : in Atom; + Label : in String := "") + is + I, Length : Offset := 0; + begin + if Is_Printable (Data) then + if Label'Length > 0 then + Report.Info (Label & ": """ & To_String (Data) & '"'); + else + Report.Info ('"' & To_String (Data) & '"'); + end if; + else + if Label'Length > 0 then + Report.Info + (Label & ": " & Natural'Image (Data'Length) & " octets"); + end if; + + while I < Data'Length loop + Length := Offset'Min (16, Data'Length - I); + Report.Info (Hex_Slice + (I, 8, + Data (Data'First + I .. Data'First + I + Length - 1), 16)); + I := I + 16; + end loop; + end if; + end Dump_Atom; + + + procedure Test_Atom + (Report : in out NT.Reporter'Class; + Test_Name : in String; + Expected : in Atom; + Found : in Atom) is + begin + if Found = Expected then + Report.Item (Test_Name, NT.Success); + else + Report.Item (Test_Name, NT.Fail); + Dump_Atom (Report, Found, "Found"); + Dump_Atom (Report, Expected, "Expected"); + end if; + end Test_Atom; + +end Natools.S_Expressions.Test_Tools; ADDED tests/natools-s_expressions-test_tools.ads Index: tests/natools-s_expressions-test_tools.ads ================================================================== --- tests/natools-s_expressions-test_tools.ads +++ tests/natools-s_expressions-test_tools.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.S_Expressions.Test_Tools provides tools used in S-expression -- +-- test suites. -- +------------------------------------------------------------------------------ + +with Natools.Tests; + +package Natools.S_Expressions.Test_Tools is + pragma Preelaborate (Test_Tools); + + package NT renames Natools.Tests; + + procedure Dump_Atom + (Report : in out NT.Reporter'Class; + Data : in Atom; + Label : in String := ""); + -- Dump contents on Data as info in Report + + procedure Test_Atom + (Report : in out NT.Reporter'Class; + Test_Name : in String; + Expected : in Atom; + Found : in Atom); + -- Report success when Found is equal to Expected, and failure + -- with diagnostics otherwise. + +end Natools.S_Expressions.Test_Tools;