------------------------------------------------------------------------------
-- Copyright (c) 2014, 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.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Parsers;
with Natools.S_Expressions.Test_Tools;
with Natools.S_Expressions.Templates.Integers;
with Natools.Static_Maps.S_Expressions.Templates.Integers.T;

package body Natools.S_Expressions.Templates.Tests.Integers is

   procedure Test_Render
     (Test : in out NT.Test;
      Defaults : in Templates.Integers.Format;
      Template : in String;
      Value : in Integer;
      Expected : in String);
   procedure Test_Render
     (Test : in out NT.Test;
      Template : in String;
      Value : in Integer;
      Expected : in String);
      --  Run Template with Value and compare the result with Expected

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Test_Render
     (Test : in out NT.Test;
      Template : in String;
      Value : in Integer;
      Expected : in String)
   is
      Input : aliased Test_Tools.Memory_Stream;
      Output : Test_Tools.Memory_Stream;
      Parser : Parsers.Stream_Parser (Input'Access);
   begin
      Input.Set_Data (To_Atom (Template));
      Parser.Next;
      Output.Set_Expected (To_Atom (Expected));
      Templates.Integers.Render (Output, Parser, Value);
      Output.Check_Stream (Test);
   end Test_Render;

   procedure Test_Render
     (Test : in out NT.Test;
      Defaults : in Templates.Integers.Format;
      Template : in String;
      Value : in Integer;
      Expected : in String)
   is
      Input : aliased Test_Tools.Memory_Stream;
      Output : Test_Tools.Memory_Stream;
      Parser : Parsers.Stream_Parser (Input'Access);
   begin
      Input.Set_Data (To_Atom (Template));
      Parser.Next;
      Output.Set_Expected (To_Atom (Expected));
      Templates.Integers.Render (Output, Defaults, Parser, Value);
      Output.Check_Stream (Test);
   end Test_Render;

   -------------------------
   -- Complete Test Suite --
   -------------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Alignment (Report);
      Default_Format (Report);
      Explicit_Images (Report);
      Explicit_Sign (Report);
      Hexadecimal (Report);
      Overflow (Report);
      Parse_Errors (Report);
      Static_Hash_Map (Report);
      Explicit_Default_Format (Report);
      Prefix_And_Suffix (Report);
   end All_Tests;

   -----------------------
   -- Inidividual Tests --
   -----------------------

   procedure Alignment (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Debug instantiation");
   begin
      Test_Render (Test, "(width 5)", 0, "    0");
      Test_Render (Test, "(width 5)(padding _)(align center)", 10, "_10__");
      Test_Render (Test, "(width 5 10)(left-align)", 7, "7    ");
      Test_Render (Test, "(min-width 5)(right-align)", 2, "    2");
      Test_Render (Test, "(width 5)(padding > <)(centered)", 4, ">>4<<");
      Test_Render
        (Test,
         "(width 5)(left-padding ""["")(right-padding ""]"")(centered)",
         126,
         "[126]");
      Test_Render (Test, "(width 3)(centered)", 16, "16 ");
      Test_Render (Test, "(width 3)(centered)", 456, "456");
      Test_Render (Test, "(width 3)(align left)", 567, "567");
      Test_Render (Test, "(width 3)(align right)", 678, "678");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Alignment;

   procedure Default_Format (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Debug instantiation");
   begin
      Test_Render (Test, "", 42, "42");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Default_Format;

   procedure Explicit_Default_Format (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Client-provided default format");
   begin
      declare
         Default : Templates.Integers.Format;
      begin
         Default.Set_Minimum_Width (2);
         Default.Set_Left_Padding (To_Atom ("0"));

         Test_Render (Test, Default, "", 5, "05");
         Test_Render (Test, Default, "", 12, "12");
         Test_Render (Test, Default, "(padding 1: )", 7, " 7");
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Explicit_Default_Format;

   procedure Explicit_Images (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Explicit images in template");
   begin
      Test_Render (Test, "(image (-2 two) (666 evil))", 10, "10");
      Test_Render (Test, "(image (-2 two) (666 evil))", -2, "two");
      Test_Render (Test, "(image (-2 two) (666 evil))", 666, "evil");
      Test_Render (Test, "(image (-2 two) (666 evil) (-2))", -2, "-2");
      Test_Render (Test, "(image (1 one))3:Two4:four", 1, "one");
      Test_Render (Test, "(image (1 one))3:Two4:four", 2, "Two");
      Test_Render (Test, "(image (1 one))3:Two4:four", 3, "four");
      Test_Render (Test, "(image (1 one))3:Two4:four", 4, "4");
      Test_Render (Test, "(image (invalid -))5:first", Integer'First, "first");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Explicit_Images;

   procedure Explicit_Sign (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Explicit sign specification");
   begin
      Test_Render (Test, "(sign +)", 42, "+42");
      Test_Render (Test, "(sign + _)", 42, "+42");
      Test_Render (Test, "(sign + _)", -42, "_42");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Explicit_Sign;

   procedure Hexadecimal (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Hexadecimal representation");
      Hex_Spec : constant String
        := "(base 0 1 2 3 4 5 6 7 8 9 A B C D E F)";
   begin
      Test_Render (Test, Hex_Spec, 8, "8");
      Test_Render (Test, Hex_Spec, 16#BEE#, "BEE");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Hexadecimal;

   procedure Overflow (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Width overflow");
   begin
      Test_Render (Test, "(width 3)", 10_000, "");
      Test_Render (Test, "(max-width 4)", 10_000, "");
      Test_Render (Test, "(max-width 3 ""[...]"")", 10_000, "[...]");
      Test_Render (Test, "(width 2 3 ...)", 10_000, "...");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Overflow;

   procedure Parse_Errors (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parse errors in template");
   begin
      Test_Render (Test, "(invalid-command)", 1, "1");
      Test_Render (Test, "(align)", 2, "2");
      Test_Render (Test, "(align invalid)", 3, "3");
      Test_Render (Test, "(padding)", 4, "4");
      Test_Render (Test, "(left-padding)", 5, "5");
      Test_Render (Test, "(right-padding)", 6, "6");
      Test_Render (Test, "(signs)", 7, "7");
      Test_Render (Test, "(width)", 8, "8");
      Test_Render (Test, "(max-width)", 9, "9");
      Test_Render (Test, "(min-width)", 10, "10");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Parse_Errors;

   procedure Prefix_And_Suffix (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parse errors in template");
      Ordinal : constant String
        := "(suffix 1:? (th (0 31)) (st 1 21 31) (nd 2 22) (rd 3 23) (0: 0))";
   begin
      declare
         Format : Templates.Integers.Format;
      begin
         Format.Set_Prefix ((0, 9), To_Atom ("a"));
         Format.Set_Prefix ((-99, -10), To_Atom ("b"));
         Format.Set_Prefix ((50, 99), To_Atom ("c"));
         Format.Set_Prefix (0, To_Atom ("d"));
         Format.Set_Prefix (-10, To_Atom ("e"));
         Format.Set_Prefix (5, To_Atom ("f"));
         Format.Set_Prefix ((7, 52), To_Atom ("g"));
         Format.Set_Prefix ((-52, -49), To_Atom ("h"));
         Format.Set_Prefix ((-100, -90), To_Atom ("i"));
         Format.Remove_Prefix (8);

         Test_Render (Test, Format, "", -196, "-196");
         Test_Render (Test, Format, "", -101, "-101");
         Test_Render (Test, Format, "", -100, "i-100");
         Test_Render (Test, Format, "", -90, "i-90");
         Test_Render (Test, Format, "", -89, "b-89");
         Test_Render (Test, Format, "", -53, "b-53");
         Test_Render (Test, Format, "", -52, "h-52");
         Test_Render (Test, Format, "", -49, "h-49");
         Test_Render (Test, Format, "", -48, "b-48");
         Test_Render (Test, Format, "", -11, "b-11");
         Test_Render (Test, Format, "", -10, "e-10");
         Test_Render (Test, Format, "", -9, "-9");
         Test_Render (Test, Format, "", -1, "-1");
         Test_Render (Test, Format, "", 0, "d0");
         Test_Render (Test, Format, "", 1, "a1");
         Test_Render (Test, Format, "", 4, "a4");
         Test_Render (Test, Format, "", 5, "f5");
         Test_Render (Test, Format, "", 6, "a6");
         Test_Render (Test, Format, "", 7, "g7");
         Test_Render (Test, Format, "", 8, "8");
         Test_Render (Test, Format, "", 9, "g9");
         Test_Render (Test, Format, "", 52, "g52");
         Test_Render (Test, Format, "", 53, "c53");
         Test_Render (Test, Format, "", 99, "c99");
         Test_Render (Test, Format, "", 100, "100");
         Test_Render (Test, Format, "", 192, "192");
      end;

      declare
         Format : Templates.Integers.Format;
      begin
         Format.Set_Suffix ((0, 10), To_Atom ("th"));
         Format.Set_Suffix (1, To_Atom ("st"));
         Format.Remove_Suffix (0);

         Test_Render (Test, Format, "", -1, "-1");
         Test_Render (Test, Format, "", 0, "0");
         Test_Render (Test, Format, "", 1, "1st");
         Test_Render (Test, Format, "", 4, "4th");
         Test_Render (Test, Format, "", 10, "10th");
      end;

      Test_Render (Test, Ordinal, -1, "-1?");
      Test_Render (Test, Ordinal, 0, "0");
      Test_Render (Test, Ordinal, 1, "1st");
      Test_Render (Test, Ordinal, 2, "2nd");
      Test_Render (Test, Ordinal, 3, "3rd");
      Test_Render (Test, Ordinal, 4, "4th");

      Test_Render (Test, "(prefix (a) (b invalid (9 5)))", 0, "0");
      Test_Render (Test, "(prefix (c (invalid 5) (-1 invalid)))", 0, "0");
      Test_Render (Test, "(prefix (d ((invalid) 5) (-1)) ())", 0, "0");

      declare
         Format : Templates.Integers.Format;
      begin
         Format.Set_Minimum_Width (10);
         Format.Set_Suffix (1, To_Atom ("er"), 2);
         Format.Set_Prefix (10, To_Atom ("dix : "));

         Test_Render (Test, Format, "", 5, "         5");
         Test_Render (Test, Format, "", 1, "       1er");
         Test_Render (Test, Format, "(centered)", 10, " dix : 10 ");
         Test_Render (Test, Format, "(suffix ((th 0) 7))", 7, "         7th");
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Prefix_And_Suffix;

   procedure Static_Hash_Map (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parse errors in template");
   begin
      if not Natools.Static_Maps.S_Expressions.Templates.Integers.T then
         Test.Fail;
      end if;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Static_Hash_Map;

end Natools.S_Expressions.Templates.Tests.Integers;

------------------------------------------------------------------------------
-- Copyright (c) 2014, 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.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Parsers;
with Natools.S_Expressions.Test_Tools;
with Natools.S_Expressions.Templates.Integers;
with Natools.Static_Maps.S_Expressions.Templates.Integers.T;

package body Natools.S_Expressions.Templates.Tests.Integers is

   procedure Test_Render
     (Test : in out NT.Test;
      Defaults : in Templates.Integers.Format;
      Template : in String;
      Value : in Integer;
      Expected : in String);
   procedure Test_Render
     (Test : in out NT.Test;
      Template : in String;
      Value : in Integer;
      Expected : in String);
      --  Run Template with Value and compare the result with Expected

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Test_Render
     (Test : in out NT.Test;
      Template : in String;
      Value : in Integer;
      Expected : in String)
   is
      Input : aliased Test_Tools.Memory_Stream;
      Output : Test_Tools.Memory_Stream;
      Parser : Parsers.Stream_Parser (Input'Access);
   begin
      Input.Set_Data (To_Atom (Template));
      Parser.Next;
      Output.Set_Expected (To_Atom (Expected));
      Templates.Integers.Render (Output, Parser, Value);
      Output.Check_Stream (Test);
   end Test_Render;

   procedure Test_Render
     (Test : in out NT.Test;
      Defaults : in Templates.Integers.Format;
      Template : in String;
      Value : in Integer;
      Expected : in String)
   is
      Input : aliased Test_Tools.Memory_Stream;
      Output : Test_Tools.Memory_Stream;
      Parser : Parsers.Stream_Parser (Input'Access);
   begin
      Input.Set_Data (To_Atom (Template));
      Parser.Next;
      Output.Set_Expected (To_Atom (Expected));
      Templates.Integers.Render (Output, Defaults, Parser, Value);
      Output.Check_Stream (Test);
   end Test_Render;

   -------------------------
   -- Complete Test Suite --
   -------------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Alignment (Report);
      Default_Format (Report);
      Explicit_Images (Report);
      Explicit_Sign (Report);
      Hexadecimal (Report);
      Overflow (Report);
      Parse_Errors (Report);
      Static_Hash_Map (Report);
      Explicit_Default_Format (Report);
      Prefix_And_Suffix (Report);
   end All_Tests;

   -----------------------
   -- Inidividual Tests --
   -----------------------

   procedure Alignment (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Debug instantiation");
   begin
      Test_Render (Test, "(width 5)", 0, "    0");
      Test_Render (Test, "(width 5)(padding _)(align center)", 10, "_10__");
      Test_Render (Test, "(width 5 10)(left-align)", 7, "7    ");
      Test_Render (Test, "(min-width 5)(right-align)", 2, "    2");
      Test_Render (Test, "(width 5)(padding > <)(centered)", 4, ">>4<<");
      Test_Render
        (Test,
         "(width 5)(left-padding ""["")(right-padding ""]"")(centered)",
         126,
         "[126]");
      Test_Render (Test, "(width 3)(centered)", 16, "16 ");
      Test_Render (Test, "(width 3)(centered)", 456, "456");
      Test_Render (Test, "(width 3)(align left)", 567, "567");
      Test_Render (Test, "(width 3)(align right)", 678, "678");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Alignment;

   procedure Default_Format (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Debug instantiation");
   begin
      Test_Render (Test, "", 42, "42");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Default_Format;

   procedure Explicit_Default_Format (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Client-provided default format");
   begin
      declare
         Default : Templates.Integers.Format;
      begin
         Default.Set_Minimum_Width (2);
         Default.Set_Left_Padding (To_Atom ("0"));

         Test_Render (Test, Default, "", 5, "05");
         Test_Render (Test, Default, "", 12, "12");
         Test_Render (Test, Default, "(padding 1: )", 7, " 7");
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Explicit_Default_Format;

   procedure Explicit_Images (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Explicit images in template");
   begin
      Test_Render (Test, "(image (-2 two) (666 evil))", 10, "10");
      Test_Render (Test, "(image (-2 two) (666 evil))", -2, "two");
      Test_Render (Test, "(image (-2 two) (666 evil))", 666, "evil");
      Test_Render (Test, "(image (-2 two) (666 evil) (-2))", -2, "-2");
      Test_Render (Test, "(image (1 one))3:Two4:four", 1, "one");
      Test_Render (Test, "(image (1 one))3:Two4:four", 2, "Two");
      Test_Render (Test, "(image (1 one))3:Two4:four", 3, "four");
      Test_Render (Test, "(image (1 one))3:Two4:four", 4, "4");
      Test_Render (Test, "(image (invalid -))5:first", Integer'First, "first");
      Test_Render (Test, "(image-range (""?"" (10 19)))", 9, "9");
      Test_Render (Test, "(image-range (""?"" (10 19)))", 10, "?");
      Test_Render (Test, "(image-range (""?"" (10 19)))", 15, "?");
      Test_Render (Test, "(image-range (""?"" (10 19)))", 19, "?");
      Test_Render (Test, "(image-range (""?"" (10 19)))", 20, "20");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Explicit_Images;

   procedure Explicit_Sign (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Explicit sign specification");
   begin
      Test_Render (Test, "(sign +)", 42, "+42");
      Test_Render (Test, "(sign + _)", 42, "+42");
      Test_Render (Test, "(sign + _)", -42, "_42");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Explicit_Sign;

   procedure Hexadecimal (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Hexadecimal representation");
      Hex_Spec : constant String
        := "(base 0 1 2 3 4 5 6 7 8 9 A B C D E F)";
   begin
      Test_Render (Test, Hex_Spec, 8, "8");
      Test_Render (Test, Hex_Spec, 16#BEE#, "BEE");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Hexadecimal;

   procedure Overflow (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Width overflow");
   begin
      Test_Render (Test, "(width 3)", 10_000, "");
      Test_Render (Test, "(max-width 4)", 10_000, "");
      Test_Render (Test, "(max-width 3 ""[...]"")", 10_000, "[...]");
      Test_Render (Test, "(width 2 3 ...)", 10_000, "...");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Overflow;

   procedure Parse_Errors (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parse errors in template");
   begin
      Test_Render (Test, "(invalid-command)", 1, "1");
      Test_Render (Test, "(align)", 2, "2");
      Test_Render (Test, "(align invalid)", 3, "3");
      Test_Render (Test, "(padding)", 4, "4");
      Test_Render (Test, "(left-padding)", 5, "5");
      Test_Render (Test, "(right-padding)", 6, "6");
      Test_Render (Test, "(signs)", 7, "7");
      Test_Render (Test, "(width)", 8, "8");
      Test_Render (Test, "(max-width)", 9, "9");
      Test_Render (Test, "(min-width)", 10, "10");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Parse_Errors;

   procedure Prefix_And_Suffix (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parse errors in template");
      Ordinal : constant String
        := "(suffix 1:? (th (0 31)) (st 1 21 31) (nd 2 22) (rd 3 23) (0: 0))";
   begin
      declare
         Format : Templates.Integers.Format;
      begin
         Format.Set_Prefix ((0, 9), To_Atom ("a"));
         Format.Set_Prefix ((-99, -10), To_Atom ("b"));
         Format.Set_Prefix ((50, 99), To_Atom ("c"));
         Format.Set_Prefix (0, To_Atom ("d"));
         Format.Set_Prefix (-10, To_Atom ("e"));
         Format.Set_Prefix (5, To_Atom ("f"));
         Format.Set_Prefix ((7, 52), To_Atom ("g"));
         Format.Set_Prefix ((-52, -49), To_Atom ("h"));
         Format.Set_Prefix ((-100, -90), To_Atom ("i"));
         Format.Remove_Prefix (8);

         Test_Render (Test, Format, "", -196, "-196");
         Test_Render (Test, Format, "", -101, "-101");
         Test_Render (Test, Format, "", -100, "i-100");
         Test_Render (Test, Format, "", -90, "i-90");
         Test_Render (Test, Format, "", -89, "b-89");
         Test_Render (Test, Format, "", -53, "b-53");
         Test_Render (Test, Format, "", -52, "h-52");
         Test_Render (Test, Format, "", -49, "h-49");
         Test_Render (Test, Format, "", -48, "b-48");
         Test_Render (Test, Format, "", -11, "b-11");
         Test_Render (Test, Format, "", -10, "e-10");
         Test_Render (Test, Format, "", -9, "-9");
         Test_Render (Test, Format, "", -1, "-1");
         Test_Render (Test, Format, "", 0, "d0");
         Test_Render (Test, Format, "", 1, "a1");
         Test_Render (Test, Format, "", 4, "a4");
         Test_Render (Test, Format, "", 5, "f5");
         Test_Render (Test, Format, "", 6, "a6");
         Test_Render (Test, Format, "", 7, "g7");
         Test_Render (Test, Format, "", 8, "8");
         Test_Render (Test, Format, "", 9, "g9");
         Test_Render (Test, Format, "", 52, "g52");
         Test_Render (Test, Format, "", 53, "c53");
         Test_Render (Test, Format, "", 99, "c99");
         Test_Render (Test, Format, "", 100, "100");
         Test_Render (Test, Format, "", 192, "192");
      end;

      declare
         Format : Templates.Integers.Format;
      begin
         Format.Set_Suffix ((0, 10), To_Atom ("th"));
         Format.Set_Suffix (1, To_Atom ("st"));
         Format.Remove_Suffix (0);

         Test_Render (Test, Format, "", -1, "-1");
         Test_Render (Test, Format, "", 0, "0");
         Test_Render (Test, Format, "", 1, "1st");
         Test_Render (Test, Format, "", 4, "4th");
         Test_Render (Test, Format, "", 10, "10th");
      end;

      Test_Render (Test, Ordinal, -1, "-1?");
      Test_Render (Test, Ordinal, 0, "0");
      Test_Render (Test, Ordinal, 1, "1st");
      Test_Render (Test, Ordinal, 2, "2nd");
      Test_Render (Test, Ordinal, 3, "3rd");
      Test_Render (Test, Ordinal, 4, "4th");

      Test_Render (Test, "(prefix (a) (b invalid (9 5)))", 0, "0");
      Test_Render (Test, "(prefix (c (invalid 5) (-1 invalid)))", 0, "0");
      Test_Render (Test, "(prefix (d ((invalid) 5) (-1)) ())", 0, "0");

      declare
         Format : Templates.Integers.Format;
      begin
         Format.Set_Minimum_Width (10);
         Format.Set_Suffix (1, To_Atom ("er"), 2);
         Format.Set_Prefix (10, To_Atom ("dix : "));

         Test_Render (Test, Format, "", 5, "         5");
         Test_Render (Test, Format, "", 1, "       1er");
         Test_Render (Test, Format, "(centered)", 10, " dix : 10 ");
         Test_Render (Test, Format, "(suffix ((th 0) 7))", 7, "         7th");
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Prefix_And_Suffix;

   procedure Static_Hash_Map (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parse errors in template");
   begin
      if not Natools.Static_Maps.S_Expressions.Templates.Integers.T then
         Test.Fail;
      end if;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Static_Hash_Map;

end Natools.S_Expressions.Templates.Tests.Integers;

add tests for image ranges

s_expressions-templates-tests-integers: add tests for image ranges


with Interfaces.C; use Interfaces.C;
with Mysql.Mysql;  use Mysql.Mysql;

package Mysql.Time is
   pragma Preelaborate;

   --  Copyright (C) 2004 MySQL AB
   --  This program is free software; you can redistribute it and/or modify
   --  it under the terms of the GNU General Public License as published by
   --  the Free Software Foundation; version 2 of the License.
   --  This program is distributed in the hope that it will be useful,
   --  but WITHOUT ANY WARRANTY; without even the implied warranty of
   --  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   --  GNU General Public License for more details.
   --  You should have received a copy of the GNU General Public License
   --  along with this program; if not, write to the Free Software
   --  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

   --  Time declarations shared between the server and client API:
   --  you should not add anything to this header unless it's used
   --  (and hence should be visible) in mysql.h.
   --  If you're looking for a place to add new time-related declaration,
   --  it's most likely my_time.h. See also "C API Handling of Date
   --  and Time Values" chapter in documentation.
   --

   subtype enum_mysql_timestamp_type is unsigned;
   MYSQL_TIMESTAMP_NONE : constant enum_mysql_timestamp_type := -2;
   MYSQL_TIMESTAMP_ERROR : constant enum_mysql_timestamp_type := -1;
   MYSQL_TIMESTAMP_DATE : constant enum_mysql_timestamp_type := 0;
   MYSQL_TIMESTAMP_DATETIME : constant enum_mysql_timestamp_type := 1;
   MYSQL_TIMESTAMP_TIME : constant enum_mysql_timestamp_type := 2;

   --  Structure which is used to represent datetime values inside MySQL.
   --  We assume that values in this structure are normalized, i.e. year <= 9999,
   --  month <= 12, day <= 31, hour <= 23, hour <= 59, hour <= 59. Many functions
   --  in server such as my_system_gmt_sec() or make_time() family of functions
   --  rely on this (actually now usage of make_*() family relies on a bit weaker
   --  restriction). Also functions that produce MYSQL_TIME as result ensure this.
   --  There is one exception to this rule though if this structure holds time
   --  value (time_type == MYSQL_TIMESTAMP_TIME) days and hour member can hold
   --  bigger values.
   --

   type st_mysql_time is record
      year : aliased unsigned;
      month : aliased unsigned;
      day : aliased unsigned;
      hour : aliased unsigned;
      minute : aliased unsigned;
      second : aliased unsigned;
      second_part : aliased unsigned_long;
      neg : aliased my_bool;
      time_type : aliased enum_mysql_timestamp_type;
   end record;
   pragma Convention (C, st_mysql_time);

   subtype MYSQL_TIME is st_mysql_time;

end Mysql.Time;

with Interfaces.C; use Interfaces.C;
with Mysql.Mysql;  use Mysql.Mysql;

package Mysql.Time is
   pragma Preelaborate;

   --  Copyright (C) 2004 MySQL AB
   --  This program is free software; you can redistribute it and/or modify
   --  it under the terms of the GNU General Public License as published by
   --  the Free Software Foundation; version 2 of the License.
   --  This program is distributed in the hope that it will be useful,
   --  but WITHOUT ANY WARRANTY; without even the implied warranty of
   --  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   --  GNU General Public License for more details.
   --  You should have received a copy of the GNU General Public License
   --  along with this program; if not, write to the Free Software
   --  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

   --  Time declarations shared between the server and client API:
   --  you should not add anything to this header unless it's used
   --  (and hence should be visible) in mysql.h.
   --  If you're looking for a place to add new time-related declaration,
   --  it's most likely my_time.h. See also "C API Handling of Date
   --  and Time Values" chapter in documentation.
   --

   subtype enum_mysql_timestamp_type is unsigned;
   MYSQL_TIMESTAMP_NONE : constant enum_mysql_timestamp_type := 16#fffffffe#;
   MYSQL_TIMESTAMP_ERROR : constant enum_mysql_timestamp_type := 16#ffffffff#;
   MYSQL_TIMESTAMP_DATE : constant enum_mysql_timestamp_type := 0;
   MYSQL_TIMESTAMP_DATETIME : constant enum_mysql_timestamp_type := 1;
   MYSQL_TIMESTAMP_TIME : constant enum_mysql_timestamp_type := 2;

   --  Structure which is used to represent datetime values inside MySQL.
   --  We assume that values in this structure are normalized, i.e. year <= 9999,
   --  month <= 12, day <= 31, hour <= 23, hour <= 59, hour <= 59. Many functions
   --  in server such as my_system_gmt_sec() or make_time() family of functions
   --  rely on this (actually now usage of make_*() family relies on a bit weaker
   --  restriction). Also functions that produce MYSQL_TIME as result ensure this.
   --  There is one exception to this rule though if this structure holds time
   --  value (time_type == MYSQL_TIMESTAMP_TIME) days and hour member can hold
   --  bigger values.
   --

   type st_mysql_time is record
      year : aliased unsigned;
      month : aliased unsigned;
      day : aliased unsigned;
      hour : aliased unsigned;
      minute : aliased unsigned;
      second : aliased unsigned;
      second_part : aliased unsigned_long;
      neg : aliased my_bool;
      time_type : aliased enum_mysql_timestamp_type;
   end record;
   pragma Convention (C, st_mysql_time);

   subtype MYSQL_TIME is st_mysql_time;

end Mysql.Time;

Fix compilation warning that was not detected for several years!


-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  Copyright (C) 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Policies.Roles");

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Role_Policy) return String is
      pragma Unreferenced (From);
   begin
      return "role";
   end Get_Name;

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Set_Reader_Config (Policy : in out Role_Policy;
                                Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Set_Reader_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  Copyright (C) 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Policies.Roles");

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Role_Policy) return String is
      pragma Unreferenced (From);
   begin
      return "role";
   end Get_Name;

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

Rename Set_Reader_Config into Prepare_Config


------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2015, AdaCore                           --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of STMicroelectronics nor the names of its       --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

--  This file provides declarations for devices on the STM32F7 Discovery kits
--  manufactured by ST Microelectronics.

with STM32.Device;  use STM32.Device;

with STM32.GPIO;    use STM32.GPIO;
--  with STM32.SPI;     use STM32.SPI;
with STM32.ADC;     use STM32.ADC;
with STM32.FMC;     use STM32.FMC;

with Ada.Interrupts.Names;  use Ada.Interrupts;

use STM32;  -- for base addresses

package STM32.Board is
   pragma Elaborate_Body;

   subtype User_LED is GPIO_Point;

   Green : User_LED renames PI1;

   All_LEDs  : constant GPIO_Points := (1 => Green);
   LCH_LED   : constant User_LED := Green;

   procedure Initialize_LEDs;
   --  MUST be called prior to any use of the LEDs

   procedure Turn_On (This : User_LED)
     renames STM32.GPIO.Set;
   procedure Turn_Off (This : User_LED)
     renames STM32.GPIO.Clear;

   procedure All_LEDs_Off with Inline;
   procedure All_LEDs_On  with Inline;
   procedure Toggle_LEDs (These : GPIO_Points)
     renames STM32.GPIO.Toggle;

   --  GPIO Pins for FMC

   FMC_A : constant GPIO_Points :=
             (PF0, PF1, PF2, PF3, PF4, PF5, PF12, PF13, PF14, PF15, PG0, PG1);

   FMC_D : constant GPIO_Points :=
             (PD14, PD15, PD0, PD1, PE7, PE8, PE9, PE10,
              PE11, PE12, PE13, PE14, PE15, PD8, PD9, PD10);

   FMC_SDNWE     : GPIO_Point renames PH5;
   FMC_SDNRAS    : GPIO_Point renames PF11;
   FMC_SDNCAS    : GPIO_Point renames PG15;
   FMC_SDCLK     : GPIO_Point renames PG8;
   FMC_BA0       : GPIO_Point renames PG4;
   FMC_BA1       : GPIO_Point renames PG5;
   FMC_SDNE0     : GPIO_Point renames PH3;
   FMC_SDCKE0    : GPIO_Point renames PC3;
   FMC_NBL0      : GPIO_Point renames PE0;
   FMC_NBL1      : GPIO_Point renames PE1;

   SDRAM_PINS    : constant GPIO_Points :=
                     FMC_A & FMC_D & FMC_SDNWE & FMC_SDNRAS & FMC_SDNCAS &
                     FMC_SDCLK & FMC_BA0 & FMC_BA1 & FMC_SDNE0 & FMC_SDCKE0 &
                     FMC_NBL0 & FMC_NBL1;

   --  SDRAM CONFIGURATION Parameters
   SDRAM_Base         : constant := 16#C0000000#;
   SDRAM_Size         : constant := 16#800000#;
   SDRAM_Bank         : constant STM32.FMC.FMC_SDRAM_Cmd_Target_Bank :=
                          STM32.FMC.FMC_Bank1_SDRAM;
   SDRAM_Mem_Width    : constant STM32.FMC.FMC_SDRAM_Memory_Bus_Width :=
                          STM32.FMC.FMC_SDMemory_Width_16b;
   SDRAM_Row_Bits     : constant STM32.FMC.FMC_SDRAM_Row_Address_Bits :=
                          STM32.FMC.FMC_RowBits_Number_12b;
   SDRAM_CAS_Latency  : constant STM32.FMC.FMC_SDRAM_CAS_Latency :=
                          STM32.FMC.FMC_CAS_Latency_2;
   SDRAM_CLOCK_Period : constant STM32.FMC.FMC_SDRAM_Clock_Configuration :=
                          STM32.FMC.FMC_SDClock_Period_2;
   SDRAM_Read_Burst   : constant STM32.FMC.FMC_SDRAM_Burst_Read :=
                          STM32.FMC.FMC_Read_Burst_Disable;
   SDRAM_Read_Pipe    : constant STM32.FMC.FMC_SDRAM_Read_Pipe_Delay :=
                          STM32.FMC.FMC_ReadPipe_Delay_0;
   SDRAM_Refresh_Cnt  : constant := 1539;

   ------------------------
   --  GPIO Pins for LCD --
   ------------------------

   LCD_BL_CTRL   : GPIO_Point renames PK3;
   LCD_ENABLE    : GPIO_Point renames PI12;

   LCD_HSYNC     : GPIO_Point renames PI10;
   LCD_VSYNC     : GPIO_Point renames PI9;
   LCD_CLK       : GPIO_Point renames PI14;
   LCD_DE        : GPIO_Point renames PK7;
   LCD_INT       : GPIO_Point renames PI13;

   LCD_SDA       : GPIO_Point renames PH8;
   LCD_SCL       : GPIO_Point renames PH7;
   NC1           : GPIO_Point renames PI8;

   LCD_CTRL_PINS : constant GPIO_Points :=
                     (LCD_VSYNC, LCD_HSYNC, LCD_INT,
                      LCD_CLK, LCD_DE, NC1);
   LCD_RGB_AF14  : constant GPIO_Points :=
                     (PI15, PJ0, PJ1, PJ2, PJ3, PJ4, PJ5, PJ6, --  Red
                      PJ7, PJ8, PJ9, PJ10, PJ11, PK0, PK1, PK2, --  Green
                      PE4, PJ13, PJ14, PJ15, PK4, PK5, PK6); --  Blue
   LCD_RGB_AF9   : constant GPIO_Points :=
                     (1 => PG12); -- B4

   TP_Pins : constant GPIO_Points := (LCD_SDA, LCD_SCL);

   --  User button

   User_Button_Point     : GPIO_Point renames PA0;
   User_Button_Interrupt : constant Interrupt_Id := Names.EXTI0_Interrupt;

   procedure Configure_User_Button_GPIO;
   --  Configures the GPIO port/pin for the blue user button. Sufficient
   --  for polling the button, and necessary for having the button generate
   --  interrupts.

end STM32.Board;

------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2015, AdaCore                           --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of STMicroelectronics nor the names of its       --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

--  This file provides declarations for devices on the STM32F7 Discovery kits
--  manufactured by ST Microelectronics.

with STM32.Device;  use STM32.Device;

with STM32.GPIO;    use STM32.GPIO;
--  with STM32.SPI;     use STM32.SPI;
with STM32.ADC;     use STM32.ADC;
with STM32.FMC;     use STM32.FMC;

with Ada.Interrupts.Names;  use Ada.Interrupts;

use STM32;  -- for base addresses

package STM32.Board is
   pragma Elaborate_Body;

   subtype User_LED is GPIO_Point;

   Green : User_LED renames PI1;

   All_LEDs  : constant GPIO_Points := (1 => Green);
   LCH_LED   : constant User_LED := Green;

   procedure Initialize_LEDs;
   --  MUST be called prior to any use of the LEDs

   procedure Turn_On (This : User_LED)
     renames STM32.GPIO.Set;
   procedure Turn_Off (This : User_LED)
     renames STM32.GPIO.Clear;

   procedure All_LEDs_Off with Inline;
   procedure All_LEDs_On  with Inline;
   procedure Toggle_LEDs (These : GPIO_Points)
     renames STM32.GPIO.Toggle;

   --  GPIO Pins for FMC

   FMC_A : constant GPIO_Points :=
             (PF0, PF1, PF2, PF3, PF4, PF5, PF12, PF13, PF14, PF15, PG0, PG1);

   FMC_D : constant GPIO_Points :=
             (PD14, PD15, PD0, PD1, PE7, PE8, PE9, PE10,
              PE11, PE12, PE13, PE14, PE15, PD8, PD9, PD10);

   FMC_SDNWE     : GPIO_Point renames PH5;
   FMC_SDNRAS    : GPIO_Point renames PF11;
   FMC_SDNCAS    : GPIO_Point renames PG15;
   FMC_SDCLK     : GPIO_Point renames PG8;
   FMC_BA0       : GPIO_Point renames PG4;
   FMC_BA1       : GPIO_Point renames PG5;
   FMC_SDNE0     : GPIO_Point renames PH3;
   FMC_SDCKE0    : GPIO_Point renames PC3;
   FMC_NBL0      : GPIO_Point renames PE0;
   FMC_NBL1      : GPIO_Point renames PE1;

   SDRAM_PINS    : constant GPIO_Points :=
                     FMC_A & FMC_D & FMC_SDNWE & FMC_SDNRAS & FMC_SDNCAS &
                     FMC_SDCLK & FMC_BA0 & FMC_BA1 & FMC_SDNE0 & FMC_SDCKE0 &
                     FMC_NBL0 & FMC_NBL1;

   --  SDRAM CONFIGURATION Parameters
   SDRAM_Base         : constant := 16#C0000000#;
   SDRAM_Size         : constant := 16#800000#;
   SDRAM_Bank         : constant STM32.FMC.FMC_SDRAM_Cmd_Target_Bank :=
                          STM32.FMC.FMC_Bank1_SDRAM;
   SDRAM_Mem_Width    : constant STM32.FMC.FMC_SDRAM_Memory_Bus_Width :=
                          STM32.FMC.FMC_SDMemory_Width_16b;
   SDRAM_Row_Bits     : constant STM32.FMC.FMC_SDRAM_Row_Address_Bits :=
                          STM32.FMC.FMC_RowBits_Number_12b;
   SDRAM_CAS_Latency  : constant STM32.FMC.FMC_SDRAM_CAS_Latency :=
                          STM32.FMC.FMC_CAS_Latency_2;
   SDRAM_CLOCK_Period : constant STM32.FMC.FMC_SDRAM_Clock_Configuration :=
                          STM32.FMC.FMC_SDClock_Period_2;
   SDRAM_Read_Burst   : constant STM32.FMC.FMC_SDRAM_Burst_Read :=
                          STM32.FMC.FMC_Read_Burst_Disable;
   SDRAM_Read_Pipe    : constant STM32.FMC.FMC_SDRAM_Read_Pipe_Delay :=
                          STM32.FMC.FMC_ReadPipe_Delay_0;
   SDRAM_Refresh_Cnt  : constant := 1539;

   ------------------------
   --  GPIO Pins for LCD --
   ------------------------

   LCD_BL_CTRL   : GPIO_Point renames PK3;
   LCD_ENABLE    : GPIO_Point renames PI12;

   LCD_HSYNC     : GPIO_Point renames PI10;
   LCD_VSYNC     : GPIO_Point renames PI9;
   LCD_CLK       : GPIO_Point renames PI14;
   LCD_DE        : GPIO_Point renames PK7;
   LCD_INT       : GPIO_Point renames PI13;

   LCD_SDA       : GPIO_Point renames PH8;
   LCD_SCL       : GPIO_Point renames PH7;
   NC1           : GPIO_Point renames PI8;

   LCD_CTRL_PINS : constant GPIO_Points :=
                     (LCD_VSYNC, LCD_HSYNC, LCD_INT,
                      LCD_CLK, LCD_DE, NC1);
   LCD_RGB_AF14  : constant GPIO_Points :=
                     (PI15, PJ0, PJ1, PJ2, PJ3, PJ4, PJ5, PJ6, --  Red
                      PJ7, PJ8, PJ9, PJ10, PJ11, PK0, PK1, PK2, --  Green
                      PE4, PJ13, PJ14, PJ15, PK4, PK5, PK6); --  Blue
   LCD_RGB_AF9   : constant GPIO_Points :=
                     (1 => PG12); -- B4

   TP_Pins : constant GPIO_Points := (LCD_SDA, LCD_SCL);

   --  User button

   User_Button_Point     : GPIO_Point renames PI11;
   User_Button_Interrupt : constant Interrupt_Id := Names.EXTI15_10_Interrupt;

   procedure Configure_User_Button_GPIO;
   --  Configures the GPIO port/pin for the blue user button. Sufficient
   --  for polling the button, and necessary for having the button generate
   --  interrupts.

end STM32.Board;

Fix the user button definition for the STM32F7-Disco.


-----------------------------------------------------------------------
--  mat-formats - Format various types for the console or GUI interface
--  Copyright (C) 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Strings;
package body MAT.Formats is

   use type MAT.Types.Target_Tick_Ref;

   Hex_Prefix : Boolean := True;

   Conversion : constant String (1 .. 10) := "0123456789";

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      if Hex_Prefix then
         return "0x" & Hex;
      else
         return Hex;
      end if;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   --  ------------------------------
   --  Format the time relative to the start time.
   --  ------------------------------
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String is
      T    : constant MAT.Types.Target_Tick_Ref := Value - Start;
      Sec  : constant MAT.Types.Target_Tick_Ref := T / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := T mod 1_000_000;
      Msec : Natural := Natural (Usec / 1_000);
      Frac : String (1 .. 5);
   begin
      Frac (5) := 's';
      Frac (4) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (3) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (2) := Conversion (Msec mod 10 + 1);
      Frac (1) := '.';
      return MAT.Types.Target_Tick_Ref'Image (Sec) & Frac;
   end Time;

   --  ------------------------------
   --  Format the duration in seconds, milliseconds or microseconds.
   --  ------------------------------
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String is

      Sec  : constant MAT.Types.Target_Tick_Ref := Value / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := Value mod 1_000_000;
      Msec : constant Natural := Natural (Usec / 1_000);
      Val  : Natural;
      Frac : String (1 .. 5);
   begin
      if Sec = 0 and Msec = 0 then
         return Util.Strings.Image (Integer (Usec)) & "us";
      elsif Sec = 0 then
         Val := Natural (Usec mod 1_000);
         Frac (5) := 's';
         Frac (4) := 'm';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac;
      else
         Val := Msec;
         Frac (4) := 's';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Sec)) & Frac (1 .. 4);
      end if;
   end Duration;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  Format a file, line, function information into a string.
   --  ------------------------------
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item : in MAT.Events.Targets.Probe_Event_Type;
                   Mode : in Format_Type := NORMAL) return String is
      use type MAT.Types.Target_Addr;
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            if Mode = BRIEF then
               return "malloc";
            else
               return "malloc(" & Size (Item.Size) & ") = " & Addr (Item.Addr);
            end if;

         when MAT.Events.Targets.MSG_REALLOC =>
            if Mode = BRIEF then
               if Item.Old_Addr = 0 then
                  return "realloc";
               else
                  return "realloc";
               end if;
            else
               if Item.Old_Addr = 0 then
                  return "realloc(0," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               else
                  return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               end if;
            end if;

         when MAT.Events.Targets.MSG_FREE =>
            if Mode = BRIEF then
               return "free";
            else
               return "free(" & Addr (Item.Addr) & ")";
            end if;

         when MAT.Events.Targets.MSG_BEGIN =>
            return "begin";

         when MAT.Events.Targets.MSG_END =>
            return "end";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "library";

      end case;
   end Event;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Free_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Free_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_FREE);

      return Size (Item.Size) & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & ", freed " & Duration (Free_Event.Time - Item.Time)
        & " after by event" & MAT.Events.Targets.Event_Id_Type'Image (Free_Event.Id)
      ;

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes allocated (never freed)";

   end Event_Malloc;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Alloc_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Alloc_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_MALLOC);

      return Size (Alloc_Event.Size) & " bytes freed after " & Duration (Item.Time - Start_Time)
        & ", alloc'ed for " & Duration (Item.Time - Alloc_Event.Time)
        & " by event" & MAT.Events.Targets.Event_Id_Type'Image (Alloc_Event.Id);

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes freed";

   end Event_Free;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item       : in MAT.Events.Targets.Probe_Event_Type;
                   Related    : in MAT.Events.Targets.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String is
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            return Event_Malloc (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_REALLOC =>
            return Size (Item.Size) & " bytes reallocated";

         when MAT.Events.Targets.MSG_FREE =>
            return Event_Free (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_BEGIN =>
            return "Begin event";

         when MAT.Events.Targets.MSG_END =>
            return "End event";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "Library information event";

      end case;
   end Event;

end MAT.Formats;

-----------------------------------------------------------------------
--  mat-formats - Format various types for the console or GUI interface
--  Copyright (C) 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Strings;
package body MAT.Formats is

   use type MAT.Types.Target_Tick_Ref;

   Hex_Prefix : Boolean := True;

   Conversion : constant String (1 .. 10) := "0123456789";

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      if Hex_Prefix then
         return "0x" & Hex;
      else
         return Hex;
      end if;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   --  ------------------------------
   --  Format the time relative to the start time.
   --  ------------------------------
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String is
      T    : constant MAT.Types.Target_Tick_Ref := Value - Start;
      Sec  : constant MAT.Types.Target_Tick_Ref := T / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := T mod 1_000_000;
      Msec : Natural := Natural (Usec / 1_000);
      Frac : String (1 .. 5);
   begin
      Frac (5) := 's';
      Frac (4) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (3) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (2) := Conversion (Msec mod 10 + 1);
      Frac (1) := '.';
      return MAT.Types.Target_Tick_Ref'Image (Sec) & Frac;
   end Time;

   --  ------------------------------
   --  Format the duration in seconds, milliseconds or microseconds.
   --  ------------------------------
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String is

      Sec  : constant MAT.Types.Target_Tick_Ref := Value / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := Value mod 1_000_000;
      Msec : constant Natural := Natural (Usec / 1_000);
      Val  : Natural;
      Frac : String (1 .. 5);
   begin
      if Sec = 0 and Msec = 0 then
         return Util.Strings.Image (Integer (Usec)) & "us";
      elsif Sec = 0 then
         Val := Natural (Usec mod 1_000);
         Frac (5) := 's';
         Frac (4) := 'm';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac;
      else
         Val := Msec;
         Frac (4) := 's';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Sec)) & Frac (1 .. 4);
      end if;
   end Duration;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  Format a file, line, function information into a string.
   --  ------------------------------
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

   --  ------------------------------
   --  Format an event range description.
   --  ------------------------------
   function Event (First : in MAT.Events.Targets.Probe_Event_Type;
                   Last  : in MAT.Events.Targets.Probe_Event_Type) return String is
      use type MAT.Events.Targets.Event_Id_Type;

      Id1 : constant String := MAT.Events.Targets.Event_Id_Type'Image (First.Id);
      Id2 : constant String := MAT.Events.Targets.Event_Id_Type'Image (Last.Id);
   begin
      if First.Id = Last.Id then
         return Id1 (Id1'First + 1 .. Id1'Last);
      else
         return Id1 (Id1'First + 1 .. Id1'Last) & ".." & Id2 (Id2'First + 1 .. Id2'Last);
      end if;
   end Event;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item : in MAT.Events.Targets.Probe_Event_Type;
                   Mode : in Format_Type := NORMAL) return String is
      use type MAT.Types.Target_Addr;
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            if Mode = BRIEF then
               return "malloc";
            else
               return "malloc(" & Size (Item.Size) & ") = " & Addr (Item.Addr);
            end if;

         when MAT.Events.Targets.MSG_REALLOC =>
            if Mode = BRIEF then
               if Item.Old_Addr = 0 then
                  return "realloc";
               else
                  return "realloc";
               end if;
            else
               if Item.Old_Addr = 0 then
                  return "realloc(0," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               else
                  return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               end if;
            end if;

         when MAT.Events.Targets.MSG_FREE =>
            if Mode = BRIEF then
               return "free";
            else
               return "free(" & Addr (Item.Addr) & ")";
            end if;

         when MAT.Events.Targets.MSG_BEGIN =>
            return "begin";

         when MAT.Events.Targets.MSG_END =>
            return "end";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "library";

      end case;
   end Event;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Free_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Free_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_FREE);

      return Size (Item.Size) & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & ", freed " & Duration (Free_Event.Time - Item.Time)
        & " after by event" & MAT.Events.Targets.Event_Id_Type'Image (Free_Event.Id)
      ;

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes allocated (never freed)";

   end Event_Malloc;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Alloc_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Alloc_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_MALLOC);

      return Size (Alloc_Event.Size) & " bytes freed after " & Duration (Item.Time - Start_Time)
        & ", alloc'ed for " & Duration (Item.Time - Alloc_Event.Time)
        & " by event" & MAT.Events.Targets.Event_Id_Type'Image (Alloc_Event.Id);

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes freed";

   end Event_Free;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item       : in MAT.Events.Targets.Probe_Event_Type;
                   Related    : in MAT.Events.Targets.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String is
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            return Event_Malloc (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_REALLOC =>
            return Size (Item.Size) & " bytes reallocated";

         when MAT.Events.Targets.MSG_FREE =>
            return Event_Free (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_BEGIN =>
            return "Begin event";

         when MAT.Events.Targets.MSG_END =>
            return "End event";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "Library information event";

      end case;
   end Event;

end MAT.Formats;

Implement the Event function to print an event range


-----------------------------------------------------------------------
--  util-streams-encoders -- Streams with encoding and decoding capabilities
--  Copyright (C) 2017, 2019, 2021, 2022 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Encoders;

--  == Encoder Streams ==
--  The `Util.Streams.Buffered.Encoders` is a generic package which implements an
--  encoding or decoding stream through the `Transformer` interface.  The generic
--  package must be instantiated with a transformer type.  The stream passes the data
--  to be written to the `Transform` method of that interface and it makes
--  transformations on the data before being written.
--
--  The AES encoding stream is created as follows:
--
--   package Encoding is
--      new Util.Streams.Buffered.Encoders (Encoder => Util.Encoders.AES.Encoder);
--
--  and the AES decoding stream is created with:
--
--   package Decoding is
--      new Util.Streams.Buffered.Encoders (Encoder => Util.Encoders.AES.Decoder);
--
--     Encode : Util.Streams.Buffered.Encoders.Encoding_Stream;
--
--  The encoding stream manages a buffer that is used to hold the encoded data before it is
--  written to the target stream.  The `Initialize` procedure must be called to indicate
--  the target stream, the size of the buffer and the encoding format to be used.
--
--     Encode.Initialize (Output => File'Access, Size => 4096, Format => "base64");
--
generic
   type Encoder is limited new Util.Encoders.Transformer with private;
package Util.Streams.Buffered.Encoders is

   --  -----------------------
   --  Encoding stream
   --  -----------------------
   --  The Encoding_Stream is an output stream which uses an encoder to
   --  transform the data before writing it to the output.  The transformer can
   --  change the data by encoding it in Base64, Base16 or encrypting it.
   type Encoder_Stream is limited new Util.Streams.Buffered.Input_Output_Buffer_Stream
     with record
      Transform   : Encoder;
      Flushed     : Boolean := False;
   end record;

   --  Initialize the stream with a buffer of Size bytes.
   procedure Initialize (Stream  : in out Encoder_Stream;
                         Size    : in Positive);

   --  Initialize the stream to write on the given stream.
   --  An internal buffer is allocated for writing the stream.
   procedure Produces (Stream  : in out Encoder_Stream;
                       Output  : access Output_Stream'Class;
                       Size    : in Positive);

   --  Initialize the stream to read the given streams.
   procedure Consumes (Stream  : in out Encoder_Stream;
                       Input   : access Input_Stream'Class;
                       Size    : in Positive);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Encoder_Stream);

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Encoder_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Read into the buffer as many bytes as possible and return in
   --  `last` the position of the last byte read.
   overriding
   procedure Read (Stream : in out Encoder_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset);

   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   overriding
   procedure Flush (Stream : in out Encoder_Stream);

   overriding
   procedure Finalize (Stream : in out Encoder_Stream);

   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   procedure Fill (Stream : in out Encoder_Stream);

end Util.Streams.Buffered.Encoders;

-----------------------------------------------------------------------
--  util-streams-encoders -- Streams with encoding and decoding capabilities
--  Copyright (C) 2017, 2019, 2021, 2022 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Encoders;

--  == Encoder Streams ==
--  The `Util.Streams.Buffered.Encoders` is a generic package which implements an
--  encoding or decoding stream through the `Transformer` interface.  The generic
--  package must be instantiated with a transformer type.  The stream passes the data
--  to be written to the `Transform` method of that interface and it makes
--  transformations on the data before being written.
--
--  The AES encoding stream is created as follows:
--
--    package Encoding is
--      new Util.Streams.Buffered.Encoders (Encoder => Util.Encoders.AES.Encoder);
--
--  and the AES decoding stream is created with:
--
--    package Decoding is
--      new Util.Streams.Buffered.Encoders (Encoder => Util.Encoders.AES.Decoder);
--
--  The encoding stream instance is declared:
--
--      Encode : Util.Streams.Buffered.Encoders.Encoder_Stream;
--
--  The encoding stream manages a buffer that is used to hold the encoded data before it is
--  written to the target stream.  The `Initialize` procedure must be called to indicate
--  the target stream, the size of the buffer and the encoding format to be used.
--
--     Encode.Initialize (Output => File'Access, Size => 4096, Format => "base64");
--
--  The encoding stream provides a `Produces` procedure that reads the encoded
--  stream and write the result in another stream.  It also provides a `Consumes`
--  procedure that encodes a stream by reading its content and write the encoded
--  result to another stream.
generic
   type Encoder is limited new Util.Encoders.Transformer with private;
package Util.Streams.Buffered.Encoders is

   --  -----------------------
   --  Encoding stream
   --  -----------------------
   --  The Encoding_Stream is an output stream which uses an encoder to
   --  transform the data before writing it to the output.  The transformer can
   --  change the data by encoding it in Base64, Base16 or encrypting it.
   type Encoder_Stream is limited new Util.Streams.Buffered.Input_Output_Buffer_Stream
     with record
      Transform   : Encoder;
      Flushed     : Boolean := False;
   end record;

   --  Initialize the stream with a buffer of Size bytes.
   procedure Initialize (Stream  : in out Encoder_Stream;
                         Size    : in Positive);

   --  Initialize the stream to write on the given stream.
   --  An internal buffer is allocated for writing the stream.
   procedure Produces (Stream  : in out Encoder_Stream;
                       Output  : access Output_Stream'Class;
                       Size    : in Positive);

   --  Initialize the stream to read the given streams.
   procedure Consumes (Stream  : in out Encoder_Stream;
                       Input   : access Input_Stream'Class;
                       Size    : in Positive);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Encoder_Stream);

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Encoder_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Read into the buffer as many bytes as possible and return in
   --  `last` the position of the last byte read.
   overriding
   procedure Read (Stream : in out Encoder_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset);

   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   overriding
   procedure Flush (Stream : in out Encoder_Stream);

   overriding
   procedure Finalize (Stream : in out Encoder_Stream);

   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   procedure Fill (Stream : in out Encoder_Stream);

end Util.Streams.Buffered.Encoders;

Fix the documentation

Fix the documentation