-----------------------------------------------------------------------
--  asf.requests.tools -- ASF Requests Tools
--  Copyright (C) 2010 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.Transforms;
package body ASF.Requests.Tools is

   --  ------------------------------
   --  Builds a printable representation of the request for debugging purposes.
   --  When Html is true, the returned content contains an HTML presentation.
   --  ------------------------------
   function To_String (Req              : in Request'Class;
                       Html             : in Boolean := False;
                       Print_Headers    : in Boolean := True;
                       Print_Attributes : in Boolean := False) return String is

      procedure Put (Title : in String; Value : in String);
      procedure Put (Name  : in String; Value : in EL.Objects.Object);
      procedure Append_Html (Content : in String);
      pragma Inline (Append_Html);

      Info : Unbounded_String;

      procedure Append_Html (Content : in String) is
      begin
         if Html then
            Append (Info, Content);
         end if;
      end Append_Html;

      procedure Put (Title : in String;
                     Value : in String) is
      begin
         if Html then
            Append (Info, "
");
            Util.Strings.Transforms.Escape_Xml (Content => Title,
                                                Into    => Info);
            Append (Info, "	");
            Util.Strings.Transforms.Escape_Xml (Content => Value,
                                                Into    => Info);
            Append (Info, "
");
         else
            Append (Info, Title);
            Append (Info, ": ");
            Append (Info, Value);
            Append (Info, ASCII.LF);
         end if;
      end Put;

      procedure Put (Name  : in String;
                     Value : in EL.Objects.Object) is
      begin
         Put (Title => Name, Value => EL.Objects.To_String (Value));
      end Put;

   begin
      Append_Html ("

"
                   & "

Request
");
      Append (Info, ASCII.LF);
      Put ("     URI", Req.Get_Request_URI);
      Put ("    Peer", Req.Get_Remote_Host);
      Put ("Protocol", Req.Get_Protocol);
      Put ("  Method", Req.Get_Method);
      Put ("   Query", Req.Get_Query_String);
      Append_Html ("

");

      if Print_Headers then
         Append_Html ("

"
                      & "
Headers
");
         Req.Iterate_Headers (Process => Put'Access);
         Append_Html ("

");
      end if;

      if Print_Attributes then
         Append_Html ("

"
                      & "
Attributes
");
         Req.Iterate_Attributes (Process => Put'Access);
         Append_Html ("

");
      end if;

      Append_Html ("
");
      return To_String (Info);
   end To_String;

   --  ------------------------------
   --  Set the internal context associated with a request:
   --

   --
The servlet that processes the request,
   --
The response associated with the request
   --  </ul/
   --  ------------------------------
   procedure Set_Context (Req      : in out Request'Class;
                          Servlet  : access ASF.Servlets.Servlet'Class;
                          Response : in ASF.Responses.Response_Access) is
   begin
      Req.Servlet := Servlet;
      Req.Info.Response := Response;
   end Set_Context;

end ASF.Requests.Tools;

-----------------------------------------------------------------------
--  asf.requests.tools -- ASF Requests Tools
--  Copyright (C) 2010, 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.Transforms;
package body ASF.Requests.Tools is

   --  ------------------------------
   --  Builds a printable representation of the request for debugging purposes.
   --  When Html is true, the returned content contains an HTML presentation.
   --  ------------------------------
   function To_String (Req              : in Request'Class;
                       Html             : in Boolean := False;
                       Print_Headers    : in Boolean := True;
                       Print_Attributes : in Boolean := False) return String is

      procedure Put (Title : in String; Value : in String);
      procedure Put (Name  : in String; Value : in EL.Objects.Object);
      procedure Append_Html (Content : in String);
      pragma Inline (Append_Html);

      Info : Unbounded_String;

      procedure Append_Html (Content : in String) is
      begin
         if Html then
            Append (Info, Content);
         end if;
      end Append_Html;

      procedure Put (Title : in String;
                     Value : in String) is
      begin
         if Html then
            Append (Info, "
");
            Util.Strings.Transforms.Escape_Xml (Content => Title,
                                                Into    => Info);
            Append (Info, "	");
            Util.Strings.Transforms.Escape_Xml (Content => Value,
                                                Into    => Info);
            Append (Info, "
");
         else
            Append (Info, Title);
            Append (Info, ": ");
            Append (Info, Value);
            Append (Info, ASCII.LF);
         end if;
      end Put;

      procedure Put (Name  : in String;
                     Value : in EL.Objects.Object) is
      begin
         Put (Title => Name, Value => EL.Objects.To_String (Value));
      end Put;

   begin
      Append_Html ("

"
                   & "

Request
");
      Append (Info, ASCII.LF);
      Put ("     URI", Req.Get_Request_URI);
      Put ("    Peer", Req.Get_Remote_Host);
      Put ("Protocol", Req.Get_Protocol);
      Put ("  Method", Req.Get_Method);
      Put ("   Query", Req.Get_Query_String);
      Append_Html ("

");

      if Print_Headers then
         Append_Html ("

"
                      & "
Headers
");
         Req.Iterate_Headers (Process => Put'Access);
         Append_Html ("

");
      end if;

      if Print_Attributes then
         Append_Html ("

"
                      & "
Attributes
");
         Req.Iterate_Attributes (Process => Put'Access);
         Append_Html ("

");
      end if;

      Append_Html ("
");
      return To_String (Info);
   end To_String;

   --  ------------------------------
   --  Set the internal context associated with a request:
   --

   --
The servlet that processes the request,
   --
The response associated with the request
   --  </ul/
   --  ------------------------------
   procedure Set_Context (Req      : in out Request'Class;
                          Response : in ASF.Responses.Response_Access;
                          Context  : access ASF.Routes.Route_Context_Type) is
   begin
      Req.Context := Context;
      Req.Info.Response := Response;
   end Set_Context;

end ASF.Requests.Tools;

Update the Set_Context procedure to store the route context type


-----------------------------------------------------------------------
--  mat-events-tools - Profiler Events Description
--  Copyright (C) 2014, 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.
-----------------------------------------------------------------------
package body MAT.Events.Tools is

   --  ------------------------------
   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   --  ------------------------------
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Target_Event_Type is
      Iter  : Target_Event_Cursor := List.First;
      Event : Target_Event_Type;
   begin
      while Target_Event_Vectors.Has_Element (Iter) loop
         Event := Target_Event_Vectors.Element (Iter);
         if Event.Index = Kind then
            return Event;
         end if;
         Target_Event_Vectors.Next (Iter);
      end loop;
      raise Not_Found;
   end Find;

   function "<" (Left, Right : in Frame_Key_Type) return Boolean is
   begin
      if Left.Addr < Right.Addr then
         return True;
      elsif Left.Addr > Right.Addr then
         return False;
      else
         return Left.Level < Right.Level;
      end if;
   end "<";

   --  ------------------------------
   --  Collect statistics information about events.
   --  ------------------------------
   procedure Collect_Info (Into  : in out Event_Info_Type;
                           Event : in MAT.Events.Target_Event_Type) is
   begin
      Into.Last_Event := Event;
      if Event.Event = 2 then
         Into.Malloc_Count := Into.Malloc_Count + 1;
         Into.Alloc_Size := Into.Alloc_Size + Event.Size;

      elsif Event.Event = 3 then
         Into.Realloc_Count := Into.Realloc_Count + 1;
         Into.Alloc_Size := Into.Alloc_Size + Event.Size;
         Into.Free_Size := Into.Free_Size + Event.Old_Size;

      elsif Event.Event = 4 then
         Into.Free_Count := Into.Free_Count + 1;
         Into.Free_Size := Into.Free_Size + Event.Size;
      end if;
   end Collect_Info;

   --  ------------------------------
   --  Extract from the frame info map, the list of event info sorted on the count.
   --  ------------------------------
   procedure Build_Event_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector) is

      function "<" (Left, Right : in Event_Info_Type) return Boolean is
      begin
         return Left.Count < Right.Count;
      end "<";

      package Sort_Event_Info is new Event_Info_Vectors.Generic_Sorting;
      Iter : Frame_Event_Info_Cursor := Map.First;
      Item : Event_Info_Type;
   begin
      while Frame_Event_Info_Maps.Has_Element (Iter) loop
         Item := Frame_Event_Info_Maps.Element (Iter);
         List.Append (Item);
         Frame_Event_Info_Maps.Next (Iter);
      end loop;
      Sort_Event_Info.Sort (List);
   end Build_Event_Info;

   --  ------------------------------
   --  Extract from the frame info map, the list of frame event info sorted
   --  on the frame level and slot size.
   --  ------------------------------
   procedure Build_Frame_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Frame_Info_Vector) is

      function "<" (Left, Right : in Frame_Info_Type) return Boolean;

      function "<" (Left, Right : in Frame_Info_Type) return Boolean is
      begin
         if Left.Key.Level < Right.Key.Level then
            return True;
         else
            return False;
         end if;
      end "<";

      package Sort_Frame_Info is new Frame_Info_Vectors.Generic_Sorting;

      Iter : Frame_Event_Info_Cursor := Map.First;
      Item : Frame_Info_Type;
   begin
      while Frame_Event_Info_Maps.Has_Element (Iter) loop
         Item.Key  := Frame_Event_Info_Maps.Key (Iter);
         Item.Info := Frame_Event_Info_Maps.Element (Iter);
         List.Append (Item);
         Frame_Event_Info_Maps.Next (Iter);
      end loop;
      Sort_Frame_Info.Sort (List);
   end Build_Frame_Info;

end MAT.Events.Tools;

-----------------------------------------------------------------------
--  mat-events-tools - Profiler Events Description
--  Copyright (C) 2014, 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.
-----------------------------------------------------------------------
package body MAT.Events.Tools is

   --  ------------------------------
   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   --  ------------------------------
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Target_Event_Type is
      Iter  : Target_Event_Cursor := List.First;
      Event : Target_Event_Type;
   begin
      while Target_Event_Vectors.Has_Element (Iter) loop
         Event := Target_Event_Vectors.Element (Iter);
         if Event.Index = Kind then
            return Event;
         end if;
         Target_Event_Vectors.Next (Iter);
      end loop;
      raise Not_Found;
   end Find;

   function "<" (Left, Right : in Frame_Key_Type) return Boolean is
   begin
      if Left.Addr < Right.Addr then
         return True;
      elsif Left.Addr > Right.Addr then
         return False;
      else
         return Left.Level < Right.Level;
      end if;
   end "<";

   --  ------------------------------
   --  Collect statistics information about events.
   --  ------------------------------
   procedure Collect_Info (Into  : in out Event_Info_Type;
                           Event : in MAT.Events.Target_Event_Type) is
   begin
      Into.Count := Into.Count + 1;
      Into.Last_Event := Event;
      if Event.Index = MAT.Events.MSG_MALLOC then
         Into.Malloc_Count := Into.Malloc_Count + 1;
         Into.Alloc_Size := Into.Alloc_Size + Event.Size;

      elsif Event.Index = MAT.Events.MSG_REALLOC then
         Into.Realloc_Count := Into.Realloc_Count + 1;
         Into.Alloc_Size := Into.Alloc_Size + Event.Size;
         Into.Free_Size := Into.Free_Size + Event.Old_Size;

      elsif Event.Index = MAT.Events.MSG_FREE then
         Into.Free_Count := Into.Free_Count + 1;
         Into.Free_Size := Into.Free_Size + Event.Size;
      end if;
   end Collect_Info;

   --  ------------------------------
   --  Extract from the frame info map, the list of event info sorted on the count.
   --  ------------------------------
   procedure Build_Event_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector) is

      function "<" (Left, Right : in Event_Info_Type) return Boolean is
      begin
         return Left.Count < Right.Count;
      end "<";

      package Sort_Event_Info is new Event_Info_Vectors.Generic_Sorting;
      Iter : Frame_Event_Info_Cursor := Map.First;
      Item : Event_Info_Type;
   begin
      while Frame_Event_Info_Maps.Has_Element (Iter) loop
         Item := Frame_Event_Info_Maps.Element (Iter);
         List.Append (Item);
         Frame_Event_Info_Maps.Next (Iter);
      end loop;
      Sort_Event_Info.Sort (List);
   end Build_Event_Info;

   --  ------------------------------
   --  Extract from the frame info map, the list of frame event info sorted
   --  on the frame level and slot size.
   --  ------------------------------
   procedure Build_Frame_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Frame_Info_Vector) is

      function "<" (Left, Right : in Frame_Info_Type) return Boolean;

      function "<" (Left, Right : in Frame_Info_Type) return Boolean is
      begin
         if Left.Key.Level < Right.Key.Level then
            return True;
         else
            return False;
         end if;
      end "<";

      package Sort_Frame_Info is new Frame_Info_Vectors.Generic_Sorting;

      Iter : Frame_Event_Info_Cursor := Map.First;
      Item : Frame_Info_Type;
   begin
      while Frame_Event_Info_Maps.Has_Element (Iter) loop
         Item.Key  := Frame_Event_Info_Maps.Key (Iter);
         Item.Info := Frame_Event_Info_Maps.Element (Iter);
         List.Append (Item);
         Frame_Event_Info_Maps.Next (Iter);
      end loop;
      Sort_Frame_Info.Sort (List);
   end Build_Frame_Info;

end MAT.Events.Tools;

Use the enum values MAT.Events.MSG_FREE/MALLOC/REALLOC


-----------------------------------------------------------------------
--  serialize-io-json-tests -- Unit tests for JSON parser
--  Copyright (C) 2011 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.Test_Caller;
with Util.Log.Loggers;

package body Util.Serialize.IO.JSON.Tests is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.JSON");

   package Caller is new Util.Test_Caller (Test, "Serialize.IO.JSON");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse errors)",
                       Test_Parse_Error'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse Ok)",
                       Test_Parser'Access);
   end Add_Tests;

   --  ------------------------------
   --  Check various JSON parsing errors.
   --  ------------------------------
   procedure Test_Parse_Error (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse_Error (Content : in String);

      procedure Check_Parse_Error (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);
         Log.Error ("No exception raised for: {0}", Content);

      exception
         when Parse_Error =>
            null;
      end Check_Parse_Error;

   begin
      Check_Parse_Error ("{ ""person"":23");
      Check_Parse_Error ("{ person: 23]");
      Check_Parse_Error ("[ }");
      Check_Parse_Error ("{[]}");
      Check_Parse_Error ("{");
      Check_Parse_Error ("{[");
      Check_Parse_Error ("{ ""person");
      Check_Parse_Error ("{ ""person"":");
      Check_Parse_Error ("{ ""person"":""asf");
      Check_Parse_Error ("{ ""person"":""asf""");
      Check_Parse_Error ("{ ""person"":""asf"",");
   end Test_Parse_Error;

   --  ------------------------------
   --  Check various (basic) JSON valid strings (no mapper).
   --  ------------------------------
   procedure Test_Parser (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse (Content : in String);

      procedure Check_Parse (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);

      exception
         when Parse_Error =>
            Log.Error ("Parse error for: " & Content);
            raise;
      end Check_Parse;

   begin
      Check_Parse ("{ ""person"":23}");
      Check_Parse ("{ }");
      Check_Parse ("{""person"":""asf""}");
      Check_Parse ("{""person"":""asf"",""age"":""2""}");
   end Test_Parser;

end Util.Serialize.IO.JSON.Tests;

-----------------------------------------------------------------------
--  serialize-io-json-tests -- Unit tests for JSON parser
--  Copyright (C) 2011 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.Test_Caller;
with Util.Log.Loggers;

package body Util.Serialize.IO.JSON.Tests is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.JSON");

   package Caller is new Util.Test_Caller (Test, "Serialize.IO.JSON");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse errors)",
                       Test_Parse_Error'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse Ok)",
                       Test_Parser'Access);
   end Add_Tests;

   --  ------------------------------
   --  Check various JSON parsing errors.
   --  ------------------------------
   procedure Test_Parse_Error (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse_Error (Content : in String);

      procedure Check_Parse_Error (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);
         Log.Error ("No exception raised for: {0}", Content);

      exception
         when Parse_Error =>
            null;
      end Check_Parse_Error;

   begin
      Check_Parse_Error ("{ ""person"":23");
      Check_Parse_Error ("{ person: 23]");
      Check_Parse_Error ("[ }");
      Check_Parse_Error ("{[]}");
      Check_Parse_Error ("{");
      Check_Parse_Error ("{[");
      Check_Parse_Error ("{ ""person");
      Check_Parse_Error ("{ ""person"":");
      Check_Parse_Error ("{ ""person"":""asf");
      Check_Parse_Error ("{ ""person"":""asf""");
      Check_Parse_Error ("{ ""person"":""asf"",");
      Check_Parse_Error ("{ ""person"":""\uze""}");
      Check_Parse_Error ("{ ""person"":""\u012-""}");
      Check_Parse_Error ("{ ""person"":""\u012G""}");
   end Test_Parse_Error;

   --  ------------------------------
   --  Check various (basic) JSON valid strings (no mapper).
   --  ------------------------------
   procedure Test_Parser (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse (Content : in String);

      procedure Check_Parse (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);

      exception
         when Parse_Error =>
            Log.Error ("Parse error for: " & Content);
            raise;
      end Check_Parse;

   begin
      Check_Parse ("{ ""person"":23}");
      Check_Parse ("{ }");
      Check_Parse ("{""person"":""asf""}");
      Check_Parse ("{""person"":""asf"",""age"":""2""}");
      Check_Parse ("{ ""person"":""\u0123""}");
      Check_Parse ("{ ""person"":""\u4567""}");
      Check_Parse ("{ ""person"":""\u89ab""}");
      Check_Parse ("{ ""person"":""\ucdef""}");
      Check_Parse ("{ ""person"":""\u1CDE""}");
      Check_Parse ("{ ""person"":""\u2ABF""}");
   end Test_Parser;

end Util.Serialize.IO.JSON.Tests;

Add unit tests for some JSON \u sequences


-----------------------------------------------------------------------
--  applications.messages -- Application Messages
--  Copyright (C) 2010 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 Ada.Strings.Unbounded;
package ASF.Applications.Messages is

   type Severity is (NONE, INFO, WARN, ERROR, FATAL);

   --  ------------------------------
   --  Application message
   --  ------------------------------
   type Message is private;

   --  Return the message severity level.
   function Get_Severity (Msg : in Message) return Severity;

   --  Sets the message severity level.
   procedure Set_Severity (Msg  : in out Message;
                           Kind : in Severity);

   --  Return the localized message summary.
   function Get_Summary (Msg : in Message) return String;

   --  Sets the localized message summary.
   procedure Set_Summary (Msg     : in out Message;
                          Summary : in String);

   --  Return the localized message detail.  If the message detail was
   --  not provided, returns the message summary.
   function Get_Detail (Msg : in Message) return String;

   --  Sets the localized message detail.
   procedure Set_Detail (Msg    : in out Message;
                         Detail : in String);

   --  Returns true if both messages are identical (same severity, same messages)
   function "=" (Left, Right : in Message) return Boolean;

private

   type Message is record
      Kind      : Severity;
      Summary   : Ada.Strings.Unbounded.Unbounded_String;
      Detail    : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end ASF.Applications.Messages;

-----------------------------------------------------------------------
--  applications.messages -- Application Messages
--  Copyright (C) 2010 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 Ada.Strings.Unbounded;
package ASF.Applications.Messages is

   type Severity is (NONE, INFO, WARN, ERROR, FATAL);

   --  ------------------------------
   --  Application message
   --  ------------------------------
   type Message is private;

   --  Return the message severity level.
   function Get_Severity (Msg : in Message) return Severity;

   --  Sets the message severity level.
   procedure Set_Severity (Msg  : in out Message;
                           Kind : in Severity);

   --  Return the localized message summary.
   function Get_Summary (Msg : in Message) return String;

   --  Sets the localized message summary.
   procedure Set_Summary (Msg     : in out Message;
                          Summary : in String);

   --  Return the localized message detail.  If the message detail was
   --  not provided, returns the message summary.
   function Get_Detail (Msg : in Message) return String;

   --  Sets the localized message detail.
   procedure Set_Detail (Msg    : in out Message;
                         Detail : in String);

   --  Returns true if both messages are identical (same severity, same messages)
   function "=" (Left, Right : in Message) return Boolean;

private

   type Message is record
      Kind      : Severity := ERROR;
      Summary   : Ada.Strings.Unbounded.Unbounded_String;
      Detail    : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end ASF.Applications.Messages;

Set the default severity to ERROR

Set the default severity to ERROR


-----------------------------------------------------------------------
--  gen-xmi-tests -- Tests for xmi
--  Copyright (C) 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 Ada.Strings.Unbounded;

with Util.Test_Caller;
with Gen.Generator;
package body Gen.Artifacts.XMI.Tests is

   use Ada.Strings.Unbounded;

   package Caller is new Util.Test_Caller (Test, "Gen.XMI");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Gen.XMI.Read_UML_Configuration",
                       Test_Read_XMI'Access);
      Caller.Add_Test (Suite, "Test Gen.XMI.Find_Element",
                       Test_Find_Element'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the XMI files defines in the Dynamo UML configuration repository.
   --  ------------------------------
   procedure Test_Read_XMI (T : in out Test) is
      procedure Check (Namespace : in String;
                       Name      : in String;
                       Id        : in String);

      A : Artifact;
      G : Gen.Generator.Handler;
      C : constant String := Util.Tests.Get_Parameter ("config_dir", "config");

      use type Gen.Model.XMI.Model_Element_Access;

      procedure Check (Namespace : in String;
                       Name      : in String;
                       Id        : in String) is
         Empty  : Gen.Model.XMI.Model_Map.Map;
         XMI_Id : constant Unbounded_String := To_Unbounded_String (Namespace & "#" & Id);
         N      : constant Gen.Model.XMI.Model_Element_Access := Gen.Model.XMI.Find (A.Nodes,
                                                                                Empty,
                                                                                XMI_Id);
      begin
         T.Assert (N /= null, "Cannot find UML element " & To_String (XMI_Id));
         Util.Tests.Assert_Equals (T, Name, To_String (N.Name), "Invalid element name");
      end Check;

   begin
      Gen.Generator.Initialize (G, Ada.Strings.Unbounded.To_Unbounded_String (C), False);
      A.Read_UML_Configuration (G);

      --  ArgoUML Integer DataType
      Check ("default-uml14.xmi", "Integer",
             "-84-17--56-5-43645a83:11466542d86:-8000:000000000000087C");
      --  ArgoUML String DataType
      Check ("default-uml14.xmi", "String",
             "-84-17--56-5-43645a83:11466542d86:-8000:000000000000087E");
      --  ArgoUML documentation TagDefinition
      Check ("default-uml14.xmi", "documentation",
             ".:000000000000087C");
      --  ArgoUML type Stereotype
      Check ("default-uml14.xmi", "type",
             ".:0000000000000842");

      --  Persistence Table Stereotype
      Check ("Dynamo.xmi", "Table",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001D4F");
      Check ("Dynamo.xmi", "PK",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001D50");
      Check ("Dynamo.xmi", "FK",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001F70");
      Check ("Dynamo.xmi", "Bean",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001F72");

   end Test_Read_XMI;

   --  ------------------------------
   --  Test searching an XMI element by using a qualified name.
   --  ------------------------------
   procedure Test_Find_Element (T : in out Test) is
      A : Artifact;
      G : Gen.Generator.Handler;
      C : constant String := Util.Tests.Get_Parameter ("config_dir", "config");

      use Gen.Model.XMI;

      function Find_Stereotype is
        new Gen.Model.XMI.Find_Element (Element_Type        => Stereotype_Element,
                                        Element_Type_Access => Stereotype_Element_Access);

   begin
      Gen.Generator.Initialize (G, Ada.Strings.Unbounded.To_Unbounded_String (C), False);
      A.Read_UML_Configuration (G);

      declare
         S : Gen.Model.XMI.Stereotype_Element_Access;
      begin
         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.Table", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");
      end;
   end Test_Find_Element;

end Gen.Artifacts.XMI.Tests;

-----------------------------------------------------------------------
--  gen-xmi-tests -- Tests for xmi
--  Copyright (C) 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 Ada.Strings.Unbounded;

with Util.Test_Caller;
with Gen.Generator;
package body Gen.Artifacts.XMI.Tests is

   use Ada.Strings.Unbounded;

   package Caller is new Util.Test_Caller (Test, "Gen.XMI");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Gen.XMI.Read_UML_Configuration",
                       Test_Read_XMI'Access);
      Caller.Add_Test (Suite, "Test Gen.XMI.Find_Element",
                       Test_Find_Element'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the XMI files defines in the Dynamo UML configuration repository.
   --  ------------------------------
   procedure Test_Read_XMI (T : in out Test) is
      procedure Check (Namespace : in String;
                       Name      : in String;
                       Id        : in String);

      A : Artifact;
      G : Gen.Generator.Handler;
      C : constant String := Util.Tests.Get_Parameter ("config_dir", "config");

      use type Gen.Model.XMI.Model_Element_Access;

      procedure Check (Namespace : in String;
                       Name      : in String;
                       Id        : in String) is
         Empty  : Gen.Model.XMI.Model_Map.Map;
         XMI_Id : constant Unbounded_String := To_Unbounded_String (Namespace & "#" & Id);
         N      : constant Gen.Model.XMI.Model_Element_Access := Gen.Model.XMI.Find (A.Nodes,
                                                                                Empty,
                                                                                XMI_Id);
      begin
         T.Assert (N /= null, "Cannot find UML element " & To_String (XMI_Id));
         Util.Tests.Assert_Equals (T, Name, To_String (N.Name), "Invalid element name");
      end Check;

   begin
      Gen.Generator.Initialize (G, Ada.Strings.Unbounded.To_Unbounded_String (C), False);
      A.Read_UML_Configuration (G);

      --  ArgoUML Integer DataType
      Check ("default-uml14.xmi", "Integer",
             "-84-17--56-5-43645a83:11466542d86:-8000:000000000000087C");
      --  ArgoUML String DataType
      Check ("default-uml14.xmi", "String",
             "-84-17--56-5-43645a83:11466542d86:-8000:000000000000087E");
      --  ArgoUML documentation TagDefinition
      Check ("default-uml14.xmi", "documentation",
             ".:000000000000087C");
      --  ArgoUML type Stereotype
      Check ("default-uml14.xmi", "type",
             ".:0000000000000842");

      --  Persistence Table Stereotype
      Check ("Dynamo.xmi", "Table",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001D4F");
      Check ("Dynamo.xmi", "PK",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001D50");
      Check ("Dynamo.xmi", "FK",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001F70");
      Check ("Dynamo.xmi", "Bean",
             "127-0-1-1--44304ba0:139c0f2a59c:-8000:0000000000001F72");

   end Test_Read_XMI;

   --  ------------------------------
   --  Test searching an XMI element by using a qualified name.
   --  ------------------------------
   procedure Test_Find_Element (T : in out Test) is
      A : Artifact;
      G : Gen.Generator.Handler;
      C : constant String := Util.Tests.Get_Parameter ("config_dir", "config");

      use Gen.Model.XMI;

      function Find_Stereotype is
        new Gen.Model.XMI.Find_Element (Element_Type        => Stereotype_Element,
                                        Element_Type_Access => Stereotype_Element_Access);

   begin
      Gen.Generator.Initialize (G, Ada.Strings.Unbounded.To_Unbounded_String (C), False);
      A.Read_UML_Configuration (G);

      declare
         S : Gen.Model.XMI.Stereotype_Element_Access;
      begin
         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.Table", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.PK", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.FK", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "ADO.DataModel", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");

         S := Find_Stereotype (A.Nodes, "Dynamo.xmi", "AWA.Bean", Gen.Model.XMI.BY_NAME);
         T.Assert (S /= null, "Stereotype not found");
      end;
   end Test_Find_Element;

end Gen.Artifacts.XMI.Tests;

Check new stereotypes necessary for the code gneration


-----------------------------------------------------------------------
--  widgets-factory -- Factory for widget Components
--  Copyright (C) 2013 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 ASF.Views.Nodes;
with ASF.Components.Base;
with ASF.Components.Widgets.Inputs;

package body ASF.Components.Widgets.Factory is

   use ASF.Components.Base;

   function Create_Input return UIComponent_Access;

   --  -------------------------
   --  ------------------------------
   --  Create a UIFile component
   --  ------------------------------
   function Create_Input return UIComponent_Access is
   begin
      return new ASF.Components.Widgets.Inputs.UIInput;
   end Create_Input;

   use ASF.Views.Nodes;

   URI            : aliased constant String := "http://code.google.com/p/ada-asf/widget";
   INPUT_TEXT_TAG : aliased constant String := "inputText";

   Widget_Bindings : aliased constant ASF.Factory.Binding_Array
     := (1 => (Name      => INPUT_TEXT_TAG'Access,
               Component => Create_Input'Access,
               Tag       => Create_Component_Node'Access)
        );

   Core_Factory : aliased constant ASF.Factory.Factory_Bindings
     := (URI => URI'Access, Bindings => Widget_Bindings'Access);

   --  ------------------------------
   --  Get the widget component factory.
   --  ------------------------------
   function Definition return ASF.Factory.Factory_Bindings_Access is
   begin
      return Core_Factory'Access;
   end Definition;

end ASF.Components.Widgets.Factory;

-----------------------------------------------------------------------
--  widgets-factory -- Factory for widget Components
--  Copyright (C) 2013 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 ASF.Views.Nodes;
with ASF.Components.Base;
with ASF.Components.Widgets.Inputs;

package body ASF.Components.Widgets.Factory is

   use ASF.Components.Base;

   function Create_Input return UIComponent_Access;
   function Create_Complete return UIComponent_Access;

   --  ------------------------------
   --  Create a UIInput component
   --  ------------------------------
   function Create_Input return UIComponent_Access is
   begin
      return new ASF.Components.Widgets.Inputs.UIInput;
   end Create_Input;

   --  ------------------------------
   --  Create a UIComplete component
   --  ------------------------------
   function Create_Complete return UIComponent_Access is
   begin
      return new ASF.Components.Widgets.Inputs.UIComplete;
   end Create_Complete;

   use ASF.Views.Nodes;

   URI              : aliased constant String := "http://code.google.com/p/ada-asf/widget";
   AUTOCOMPLETE_TAG : aliased constant String := "autocomplete";
   INPUT_TEXT_TAG   : aliased constant String := "inputText";

   Widget_Bindings : aliased constant ASF.Factory.Binding_Array
     := (1 => (Name      => AUTOCOMPLETE_TAG'Access,
               Component => Create_Complete'Access,
               Tag       => Create_Component_Node'Access),
         2 => (Name      => INPUT_TEXT_TAG'Access,
               Component => Create_Input'Access,
               Tag       => Create_Component_Node'Access)
        );

   Core_Factory : aliased constant ASF.Factory.Factory_Bindings
     := (URI => URI'Access, Bindings => Widget_Bindings'Access);

   --  ------------------------------
   --  Get the widget component factory.
   --  ------------------------------
   function Definition return ASF.Factory.Factory_Bindings_Access is
   begin
      return Core_Factory'Access;
   end Definition;

end ASF.Components.Widgets.Factory;

Add the autocomplete component

Add the autocomplete component


-----------------------------------------------------------------------
--  util-http-clients-mockups -- HTTP Clients mockups
--  Copyright (C) 2011, 2012, 2017 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.Http.Clients;
with Ada.Strings.Unbounded;
package Util.Http.Clients.Mockups is

   --  Register the Http manager.
   procedure Register;

   --  Set the path of the file that contains the response for the next
   --  Do_Get and Do_Post calls.
   procedure Set_File (Path : in String);

private

   type File_Http_Manager is new Http_Manager with record
      File : Ada.Strings.Unbounded.Unbounded_String;
   end record;
   type File_Http_Manager_Access is access all File_Http_Manager'Class;

   procedure Create (Manager  : in File_Http_Manager;
                     Http     : in out Client'Class);

   overriding
   procedure Do_Get (Manager  : in File_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class);

   overriding
   procedure Do_Post (Manager  : in File_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class);

   overriding
   procedure Do_Put (Manager  : in File_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class);

end Util.Http.Clients.Mockups;

-----------------------------------------------------------------------
--  util-http-clients-mockups -- HTTP Clients mockups
--  Copyright (C) 2011, 2012, 2017 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.Http.Clients;
with Ada.Strings.Unbounded;
package Util.Http.Clients.Mockups is

   --  Register the Http manager.
   procedure Register;

   --  Set the path of the file that contains the response for the next
   --  Do_Get and Do_Post calls.
   procedure Set_File (Path : in String);

private

   type File_Http_Manager is new Http_Manager with record
      File : Ada.Strings.Unbounded.Unbounded_String;
   end record;
   type File_Http_Manager_Access is access all File_Http_Manager'Class;

   procedure Create (Manager  : in File_Http_Manager;
                     Http     : in out Client'Class);

   overriding
   procedure Do_Get (Manager  : in File_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class);

   overriding
   procedure Do_Post (Manager  : in File_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class);

   overriding
   procedure Do_Put (Manager  : in File_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class);

   --  Set the timeout for the connection.
   overriding
   procedure Set_Timeout (Manager : in File_Http_Manager;
                          Http    : in Client'Class;
                          Timeout : in Duration);

end Util.Http.Clients.Mockups;

Declare the Set_Timeout procedure

Declare the Set_Timeout procedure


------------------------------------------------------------------------------
--                                                                          --
--                       Copyright (C) 2016, 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 the copyright holder 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.   --
--                                                                          --
------------------------------------------------------------------------------

with nRF51.Device;
with nRF51.GPIO;

package MicroBit is

   MB_P0  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P03;  --  0 pad on edge connector
   MB_P1  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P02;  --  1 pad on edge connector
   MB_P2  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P01;  --  2 pad on edge connector
   MB_P3  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P04;  --  Display column 1
   MB_P4  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P05;  --  Display column 2
   MB_P5  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P17;  --  Button A
   MB_P6  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P12;  --  Display column 9
   MB_P7  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P11;  --  Display column 8
   MB_P8  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P18;
   MB_P9  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P10;  --  Display column 7
   MB_P10 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P06;  --  Display column 3
   MB_P11 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P26;  --  Button B
   MB_P12 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P20;
   MB_P13 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P23;  --  SCK
   MB_P14 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P22;  --  MISO
   MB_P15 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P21;  --  MOSI
   MB_P16 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P16;
   MB_P19 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P00;  --  SCL
   MB_P20 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P30;  --  SDA
end MicroBit;

------------------------------------------------------------------------------
--                                                                          --
--                       Copyright (C) 2016, 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 the copyright holder 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.   --
--                                                                          --
------------------------------------------------------------------------------

with nRF51.Device;
with nRF51.GPIO;

package MicroBit is

   --  http://tech.microbit.org/hardware/edgeconnector_ds/

   MB_P0   : nRF51.GPIO.GPIO_Point renames nRF51.Device.P03;  --  0 pad on edge connector
   MB_P1   : nRF51.GPIO.GPIO_Point renames nRF51.Device.P02;  --  1 pad on edge connector
   MB_P2   : nRF51.GPIO.GPIO_Point renames nRF51.Device.P01;  --  2 pad on edge connector
   MB_P3   : nRF51.GPIO.GPIO_Point renames nRF51.Device.P04;  --  Display column 1
   MB_P4   : nRF51.GPIO.GPIO_Point renames nRF51.Device.P05;  --  Display column 2
   MB_P5   : nRF51.GPIO.GPIO_Point renames nRF51.Device.P17;  --  Button A
   MB_P6   : nRF51.GPIO.GPIO_Point renames nRF51.Device.P12;  --  Display column 9
   MB_P7   : nRF51.GPIO.GPIO_Point renames nRF51.Device.P11;  --  Display column 8
   MB_P8   : nRF51.GPIO.GPIO_Point renames nRF51.Device.P18;
   MB_P9   : nRF51.GPIO.GPIO_Point renames nRF51.Device.P10;  --  Display column 7
   MB_P10  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P06;  --  Display column 3
   MB_P11  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P26;  --  Button B
   MB_P12  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P20;
   MB_P13  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P23;  --  SCK
   MB_P14  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P22;  --  MISO
   MB_P15  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P21;  --  MOSI
   MB_P16  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P16;
   MB_P19  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P00;  --  SCL
   MB_P20  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P30;  --  SDA

   MB_SCK  : nRF51.GPIO.GPIO_Point renames MB_P13;
   MB_MISO : nRF51.GPIO.GPIO_Point renames MB_P14;
   MB_MOSI : nRF51.GPIO.GPIO_Point renames MB_P15;

   MB_SCL  : nRF51.GPIO.GPIO_Point renames MB_P19;
   MB_SDA  : nRF51.GPIO.GPIO_Point renames MB_P20;

end MicroBit;

Add a couple of GPIO_Point aliases

MicroBit: Add a couple of GPIO_Point aliases


-----------------------------------------------------------------------
--  util-streams-buffered -- Buffered streams utilities
--  Copyright (C) 2010, 2011, 2013, 2014, 2016, 2017, 2018 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 Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;
package body Util.Streams.Buffered is

   procedure Free_Buffer is
     new Ada.Unchecked_Deallocation (Object => Stream_Element_Array,
                                     Name   => Buffer_Access);

   --  ------------------------------
   --  Initialize the stream to read or write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   --  ------------------------------
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Output  : access Output_Stream'Class;
                         Size    : in Positive) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Size);
      Stream.Buffer    := new Stream_Element_Array (1 .. Stream.Last);
      Stream.Output    := Output;
      Stream.Write_Pos := 1;
      Stream.Read_Pos  := 1;
      Stream.No_Flush  := False;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream to read from the string.
   --  ------------------------------
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Content : in String) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Content'Length);
      Stream.Buffer    := new Stream_Element_Array (1 .. Content'Length);
      Stream.Input     := null;
      Stream.Write_Pos := Stream.Last + 1;
      Stream.Read_Pos  := 1;
      for I in Content'Range loop
         Stream.Buffer (Stream_Element_Offset (I - Content'First + 1))
           := Character'Pos (Content (I));
      end loop;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream with a buffer of Size bytes.
   --  ------------------------------
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Size    : in Positive) is
   begin
      Stream.Initialize (Output => null, Size => Size);
      Stream.No_Flush := True;
      Stream.Read_Pos := 1;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream to read or write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   --  ------------------------------
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Input   : access Input_Stream'Class;
                         Size    : in Positive) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Size);
      Stream.Buffer    := new Stream_Element_Array (1 .. Stream.Last);
      Stream.Input     := Input;
      Stream.Write_Pos := 1;
      Stream.Read_Pos  := 1;
   end Initialize;

   --  ------------------------------
   --  Close the sink.
   --  ------------------------------
   overriding
   procedure Close (Stream : in out Output_Buffer_Stream) is
   begin
      if Stream.Output /= null then
         Output_Buffer_Stream'Class (Stream).Flush;
         Stream.Output.Close;
      end if;
   end Close;

   --  ------------------------------
   --  Get the direct access to the buffer.
   --  ------------------------------
   function Get_Buffer (Stream : in Output_Buffer_Stream) return Buffer_Access is
   begin
      return Stream.Buffer;
   end Get_Buffer;

   --  ------------------------------
   --  Get the number of element in the stream.
   --  ------------------------------
   function Get_Size (Stream : in Output_Buffer_Stream) return Natural is
   begin
      return Natural (Stream.Write_Pos - Stream.Read_Pos);
   end Get_Size;

   --  ------------------------------
   --  Write the buffer array to the output stream.
   --  ------------------------------
   overriding
   procedure Write (Stream : in out Output_Buffer_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Start : Stream_Element_Offset := Buffer'First;
      Pos   : Stream_Element_Offset := Stream.Write_Pos;
      Avail : Stream_Element_Offset;
      Size  : Stream_Element_Offset;
   begin
      while Start <= Buffer'Last loop
         Size := Buffer'Last - Start + 1;
         Avail := Stream.Last - Pos + 1;
         if Avail = 0 then
            if Stream.Output = null then
               raise Ada.IO_Exceptions.End_Error with "Buffer is full";
            end if;
            Stream.Output.Write (Stream.Buffer (1 .. Pos - 1));
            Stream.Write_Pos := 1;
            Pos := 1;
            Avail := Stream.Last - Pos + 1;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         Stream.Buffer (Pos .. Pos + Size - 1) := Buffer (Start .. Start + Size - 1);
         Start := Start + Size;
         Pos   := Pos + Size;
         Stream.Write_Pos := Pos;

         --  If we have still more data than the buffer size, flush and write
         --  the buffer directly.
         if Start < Buffer'Last and then Buffer'Last - Start > Stream.Buffer'Length then
            if Stream.Output = null then
               raise Ada.IO_Exceptions.End_Error with "Buffer is full";
            end if;
            Stream.Output.Write (Stream.Buffer (1 .. Pos - 1));
            Stream.Write_Pos := 1;
            Stream.Output.Write (Buffer (Start .. Buffer'Last));
            return;
         end if;
      end loop;
   end Write;

   --  ------------------------------
   --  Flush the stream.
   --  ------------------------------
   overriding
   procedure Flush (Stream : in out Output_Buffer_Stream) is
   begin
      if Stream.Write_Pos > 1 and not Stream.No_Flush then
         if Stream.Output /= null then
            Stream.Output.Write (Stream.Buffer (1 .. Stream.Write_Pos - 1));
            Stream.Output.Flush;
         end if;
         Stream.Write_Pos := 1;
      end if;
   end Flush;

   --  ------------------------------
   --  Flush the buffer in the <tt>Into</tt> array and return the index of the
   --  last element (inclusive) in <tt>Last</tt>.
   --  ------------------------------
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Streams.Stream_Element_Array;
                    Last   : out Ada.Streams.Stream_Element_Offset) is
   begin
      if Stream.Write_Pos > 1 then
         Into (Into'First .. Into'First + Stream.Write_Pos - 1) :=
           Stream.Buffer (Stream.Buffer'First .. Stream.Write_Pos - 1);
         Stream.Write_Pos := 1;
         Last := Into'First + Stream.Write_Pos - 1;
      else
         Last := Into'First - 1;
      end if;
   end Flush;

   --  ------------------------------
   --  Flush the buffer stream to the unbounded string.
   --  ------------------------------
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Ada.Strings.Unbounded.Set_Unbounded_String (Into, "");
      if Stream.Write_Pos > 1 then
         for I in 1 .. Stream.Write_Pos - 1 loop
            Ada.Strings.Unbounded.Append (Into, Character'Val (Stream.Buffer (I)));
         end loop;
         Stream.Write_Pos := 1;
      end if;
   end Flush;

   --  ------------------------------
   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   --  ------------------------------
   procedure Fill (Stream : in out Input_Buffer_Stream) is
   begin
      if Stream.Input = null then
         Stream.Eof := True;
      else
         Stream.Input.Read (Stream.Buffer (1 .. Stream.Last - 1), Stream.Write_Pos);
         Stream.Eof := Stream.Write_Pos < 1;
         if not Stream.Eof then
            Stream.Write_Pos := Stream.Write_Pos + 1;
         end if;
         Stream.Read_Pos := 1;
      end if;
   end Fill;

   --  ------------------------------
   --  Read one character from the input stream.
   --  ------------------------------
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Character) is
   begin
      if Stream.Read_Pos >= Stream.Write_Pos then
         Stream.Fill;
         if Stream.Eof then
            raise Ada.IO_Exceptions.Data_Error with "End of buffer";
         end if;
      end if;
      Char := Character'Val (Stream.Buffer (Stream.Read_Pos));
      Stream.Read_Pos := Stream.Read_Pos + 1;
   end Read;

   --  ------------------------------
   --  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 Input_Buffer_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Start : Stream_Element_Offset := Into'First;
      Pos   : Stream_Element_Offset := Stream.Read_Pos;
      Avail : Stream_Element_Offset;
      Size  : Stream_Element_Offset;
      Total : Stream_Element_Offset := 0;
   begin
      while Start <= Into'Last loop
         Size := Into'Last - Start + 1;
         Avail := Stream.Write_Pos - Pos;
         if Avail = 0 then
            Stream.Fill;
            Pos := Stream.Read_Pos;
            Avail := Stream.Write_Pos - Pos;
            exit when Avail <= 0;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         Into (Start .. Start + Size - 1) := Stream.Buffer (Pos .. Pos + Size - 1);
         Start := Start + Size;
         Pos   := Pos + Size;
         Total := Total + Size;
         Stream.Read_Pos := Pos;
      end loop;
      Last := Total;
   end Read;

   --  ------------------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  ------------------------------
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Unbounded.Unbounded_String) is
      Pos   : Stream_Element_Offset := Stream.Read_Pos;
      Avail : Stream_Element_Offset;
   begin
      loop
         Avail := Stream.Write_Pos - Pos;
         if Avail = 0 then
            Stream.Fill;
            if Stream.Eof then
               return;
            end if;
            Pos   := Stream.Read_Pos;
            Avail := Stream.Write_Pos - Pos;
         end if;
         for I in 1 .. Avail loop
            Ada.Strings.Unbounded.Append (Into, Character'Val (Stream.Buffer (Pos)));
            Pos := Pos + 1;
         end loop;
         Stream.Read_Pos := Pos;
      end loop;
   end Read;

   --  ------------------------------
   --  Flush the stream and release the buffer.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Output_Buffer_Stream) is
   begin
      if Object.Buffer /= null then
         if Object.Output /= null then
            Object.Flush;
         end if;
         Free_Buffer (Object.Buffer);
      end if;
   end Finalize;

   --  ------------------------------
   --  Returns True if the end of the stream is reached.
   --  ------------------------------
   function Is_Eof (Stream : in Input_Buffer_Stream) return Boolean is
   begin
      return Stream.Eof;
   end Is_Eof;

   --  ------------------------------
   --  Flush the stream and release the buffer.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Input_Buffer_Stream) is
   begin
      if Object.Buffer /= null then
         Free_Buffer (Object.Buffer);
      end if;
   end Finalize;

end Util.Streams.Buffered;

-----------------------------------------------------------------------
--  util-streams-buffered -- Buffered streams utilities
--  Copyright (C) 2010, 2011, 2013, 2014, 2016, 2017, 2018, 2019 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 Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;
package body Util.Streams.Buffered is

   procedure Free_Buffer is
     new Ada.Unchecked_Deallocation (Object => Stream_Element_Array,
                                     Name   => Buffer_Access);

   --  ------------------------------
   --  Initialize the stream to read or write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   --  ------------------------------
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Output  : access Output_Stream'Class;
                         Size    : in Positive) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Size);
      Stream.Buffer    := new Stream_Element_Array (1 .. Stream.Last);
      Stream.Output    := Output;
      Stream.Write_Pos := 1;
      Stream.Read_Pos  := 1;
      Stream.No_Flush  := False;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream to read from the string.
   --  ------------------------------
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Content : in String) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Content'Length);
      Stream.Buffer    := new Stream_Element_Array (1 .. Content'Length);
      Stream.Input     := null;
      Stream.Write_Pos := Stream.Last + 1;
      Stream.Read_Pos  := 1;
      for I in Content'Range loop
         Stream.Buffer (Stream_Element_Offset (I - Content'First + 1))
           := Character'Pos (Content (I));
      end loop;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream with a buffer of Size bytes.
   --  ------------------------------
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Size    : in Positive) is
   begin
      Stream.Initialize (Output => null, Size => Size);
      Stream.No_Flush := True;
      Stream.Read_Pos := 1;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream to read or write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   --  ------------------------------
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Input   : access Input_Stream'Class;
                         Size    : in Positive) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Size);
      Stream.Buffer    := new Stream_Element_Array (1 .. Stream.Last);
      Stream.Input     := Input;
      Stream.Write_Pos := 1;
      Stream.Read_Pos  := 1;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream from the buffer created for an output stream.
   --  ------------------------------
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         From    : in out Output_Buffer_Stream'Class) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Buffer := From.Buffer;
      From.Buffer := null;
      Stream.Input := null;
      Stream.Read_Pos := 1;
      Stream.Write_Pos := From.Write_Pos + 1;
      Stream.Last := From.Last;
   end Initialize;

   --  ------------------------------
   --  Close the sink.
   --  ------------------------------
   overriding
   procedure Close (Stream : in out Output_Buffer_Stream) is
   begin
      if Stream.Output /= null then
         Output_Buffer_Stream'Class (Stream).Flush;
         Stream.Output.Close;
      end if;
   end Close;

   --  ------------------------------
   --  Get the direct access to the buffer.
   --  ------------------------------
   function Get_Buffer (Stream : in Output_Buffer_Stream) return Buffer_Access is
   begin
      return Stream.Buffer;
   end Get_Buffer;

   --  ------------------------------
   --  Get the number of element in the stream.
   --  ------------------------------
   function Get_Size (Stream : in Output_Buffer_Stream) return Natural is
   begin
      return Natural (Stream.Write_Pos - Stream.Read_Pos);
   end Get_Size;

   --  ------------------------------
   --  Write the buffer array to the output stream.
   --  ------------------------------
   overriding
   procedure Write (Stream : in out Output_Buffer_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Start : Stream_Element_Offset := Buffer'First;
      Pos   : Stream_Element_Offset := Stream.Write_Pos;
      Avail : Stream_Element_Offset;
      Size  : Stream_Element_Offset;
   begin
      while Start <= Buffer'Last loop
         Size := Buffer'Last - Start + 1;
         Avail := Stream.Last - Pos + 1;
         if Avail = 0 then
            if Stream.Output = null then
               raise Ada.IO_Exceptions.End_Error with "Buffer is full";
            end if;
            Stream.Output.Write (Stream.Buffer (1 .. Pos - 1));
            Stream.Write_Pos := 1;
            Pos := 1;
            Avail := Stream.Last - Pos + 1;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         Stream.Buffer (Pos .. Pos + Size - 1) := Buffer (Start .. Start + Size - 1);
         Start := Start + Size;
         Pos   := Pos + Size;
         Stream.Write_Pos := Pos;

         --  If we have still more data than the buffer size, flush and write
         --  the buffer directly.
         if Start < Buffer'Last and then Buffer'Last - Start > Stream.Buffer'Length then
            if Stream.Output = null then
               raise Ada.IO_Exceptions.End_Error with "Buffer is full";
            end if;
            Stream.Output.Write (Stream.Buffer (1 .. Pos - 1));
            Stream.Write_Pos := 1;
            Stream.Output.Write (Buffer (Start .. Buffer'Last));
            return;
         end if;
      end loop;
   end Write;

   --  ------------------------------
   --  Flush the stream.
   --  ------------------------------
   overriding
   procedure Flush (Stream : in out Output_Buffer_Stream) is
   begin
      if not Stream.No_Flush then
         if Stream.Write_Pos > 1 then
            if Stream.Output /= null then
               Stream.Output.Write (Stream.Buffer (1 .. Stream.Write_Pos - 1));
            end if;
            Stream.Write_Pos := 1;
         end if;
         if Stream.Output /= null then
            Stream.Output.Flush;
         end if;
      end if;
   end Flush;

   --  ------------------------------
   --  Flush the buffer in the <tt>Into</tt> array and return the index of the
   --  last element (inclusive) in <tt>Last</tt>.
   --  ------------------------------
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Streams.Stream_Element_Array;
                    Last   : out Ada.Streams.Stream_Element_Offset) is
   begin
      if Stream.Write_Pos > 1 then
         Into (Into'First .. Into'First + Stream.Write_Pos - 1) :=
           Stream.Buffer (Stream.Buffer'First .. Stream.Write_Pos - 1);
         Stream.Write_Pos := 1;
         Last := Into'First + Stream.Write_Pos - 1;
      else
         Last := Into'First - 1;
      end if;
   end Flush;

   --  ------------------------------
   --  Flush the buffer stream to the unbounded string.
   --  ------------------------------
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Ada.Strings.Unbounded.Set_Unbounded_String (Into, "");
      if Stream.Write_Pos > 1 then
         for I in 1 .. Stream.Write_Pos - 1 loop
            Ada.Strings.Unbounded.Append (Into, Character'Val (Stream.Buffer (I)));
         end loop;
         Stream.Write_Pos := 1;
      end if;
   end Flush;

   --  ------------------------------
   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   --  ------------------------------
   procedure Fill (Stream : in out Input_Buffer_Stream) is
   begin
      if Stream.Input = null then
         Stream.Eof := True;
      else
         Stream.Input.Read (Stream.Buffer (1 .. Stream.Last - 1), Stream.Write_Pos);
         Stream.Eof := Stream.Write_Pos < 1;
         if not Stream.Eof then
            Stream.Write_Pos := Stream.Write_Pos + 1;
         end if;
         Stream.Read_Pos := 1;
      end if;
   end Fill;

   --  ------------------------------
   --  Read one character from the input stream.
   --  ------------------------------
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Character) is
   begin
      if Stream.Read_Pos >= Stream.Write_Pos then
         Stream.Fill;
         if Stream.Eof then
            raise Ada.IO_Exceptions.Data_Error with "End of buffer";
         end if;
      end if;
      Char := Character'Val (Stream.Buffer (Stream.Read_Pos));
      Stream.Read_Pos := Stream.Read_Pos + 1;
   end Read;

   --  ------------------------------
   --  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 Input_Buffer_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Start : Stream_Element_Offset := Into'First;
      Pos   : Stream_Element_Offset := Stream.Read_Pos;
      Avail : Stream_Element_Offset;
      Size  : Stream_Element_Offset;
      Total : Stream_Element_Offset := 0;
   begin
      while Start <= Into'Last loop
         Size := Into'Last - Start + 1;
         Avail := Stream.Write_Pos - Pos;
         if Avail = 0 then
            Stream.Fill;
            Pos := Stream.Read_Pos;
            Avail := Stream.Write_Pos - Pos;
            exit when Avail <= 0;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         Into (Start .. Start + Size - 1) := Stream.Buffer (Pos .. Pos + Size - 1);
         Start := Start + Size;
         Pos   := Pos + Size;
         Total := Total + Size;
         Stream.Read_Pos := Pos;
      end loop;
      Last := Total;
   end Read;

   --  ------------------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  ------------------------------
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Unbounded.Unbounded_String) is
      Pos   : Stream_Element_Offset := Stream.Read_Pos;
      Avail : Stream_Element_Offset;
   begin
      loop
         Avail := Stream.Write_Pos - Pos;
         if Avail = 0 then
            Stream.Fill;
            if Stream.Eof then
               return;
            end if;
            Pos   := Stream.Read_Pos;
            Avail := Stream.Write_Pos - Pos;
         end if;
         for I in 1 .. Avail loop
            Ada.Strings.Unbounded.Append (Into, Character'Val (Stream.Buffer (Pos)));
            Pos := Pos + 1;
         end loop;
         Stream.Read_Pos := Pos;
      end loop;
   end Read;

   --  ------------------------------
   --  Flush the stream and release the buffer.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Output_Buffer_Stream) is
   begin
      if Object.Buffer /= null then
         if Object.Output /= null then
            Object.Flush;
         end if;
         Free_Buffer (Object.Buffer);
      end if;
   end Finalize;

   --  ------------------------------
   --  Returns True if the end of the stream is reached.
   --  ------------------------------
   function Is_Eof (Stream : in Input_Buffer_Stream) return Boolean is
   begin
      return Stream.Eof;
   end Is_Eof;

   --  ------------------------------
   --  Flush the stream and release the buffer.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Input_Buffer_Stream) is
   begin
      if Object.Buffer /= null then
         Free_Buffer (Object.Buffer);
      end if;
   end Finalize;

end Util.Streams.Buffered;

Implement new Initialize procedure to setup an Input stream from an Output stream Fix Flush procedure to call the output Flush even if we have nothing to write locally


-----------------------------------------------------------------------
--  util-dates-iso8601 -- ISO8601 dates
--  Copyright (C) 2011, 2013, 2016 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 Ada.Calendar;
package Util.Dates.ISO8601 is

   type Precision_Type is (YEAR, MONTH, DAY, HOUR, MINUTE, SECOND, SUBSECOND);

                           --  Parses an ISO8601 date and return it as a calendar time.
   --  Raises Constraint_Error if the date format is not recognized.
   function Value (Date : in String) return Ada.Calendar.Time;

   --  Return the ISO8601 date.
   function Image (Date : in Ada.Calendar.Time) return String;
   function Image (Date : in Date_Record) return String;
   function Image (Date      : in Ada.Calendar.Time;
                   Precision : in Precision_Type) return String;
   function Image (Date      : in Date_Record;
                   Precision : in Precision_Type) return String;

end Util.Dates.ISO8601;

-----------------------------------------------------------------------
--  util-dates-iso8601 -- ISO8601 dates
--  Copyright (C) 2011, 2013, 2016, 2018 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 Ada.Calendar;

--  == ISO8601 Dates ==
--  The ISO8601 defines a standard date format that is commonly used and easily parsed by programs.
--  The `Util.Dates.ISO8601` package provides an `Image` function to convert a date into that
--  target format and a `Value` function to parse such format string and return the date.
--
--      Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
--      S    : constant String := Util.Dates.ISO8601.Image (Now);
--      Date : Ada.Calendar.time := Util.Dates.ISO8601.Value (S);
--
--  A `Constraint_Error` exception is raised when the date string is not in the correct format.
package Util.Dates.ISO8601 is

   type Precision_Type is (YEAR, MONTH, DAY, HOUR, MINUTE, SECOND, SUBSECOND);

   --  Parses an ISO8601 date and return it as a calendar time.
   --  Raises Constraint_Error if the date format is not recognized.
   function Value (Date : in String) return Ada.Calendar.Time;

   --  Return the ISO8601 date.
   function Image (Date : in Ada.Calendar.Time) return String;
   function Image (Date : in Date_Record) return String;
   function Image (Date      : in Ada.Calendar.Time;
                   Precision : in Precision_Type) return String;
   function Image (Date      : in Date_Record;
                   Precision : in Precision_Type) return String;

end Util.Dates.ISO8601;

Add and update the documentation

Add and update the documentation


-----------------------------------------------------------------------
--  ado-sequences-tests -- Test sequences factories
--  Copyright (C) 2011, 2012, 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.Test_Caller;

with ADO.Drivers;
with ADO.Sessions;
with ADO.SQL;
with Regtests.Simple.Model;

with ADO.Sequences.Hilo;
with ADO.Sessions.Factory;
package body ADO.Sequences.Tests is

   use Util.Tests;

   type Test_Impl is
     new ADO.Objects.Object_Record (Key_Type => ADO.Objects.KEY_INTEGER,
                                    Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE)
   with record
      Version : Integer;
      Value   : ADO.Identifier;
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Select_Name : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   overriding
   procedure Destroy (Object : access Test_Impl);

   overriding
   procedure Find (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean);

   overriding
   procedure Load (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class);

   overriding
   procedure Save (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   procedure Delete (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   procedure Create (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   package Caller is new Util.Test_Caller (Test, "ADO.Sequences");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Sequences.Create",
                       Test_Create_Factory'Access);
   end Add_Tests;

   --  Test creation of the sequence factory.
   --  This test revealed a memory leak if we failed to create a database connection.
   procedure Test_Create_Factory (T : in out Test) is
      Seq_Factory : ADO.Sequences.Factory;
      Obj         : Test_Impl;
      Factory     : aliased ADO.Sessions.Factory.Session_Factory;
   begin
      Seq_Factory.Set_Default_Generator (ADO.Sequences.Hilo.Create_HiLo_Generator'Access,
                                         Factory'Unchecked_Access);
      begin
         Seq_Factory.Allocate (Obj);
         T.Assert (False, "No exception raised.");

      exception
         when ADO.Drivers.Connection_Error =>
            null;  --  Good! An exception is expected because the session factory is empty.
      end;
   end Test_Create_Factory;

   overriding
   procedure Destroy (Object : access Test_Impl) is
   begin
      null;
   end Destroy;

   overriding
   procedure Find (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean) is
      pragma Unreferenced (Object, Session, Query);
   begin
      Found := False;
   end Find;

   overriding
   procedure Load (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class) is
   begin
      null;
   end Load;

   overriding
   procedure Save (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Master_Session'Class) is
   begin
      null;
   end Save;

   overriding
   procedure Delete (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class) is
   begin
      null;
   end Delete;

   overriding
   procedure Create (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class) is
   begin
      null;
   end Create;

end ADO.Sequences.Tests;

-----------------------------------------------------------------------
--  ado-sequences-tests -- Test sequences factories
--  Copyright (C) 2011, 2012, 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.Test_Caller;

with ADO.Drivers;
with ADO.Sessions;
with ADO.SQL;
with ADO.Databases;
with Regtests.Simple.Model;

with ADO.Sequences.Hilo;
with ADO.Sessions.Factory;
package body ADO.Sequences.Tests is

   use Util.Tests;

   type Test_Impl is
     new ADO.Objects.Object_Record (Key_Type => ADO.Objects.KEY_INTEGER,
                                    Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE)
   with record
      Version : Integer;
      Value   : ADO.Identifier;
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Select_Name : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   overriding
   procedure Destroy (Object : access Test_Impl);

   overriding
   procedure Find (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean);

   overriding
   procedure Load (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class);

   overriding
   procedure Save (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   procedure Delete (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   procedure Create (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   package Caller is new Util.Test_Caller (Test, "ADO.Sequences");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Sequences.Create",
                       Test_Create_Factory'Access);
   end Add_Tests;

   --  Test creation of the sequence factory.
   --  This test revealed a memory leak if we failed to create a database connection.
   procedure Test_Create_Factory (T : in out Test) is
      Seq_Factory : ADO.Sequences.Factory;
      Obj         : Test_Impl;
      Factory     : aliased ADO.Sessions.Factory.Session_Factory;
      Controller  : aliased ADO.Databases.DataSource;
      Prev_Id     : Identifier := ADO.NO_IDENTIFIER;
   begin
      Seq_Factory.Set_Default_Generator (ADO.Sequences.Hilo.Create_HiLo_Generator'Access,
                                         Factory'Unchecked_Access);
      begin
         Seq_Factory.Allocate (Obj);
         T.Assert (False, "No exception raised.");

      exception
         when ADO.Drivers.Connection_Error =>
            null;  --  Good! An exception is expected because the session factory is empty.
      end;

      --  Make a real connection.
      Controller.Set_Connection (ADO.Drivers.Get_Config ("test.database"));
      Factory.Create (Controller);
      for I in 1 .. 1_000 loop
         Seq_Factory.Allocate (Obj);
         T.Assert (Obj.Get_Key_Value /= Prev_Id, "Invalid id was allocated");
         Prev_Id := Obj.Get_Key_Value;
      end loop;
   end Test_Create_Factory;

   overriding
   procedure Destroy (Object : access Test_Impl) is
   begin
      null;
   end Destroy;

   overriding
   procedure Find (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean) is
      pragma Unreferenced (Object, Session, Query);
   begin
      Found := False;
   end Find;

   overriding
   procedure Load (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class) is
   begin
      null;
   end Load;

   overriding
   procedure Save (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Master_Session'Class) is
   begin
      null;
   end Save;

   overriding
   procedure Delete (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class) is
   begin
      null;
   end Delete;

   overriding
   procedure Create (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class) is
   begin
      null;
   end Create;

end ADO.Sequences.Tests;

Update the Test_Create_Factory test to allocate ids with the sequence generator