------------------------------------------------------------------------------
--                                                                          --
--                     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 STMicroelectronics nor the names of its       --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

with STM32.Device;  use STM32.Device;
with HAL;           use HAL;

package body Serial_IO.Streaming is

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (This : out Serial_Port) is
   begin
      Serial_IO.Initialize_Peripheral (This.Device);
      This.Initialized := True;
   end Initialize;

   -----------------
   -- Initialized --
   -----------------

   function Initialized (This : Serial_Port) return Boolean is
     (This.Initialized);

   ---------------
   -- Configure --
   ---------------

   procedure Configure
     (This      : in out Serial_Port;
      Baud_Rate : Baud_Rates;
      Parity    : Parities     := No_Parity;
      Data_Bits : Word_Lengths := Word_Length_8;
      End_Bits  : Stop_Bits    := Stopbits_1;
      Control   : Flow_Control := No_Flow_Control)
   is
   begin
      Serial_IO.Configure (This.Device, Baud_Rate, Parity, Data_Bits, End_Bits, Control);
   end Configure;

--     ---------
--     -- Get --
--     ---------
--
--     procedure Get (This : in out Serial_Port;  Msg : not null access Message) is
--        Received_Char : Character;
--        Raw           : UInt9;
--        Timeout       : constant Time_Span := Milliseconds (50);  -- arbitrary (???)
--        Timed_Out     : Boolean;
--     begin
--        Msg.Clear;
--        Receiving : for K in 1 .. Msg.Physical_Size loop
--           Await_Data_Available (This.Device.Transceiver.all, Timeout, Timed_Out);
--           exit Receiving when Timed_Out;
--           Receive (This.Device.Transceiver.all, Raw);
--           Received_Char := Character'Val (Raw);
--           exit Receiving when Received_Char = Msg.Terminator;
--           Msg.Append (Received_Char);
--        end loop Receiving;
--     end Get;

   ----------------------
   -- Await_Send_Ready --
   ----------------------

   procedure Await_Send_Ready (This : USART) is
   begin
      loop
         exit when Tx_Ready (This);
      end loop;
   end Await_Send_Ready;

   ----------------------
   -- Set_Read_Timeout --
   ----------------------

   procedure Set_Read_Timeout
     (This : in out Serial_Port;
      Wait : Time_Span := Time_Span_Last)
   is
   begin
      This.Timeout := Wait;
   end Set_Read_Timeout;

   --------------------------
   -- Await_Data_Available --
   --------------------------

   procedure Await_Data_Available
     (This      : USART;
      Timeout   : Time_Span := Time_Span_Last;
      Timed_Out : out Boolean)
   is
      Deadline : constant Time := Clock + Timeout;
   begin
      Timed_Out := True;
      while Clock < Deadline loop
         if Rx_Ready (This) then
            Timed_Out := False;
            exit;
         end if;
      end loop;
   end Await_Data_Available;

   ----------------
   -- Last_Index --
   ----------------

   function Last_Index
     (First : Stream_Element_Offset;
      Count : Long_Integer)
      return Stream_Element_Offset
   is
   begin
      if First = Stream_Element_Offset'First and then Count = 0 then
         --  we need to return First - 1, but cannot
         raise Constraint_Error;  --  per RM
      else
         return First + Stream_Element_Offset (Count) - 1;
      end if;
   end Last_Index;

   ----------
   -- Read --
   ----------

   overriding
   procedure Read
     (This   : in out Serial_Port;
      Buffer : out Ada.Streams.Stream_Element_Array;
      Last   : out Ada.Streams.Stream_Element_Offset)
   is
      Raw       : UInt9;
      Timed_Out : Boolean;
      Count     : Long_Integer := 0;
   begin
      Receiving : for K in Buffer'Range loop
         Await_Data_Available (This.Device.Transceiver.all, This.Timeout, Timed_Out);
         exit Receiving when Timed_Out;
         Receive (This.Device.Transceiver.all, Raw);
         Buffer (K) := Stream_Element (Raw);
         Count := Count + 1;
      end loop Receiving;
      Last := Last_Index (Buffer'First, Count);
   end Read;

   -----------
   -- Write --
   -----------

   overriding
   procedure Write
     (This   : in out Serial_Port;
      Buffer : Ada.Streams.Stream_Element_Array)
   is
   begin
      for Next of Buffer loop
         Await_Send_Ready (This.Device.Transceiver.all);
         Transmit (This.Device.Transceiver.all, Stream_Element'Pos (Next));
      end loop;
   end Write;

end Serial_IO.Streaming;

------------------------------------------------------------------------------
--                                                                          --
--                     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 STMicroelectronics nor the names of its       --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

with STM32.Device;  use STM32.Device;
with HAL;           use HAL;

package body Serial_IO.Streaming is

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (This : out Serial_Port) is
   begin
      Serial_IO.Initialize_Peripheral (This.Device);
      This.Initialized := True;
   end Initialize;

   -----------------
   -- Initialized --
   -----------------

   function Initialized (This : Serial_Port) return Boolean is
     (This.Initialized);

   ---------------
   -- Configure --
   ---------------

   procedure Configure
     (This      : in out Serial_Port;
      Baud_Rate : Baud_Rates;
      Parity    : Parities     := No_Parity;
      Data_Bits : Word_Lengths := Word_Length_8;
      End_Bits  : Stop_Bits    := Stopbits_1;
      Control   : Flow_Control := No_Flow_Control)
   is
   begin
      Serial_IO.Configure (This.Device, Baud_Rate, Parity, Data_Bits, End_Bits, Control);
   end Configure;

   ----------------------
   -- Await_Send_Ready --
   ----------------------

   procedure Await_Send_Ready (This : USART) is
   begin
      loop
         exit when Tx_Ready (This);
      end loop;
   end Await_Send_Ready;

   ----------------------
   -- Set_Read_Timeout --
   ----------------------

   procedure Set_Read_Timeout
     (This : in out Serial_Port;
      Wait : Time_Span := Time_Span_Last)
   is
   begin
      This.Timeout := Wait;
   end Set_Read_Timeout;

   --------------------------
   -- Await_Data_Available --
   --------------------------

   procedure Await_Data_Available
     (This      : USART;
      Timeout   : Time_Span := Time_Span_Last;
      Timed_Out : out Boolean)
   is
      Deadline : constant Time := Clock + Timeout;
   begin
      Timed_Out := True;
      while Clock < Deadline loop
         if Rx_Ready (This) then
            Timed_Out := False;
            exit;
         end if;
      end loop;
   end Await_Data_Available;

   ----------------
   -- Last_Index --
   ----------------

   function Last_Index
     (First : Stream_Element_Offset;
      Count : Long_Integer)
      return Stream_Element_Offset
   is
   begin
      if First = Stream_Element_Offset'First and then Count = 0 then
         --  we need to return First - 1, but cannot
         raise Constraint_Error;  --  per RM
      else
         return First + Stream_Element_Offset (Count) - 1;
      end if;
   end Last_Index;

   ----------
   -- Read --
   ----------

   overriding
   procedure Read
     (This   : in out Serial_Port;
      Buffer : out Ada.Streams.Stream_Element_Array;
      Last   : out Ada.Streams.Stream_Element_Offset)
   is
      Raw       : UInt9;
      Timed_Out : Boolean;
      Count     : Long_Integer := 0;
   begin
      Receiving : for K in Buffer'Range loop
         Await_Data_Available (This.Device.Transceiver.all, This.Timeout, Timed_Out);
         exit Receiving when Timed_Out;
         Receive (This.Device.Transceiver.all, Raw);
         Buffer (K) := Stream_Element (Raw);
         Count := Count + 1;
      end loop Receiving;
      Last := Last_Index (Buffer'First, Count);
   end Read;

   -----------
   -- Write --
   -----------

   overriding
   procedure Write
     (This   : in out Serial_Port;
      Buffer : Ada.Streams.Stream_Element_Array)
   is
   begin
      for Next of Buffer loop
         Await_Send_Ready (This.Device.Transceiver.all);
         Transmit (This.Device.Transceiver.all, Stream_Element'Pos (Next));
      end loop;
   end Write;

end Serial_IO.Streaming;

Remove commented-out code

Remove commented-out code


-----------------------------------------------------------------------
--  mat-expressions -- Expressions for memory slot selection
--  Copyright (C) 2014 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;

private with Util.Concurrent.Counters;

with MAT.Types;
with MAT.Memory;
package MAT.Expressions is

   type Context_Type is record
      Addr       : MAT.Types.Target_Addr;
      Allocation : MAT.Memory.Allocation;
   end record;

   type Inside_Type is (INSIDE_FILE, INSIDE_FUNCTION);

   type Expression_Type is tagged private;

   --  Create a NOT expression node.
   function Create_Not (Expr : in Expression_Type) return Expression_Type;

   --  Create a AND expression node.
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type;

   --  Create a OR expression node.
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type;

   --  Create an INSIDE expression node.
   function Create_Inside (Name : in String;
                           Kind : in Inside_Type) return Expression_Type;

   --  Create an size range expression node.
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type;

   --  Create an addr range expression node.
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type;

   --  Create an time range expression node.
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type;

   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   function Is_Selected (Node    : in Expression_Type;
                         Context : in Context_Type) return Boolean;

private

   type Kind_Type is (N_NOT, N_OR, N_AND, N_TRUE, N_FALSE,
                      N_IN_FILE, N_IN_FILE_DIRECT, N_INSIDE,
                      N_CALL_ADDR, N_CALL_ADDR_DIRECT,
                      N_IN_FUNC, N_IN_FUNC_DIRECT,
                      N_RANGE_SIZE, N_RANGE_ADDR,
                      N_RANGE_TIME,
                      N_CONDITION, N_THREAD);

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

   type Node_Type (Kind : Kind_Type) is record
      Ref_Counter : Util.Concurrent.Counters.Counter;
      case Kind is
         when N_NOT =>
            Expr : Node_Type_Access;

         when N_OR | N_AND =>
            Left, Right : Node_Type_Access;

         when N_INSIDE | N_IN_FILE | N_IN_FILE_DIRECT | N_IN_FUNC | N_IN_FUNC_DIRECT =>
            Name   : Ada.Strings.Unbounded.Unbounded_String;
            Inside : Inside_Type;

         when N_RANGE_SIZE =>
            Min_Size : MAT.Types.Target_Size;
            Max_Size : MAT.Types.Target_Size;

         when N_RANGE_ADDR | N_CALL_ADDR | N_CALL_ADDR_DIRECT =>
            Min_Addr : MAT.Types.Target_Addr;
            Max_Addr : MAT.Types.Target_Addr;

         when N_RANGE_TIME =>
            Min_Time : MAT.Types.Target_Tick_Ref;
            Max_Time : MAT.Types.Target_Tick_Ref;

         when N_THREAD =>
            Thread : MAT.Types.Target_Thread_Ref;

         when others =>
            null;
      end case;
   end record;

   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   function Is_Selected (Node    : in Node_Type;
                         Context : in Context_Type) return Boolean;

   type Expression_Type is tagged record
      Node : Node_Type_Access;
   end record;

end MAT.Expressions;

-----------------------------------------------------------------------
--  mat-expressions -- Expressions for memory slot selection
--  Copyright (C) 2014 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;

private with Util.Concurrent.Counters;

with MAT.Types;
with MAT.Memory;
package MAT.Expressions is

   type Context_Type is record
      Addr       : MAT.Types.Target_Addr;
      Allocation : MAT.Memory.Allocation;
   end record;

   type Inside_Type is (INSIDE_FILE, INSIDE_FUNCTION);

   type Expression_Type is tagged private;

   --  Create a NOT expression node.
   function Create_Not (Expr : in Expression_Type) return Expression_Type;

   --  Create a AND expression node.
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type;

   --  Create a OR expression node.
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type;

   --  Create an INSIDE expression node.
   function Create_Inside (Name : in String;
                           Kind : in Inside_Type) return Expression_Type;

   --  Create an size range expression node.
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type;

   --  Create an addr range expression node.
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type;

   --  Create an time range expression node.
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type;

   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   function Is_Selected (Node       : in Expression_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean;

private

   type Kind_Type is (N_NOT, N_OR, N_AND, N_TRUE, N_FALSE,
                      N_IN_FILE, N_IN_FILE_DIRECT, N_INSIDE,
                      N_CALL_ADDR, N_CALL_ADDR_DIRECT,
                      N_IN_FUNC, N_IN_FUNC_DIRECT,
                      N_RANGE_SIZE, N_RANGE_ADDR,
                      N_RANGE_TIME,
                      N_CONDITION, N_THREAD);

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

   type Node_Type (Kind : Kind_Type) is record
      Ref_Counter : Util.Concurrent.Counters.Counter;
      case Kind is
         when N_NOT =>
            Expr : Node_Type_Access;

         when N_OR | N_AND =>
            Left, Right : Node_Type_Access;

         when N_INSIDE | N_IN_FILE | N_IN_FILE_DIRECT | N_IN_FUNC | N_IN_FUNC_DIRECT =>
            Name   : Ada.Strings.Unbounded.Unbounded_String;
            Inside : Inside_Type;

         when N_RANGE_SIZE =>
            Min_Size : MAT.Types.Target_Size;
            Max_Size : MAT.Types.Target_Size;

         when N_RANGE_ADDR | N_CALL_ADDR | N_CALL_ADDR_DIRECT =>
            Min_Addr : MAT.Types.Target_Addr;
            Max_Addr : MAT.Types.Target_Addr;

         when N_RANGE_TIME =>
            Min_Time : MAT.Types.Target_Tick_Ref;
            Max_Time : MAT.Types.Target_Tick_Ref;

         when N_THREAD =>
            Thread : MAT.Types.Target_Thread_Ref;

         when others =>
            null;
      end case;
   end record;

   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   function Is_Selected (Node       : in Node_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean;

   type Expression_Type is tagged record
      Node : Node_Type_Access;
   end record;

end MAT.Expressions;

Change the Is_Selected operation to give the slot address and allocation as parameter


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

with MAT.Readers.Marshaller;
package body MAT.Targets.Probes is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Targets.Probes");

   MSG_BEGIN     : constant MAT.Events.Targets.Probe_Index_Type := 0;
   MSG_END       : constant MAT.Events.Targets.Probe_Index_Type := 1;

   M_PID         : constant MAT.Events.Internal_Reference := 1;
   M_EXE         : constant MAT.Events.Internal_Reference := 2;
   M_HEAP_START  : constant MAT.Events.Internal_Reference := 3;
   M_HEAP_END    : constant MAT.Events.Internal_Reference := 4;
   M_END         : constant MAT.Events.Internal_Reference := 5;

   PID_NAME      : aliased constant String := "pid";
   EXE_NAME      : aliased constant String := "exe";
   HP_START_NAME : aliased constant String := "hp_start";
   HP_END_NAME   : aliased constant String := "hp_end";
   END_NAME      : aliased constant String := "end";

   Process_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => PID_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_PID),
      2 => (Name => EXE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_EXE),
      3 => (Name => HP_START_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_START),
      4 => (Name => HP_END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_END),
      5 => (Name => END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_END));

   --  ------------------------------
   --  Create a new process after the begin event is received from the event stream.
   --  ------------------------------
   procedure Create_Process (Probe : in out Process_Probe_Type;
                             Pid         : in MAT.Types.Target_Process_Ref;
                             Path        : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
--        Probe.Target.Create_Process (Pid     => Pid,
--                                           Path    => Path,
--                                           Process => Probe.Process);
      Probe.Process.Events := Probe.Events;
      MAT.Memory.Targets.Initialize (Memory  => Probe.Process.Memory,
                                     Manager => Probe.Manager.all);
   end Create_Process;

   procedure Probe_Begin (Probe : in out Process_Probe_Type;
                          Id          : in MAT.Events.Internal_Reference;
                          Defs        : in MAT.Events.Attribute_Table;
                          Frame       : in MAT.Events.Frame_Info;
                          Msg         : in out MAT.Readers.Message) is
      Pid  : MAT.Types.Target_Process_Ref := 0;
      Path : Ada.Strings.Unbounded.Unbounded_String;
      Heap : MAT.Memory.Region_Info;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_PID =>
                  Pid := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);

               when M_EXE =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_HEAP_START =>
                  Heap.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_HEAP_END =>
                  Heap.End_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Heap.Size       := Heap.End_Addr - Heap.Start_Addr;
      Heap.Path       := Ada.Strings.Unbounded.To_Unbounded_String ("[heap]");
      Probe.Create_Process (Pid, Path);
      Probe.Manager.Read_Message (Msg);
      Probe.Manager.Read_Event_Definitions (Msg);
      Probe.Process.Memory.Add_Region (Heap);
   end Probe_Begin;

   overriding
   procedure Extract (Probe  : in Process_Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out MAT.Events.Targets.Probe_Event_Type) is
   begin
      null;
   end Extract;

   procedure Execute (Probe : in Process_Probe_Type;
                      Event : in MAT.Events.Targets.Probe_Event_Type) is
   begin
      null;
   end Execute;

   --  ------------------------------
   --  Register the reader to extract and analyze process events.
   --  ------------------------------
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Process_Probe_Type_Access) is
   begin
      Probe.Manager := Into'Unchecked_Access;
      Into.Register_Probe (Probe.all'Access, "begin", MSG_BEGIN,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "end", MSG_END,
                           Process_Attributes'Access);
   end Register;

   --  ------------------------------
   --  Initialize the target object to prepare for reading process events.
   --  ------------------------------
   procedure Initialize (Target  : in out Target_Type;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Process_Probe : constant Process_Probe_Type_Access
        := new Process_Probe_Type;
   begin
      Process_Probe.Target := Target'Unrestricted_Access;
      Process_Probe.Events := Manager.Get_Target_Events;
      Register (Manager, Process_Probe);
   end Initialize;

end MAT.Targets.Probes;

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

with MAT.Readers.Marshaller;
package body MAT.Targets.Probes is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Targets.Probes");

   MSG_BEGIN     : constant MAT.Events.Targets.Probe_Index_Type := 0;
   MSG_END       : constant MAT.Events.Targets.Probe_Index_Type := 1;

   M_PID         : constant MAT.Events.Internal_Reference := 1;
   M_EXE         : constant MAT.Events.Internal_Reference := 2;
   M_HEAP_START  : constant MAT.Events.Internal_Reference := 3;
   M_HEAP_END    : constant MAT.Events.Internal_Reference := 4;
   M_END         : constant MAT.Events.Internal_Reference := 5;

   PID_NAME      : aliased constant String := "pid";
   EXE_NAME      : aliased constant String := "exe";
   HP_START_NAME : aliased constant String := "hp_start";
   HP_END_NAME   : aliased constant String := "hp_end";
   END_NAME      : aliased constant String := "end";

   Process_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => PID_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_PID),
      2 => (Name => EXE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_EXE),
      3 => (Name => HP_START_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_START),
      4 => (Name => HP_END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_HEAP_END),
      5 => (Name => END_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_END));

   --  ------------------------------
   --  Create a new process after the begin event is received from the event stream.
   --  ------------------------------
   procedure Create_Process (Probe : in Process_Probe_Type;
                             Pid         : in MAT.Types.Target_Process_Ref;
                             Path        : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Probe.Target.Create_Process (Pid     => Pid,
                                   Path    => Path,
                                   Process => Probe.Target.Current);
      Probe.Target.Process.Events := Probe.Events;
      MAT.Memory.Targets.Initialize (Memory  => Probe.Target.Process.Memory,
                                     Manager => Probe.Manager.all);
   end Create_Process;

   procedure Probe_Begin (Probe : in Process_Probe_Type;
                          Id          : in MAT.Events.Targets.Probe_Index_Type;
                          Defs        : in MAT.Events.Attribute_Table;
                          Msg         : in out MAT.Readers.Message) is
      Pid  : MAT.Types.Target_Process_Ref := 0;
      Path : Ada.Strings.Unbounded.Unbounded_String;
      Heap : MAT.Memory.Region_Info;
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_PID =>
                  Pid := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);

               when M_EXE =>
                  Path := MAT.Readers.Marshaller.Get_String (Msg);

               when M_HEAP_START =>
                  Heap.Start_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_HEAP_END =>
                  Heap.End_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);
            end case;
         end;
      end loop;
      Heap.Size       := Heap.End_Addr - Heap.Start_Addr;
      Heap.Path       := Ada.Strings.Unbounded.To_Unbounded_String ("[heap]");
      Probe.Create_Process (Pid, Path);
      Probe.Manager.Read_Message (Msg);
      Probe.Manager.Read_Event_Definitions (Msg);
      Probe.Target.Process.Memory.Add_Region (Heap);
   end Probe_Begin;

   overriding
   procedure Extract (Probe  : in Process_Probe_Type;
                      Params : in MAT.Events.Const_Attribute_Table_Access;
                      Msg    : in out MAT.Readers.Message_Type;
                      Event  : in out MAT.Events.Targets.Probe_Event_Type) is
      use type MAT.Events.Targets.Probe_Index_Type;
   begin
      if Event.Index = MSG_BEGIN then
         Probe.Probe_Begin (Event.Index, Params.all, Msg);
      end if;
   end Extract;

   procedure Execute (Probe : in Process_Probe_Type;
                      Event : in MAT.Events.Targets.Probe_Event_Type) is
   begin
      null;
   end Execute;

   --  ------------------------------
   --  Register the reader to extract and analyze process events.
   --  ------------------------------
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Process_Probe_Type_Access) is
   begin
      Probe.Manager := Into'Unchecked_Access;
      Into.Register_Probe (Probe.all'Access, "begin", MSG_BEGIN,
                           Process_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "end", MSG_END,
                           Process_Attributes'Access);
   end Register;

   --  ------------------------------
   --  Initialize the target object to prepare for reading process events.
   --  ------------------------------
   procedure Initialize (Target  : in out Target_Type;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class) is
      Process_Probe : constant Process_Probe_Type_Access
        := new Process_Probe_Type;
   begin
      Process_Probe.Target := Target'Unrestricted_Access;
      Process_Probe.Events := Manager.Get_Target_Events;
      Register (Manager, Process_Probe);
   end Initialize;

end MAT.Targets.Probes;

Call Probe_Begin to extract the begin event information, create the new process


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@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 System;

with Ada.Exceptions;
with Ada.Real_Time;
with Ada.Unchecked_Deallocation;

with GL.Low_Level.Enums;
with GL.Types;
with GL.Pixels.Extensions;
with GL.Pixels.Queries;

with Orka.Jobs;
with Orka.Logging;
with Orka.KTX;

package body Orka.Resources.Textures.KTX is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;

   package Messages is new Orka.Logging.Messages (Resource_Loader);

   type KTX_Load_Job is new Jobs.Abstract_Job and Jobs.GPU_Job with record
      Data    : Loaders.Resource_Data;
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Context : Jobs.Execution_Context'Class);

   -----------------------------------------------------------------------------

   use all type Ada.Real_Time.Time;

   function Read_Texture
     (Bytes : Byte_Array_Pointers.Constant_Reference;
      Path  : String;
      Start : Ada.Real_Time.Time) return GL.Objects.Textures.Texture
   is
      T1 : Ada.Real_Time.Time renames Start;
      T2 : constant Ada.Real_Time.Time := Clock;

      use Ada.Streams;
      use GL.Low_Level.Enums;
      use type GL.Types.Size;

      T3, T4, T5, T6 : Ada.Real_Time.Time;
   begin
      if not Orka.KTX.Valid_Identifier (Bytes) then
         raise Texture_Load_Error with Path & " is not a KTX file";
      end if;

      declare
         Header : constant Orka.KTX.Header := Orka.KTX.Get_Header (Bytes);
         Levels : constant GL.Types.Size   := GL.Types.Size'Max (1, Header.Mipmap_Levels);

         Texture  : GL.Objects.Textures.Texture (Header.Kind);

         Width  : constant GL.Types.Size := Header.Width;
         Height :          GL.Types.Size := Header.Height;
         Depth  :          GL.Types.Size := Header.Depth;
      begin
         T3 := Clock;

         if not Header.Compressed
           and then Header.Data_Type in GL.Pixels.Extensions.Packed_Data_Type
         then
            raise GL.Feature_Not_Supported_Exception with
              "Packed data type " & Header.Data_Type'Image & " is not supported yet";
         end if;

         --  Allocate storage
         case Header.Kind is
            when Texture_2D_Array =>
               Depth := Header.Array_Elements;
            when Texture_1D_Array =>
               Height := Header.Array_Elements;
               pragma Assert (Depth = 0);
            when Texture_Cube_Map_Array =>
               --  For a cube map array, depth is the number of layer-faces
               Depth := Header.Array_Elements * 6;
            when Texture_3D =>
               null;
            when Texture_2D | Texture_Cube_Map =>
               pragma Assert (Depth = 0);
            when Texture_1D =>
               if Header.Compressed then
                  raise Texture_Load_Error with Path & " has unknown 1D compressed format";
               end if;
               pragma Assert (Height = 0);
               pragma Assert (Depth = 0);
            when others =>
               raise Program_Error;
         end case;

         if Header.Compressed then
            Texture.Allocate_Storage (Levels, 1, Header.Compressed_Format,
              Width, Height, Depth);
         else
            Texture.Allocate_Storage (Levels, 1, Header.Internal_Format,
              Width, Height, Depth);
         end if;

         case Header.Kind is
            when Texture_1D =>
               Height := 1;
               Depth  := 1;
            when Texture_1D_Array | Texture_2D =>
               Depth := 1;
            when Texture_2D_Array | Texture_3D =>
               null;
            when Texture_Cube_Map | Texture_Cube_Map_Array =>
               --  Texture_Cube_Map uses 2D storage, but 3D load operation
               --  according to table 8.15 of the OpenGL specification

               --  For a cube map, depth is the number of faces, for
               --  a cube map array, depth is the number of layer-faces
               Depth := GL.Types.Size'Max (1, Header.Array_Elements) * 6;
            when others =>
               raise Program_Error;
         end case;
         T4 := Clock;

         --  TODO Handle KTXorientation key value pair

         --  Upload texture data
         declare
            Image_Size_Index : Stream_Element_Offset
              := Orka.KTX.Get_Data_Offset (Bytes, Header.Bytes_Key_Value);

            Cube_Map : constant Boolean := Header.Kind = Texture_Cube_Map;
         begin
            for Level in 0 .. Levels - 1 loop
               declare
                  Face_Size : constant Natural := Orka.KTX.Get_Length (Bytes, Image_Size_Index);
                  --  If not Cube_Map, then Face_Size is the size of the whole level

                  Cube_Padding : constant Natural := 3 - ((Face_Size + 3) mod 4);
                  Image_Size   : constant Natural
                    := (if Cube_Map then (Face_Size + Cube_Padding) * 6 else Face_Size);
                  -- If Cube_Map then Levels = 1 so no need to add it to the expression

                  --  Compute size of the whole mipmap level
                  Mip_Padding : constant Natural := 3 - ((Image_Size + 3) mod 4);
                  Mipmap_Size : constant Natural := 4 + Image_Size + Mip_Padding;

                  Offset : constant Stream_Element_Offset := Image_Size_Index + 4;
                  pragma Assert
                    (Offset + Stream_Element_Offset (Image_Size) - 1 <= Bytes.Value'Last);
                  Image_Data : constant System.Address := Bytes (Offset)'Address;
                  --  TODO Unpack_Alignment must be 4, but Load_From_Data wants 1 | 2 | 4
                  --  depending on Header.Data_Type

                  Level_Width  : constant GL.Types.Size := Texture.Width  (Level);
                  Level_Height : constant GL.Types.Size := Texture.Height (Level);
                  Level_Depth  : constant GL.Types.Size := Texture.Depth  (Level);
               begin
                  if Header.Compressed then
                     Texture.Load_From_Data (Level, 0, 0, 0, Level_Width, Level_Height, Level_Depth,
                       Header.Compressed_Format, GL.Types.Int (Image_Size), Image_Data);
                  else
                     Texture.Load_From_Data (Level, 0, 0, 0, Level_Width, Level_Height, Level_Depth,
                       Header.Format, Header.Data_Type, Image_Data);
                  end if;

                  Image_Size_Index := Image_Size_Index + Stream_Element_Offset (Mipmap_Size);
               end;
            end loop;
         end;
         T5 := Clock;

         --  Generate a full mipmap pyramid if Mipmap_Levels = 0
         if Header.Mipmap_Levels = 0 then
            Texture.Generate_Mipmap;
         end if;
         T6 := Clock;

         Messages.Log (Info, "Loaded texture " & Path & " in " &
           Logging.Trim (Logging.Image (T6 - T1)));
         Messages.Log (Info, "  size:   " &
            Logging.Trim (Width'Image) & " x " &
            Logging.Trim (Height'Image) & " x " &
            Logging.Trim (Depth'Image) &
            ", mipmap levels:" & Levels'Image);
         Messages.Log (Info, "  kind:   " & Header.Kind'Image);
         if Header.Compressed then
            Messages.Log (Info, "  format: " & Header.Compressed_Format'Image);
         else
            Messages.Log (Info, "  format: " & Header.Internal_Format'Image);
         end if;

         Messages.Log (Info, "  statistics:");
         Messages.Log (Info, "    reading file:   " & Logging.Image (T2 - T1));
         Messages.Log (Info, "    parsing header: " & Logging.Image (T3 - T2));
         Messages.Log (Info, "    storage:        " & Logging.Image (T4 - T3));
         Messages.Log (Info, "    buffers:        " & Logging.Image (T5 - T4));
         if Header.Mipmap_Levels = 0 then
            Messages.Log (Info, "    generating mipmap:" & Logging.Image (T6 - T5));
         end if;

         return Texture;
      end;
   exception
      when Error : Orka.KTX.Invalid_Enum_Error =>
         declare
            Message : constant String := Ada.Exceptions.Exception_Message (Error);
         begin
            raise Texture_Load_Error with Path & " has " & Message;
         end;
   end Read_Texture;

   function Read_Texture
     (Location : Locations.Location_Ptr;
      Path     : String) return GL.Objects.Textures.Texture
   is
      Start_Time : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
   begin
      return Read_Texture (Location.Read_Data (Path).Get, Path, Start_Time);
   end Read_Texture;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Context : Jobs.Execution_Context'Class)
   is
      Bytes : Byte_Array_Pointers.Constant_Reference := Object.Data.Bytes.Get;
      Path  : String renames SU.To_String (Object.Data.Path);

      Resource : constant Texture_Ptr := new Texture'(others => <>);
   begin
      Resource.Texture.Replace_Element (Read_Texture (Bytes, Path, Object.Data.Start_Time));

      --  Register resource at the resource manager
      Object.Manager.Add_Resource (Path, Resource_Ptr (Resource));
   end Execute;

   -----------------------------------------------------------------------------
   --                                 Loader                                  --
   -----------------------------------------------------------------------------

   type KTX_Loader is limited new Loaders.Loader with record
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   function Extension (Object : KTX_Loader) return Loaders.Extension_String is ("ktx");

   overriding
   procedure Load
     (Object   : KTX_Loader;
      Data     : Loaders.Resource_Data;
      Enqueue  : not null access procedure (Element : Jobs.Job_Ptr);
      Location : Locations.Location_Ptr)
   is
      Job : constant Jobs.Job_Ptr := new KTX_Load_Job'
        (Jobs.Abstract_Job with
          Data    => Data,
          Manager => Object.Manager);
   begin
      Enqueue (Job);
   end Load;

   function Create_Loader
     (Manager : Managers.Manager_Ptr) return Loaders.Loader_Ptr
   is (new KTX_Loader'(Manager => Manager));

   -----------------------------------------------------------------------------
   --                                 Writer                                  --
   -----------------------------------------------------------------------------

   procedure Write_Texture
     (Texture  : GL.Objects.Textures.Texture;
      Location : Locations.Writable_Location_Ptr;
      Path     : String)
   is
      package Textures renames GL.Objects.Textures;
      package Pointers is new Textures.Texture_Pointers (Byte_Pointers);

      Format    : GL.Pixels.Format    := GL.Pixels.RGBA;
      Data_Type : GL.Pixels.Data_Type := GL.Pixels.Float;
      --  Note: unused if texture is compressed

      Base_Level : constant := 0;

      use Ada.Streams;
      use all type GL.Low_Level.Enums.Texture_Kind;
      use type GL.Types.Size;

      Compressed : constant Boolean := Texture.Compressed;

      Header : Orka.KTX.Header (Compressed);

      function Convert
        (Bytes : in out GL.Types.UByte_Array_Access) return Byte_Array_Pointers.Pointer
      is
         Pointer : Byte_Array_Pointers.Pointer;
         Result  : constant Byte_Array_Access := new Byte_Array (1 .. Bytes'Length);

         procedure Free is new Ada.Unchecked_Deallocation
           (Object => GL.Types.UByte_Array, Name => GL.Types.UByte_Array_Access);
      begin
         for Index in Bytes'Range loop
            declare
               Target_Index : constant Stream_Element_Offset
                 := Stream_Element_Offset (Index - Bytes'First + 1);
            begin
               Result (Target_Index) := Stream_Element (Bytes (Index));
            end;
         end loop;
         Free (Bytes);
         Pointer.Set (Result);
         return Pointer;
      end Convert;

      function Convert
        (Bytes : in out Pointers.Element_Array_Access) return Byte_Array_Pointers.Pointer
      is
         Pointer : Byte_Array_Pointers.Pointer;
         Result  : constant Byte_Array_Access := new Byte_Array (1 .. Bytes'Length);
      begin
         Result.all := Bytes.all;
         Pointers.Free (Bytes);
         Pointer.Set (Result);
         return Pointer;
      end Convert;

      function Get_Data
        (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
      is
         Data : Pointers.Element_Array_Access;
      begin
         Data := Pointers.Get_Data (Texture, Level, 0, 0, 0,
           Texture.Width (Level), Texture.Height (Level), Texture.Depth (Level),
           Format, Data_Type);
         return Convert (Data);
      end Get_Data;

      function Get_Compressed_Data
        (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
      is
         Data : GL.Types.UByte_Array_Access;
      begin
         Data := Textures.Get_Compressed_Data (Texture, Level, 0, 0, 0,
           Texture.Width (Level), Texture.Height (Level), Texture.Depth (Level),
           Texture.Compressed_Format);
         return Convert (Data);
      end Get_Compressed_Data;
   begin
      Header.Kind := Texture.Kind;

      Header.Width := Texture.Width (Base_Level);
      case Texture.Kind is
         when Texture_3D =>
            Header.Height := Texture.Height (Base_Level);
            Header.Depth  := Texture.Depth (Base_Level);
         when Texture_2D | Texture_2D_Array | Texture_Cube_Map | Texture_Cube_Map_Array =>
            Header.Height := Texture.Height (Base_Level);
            Header.Depth  := 0;
         when Texture_1D | Texture_1D_Array =>
            Header.Height := 0;
            Header.Depth  := 0;
         when others =>
            raise Program_Error;
      end case;

      case Texture.Kind is
         when Texture_1D_Array =>
            Header.Array_Elements := Texture.Height (Base_Level);
         when Texture_2D_Array =>
            Header.Array_Elements := Texture.Depth (Base_Level);
         when Texture_Cube_Map_Array =>
            Header.Array_Elements := Texture.Depth (Base_Level) / 6;
         when Texture_1D | Texture_2D | Texture_3D | Texture_Cube_Map =>
            Header.Array_Elements := 0;
         when others =>
            raise Program_Error;
      end case;

      Header.Mipmap_Levels   := Texture.Mipmap_Levels;
      Header.Bytes_Key_Value := 0;

      if Compressed then
         Header.Compressed_Format := Texture.Compressed_Format;
      else
         declare
            Internal_Format : constant GL.Pixels.Internal_Format
              := Texture.Internal_Format;
         begin
            Format := GL.Pixels.Queries.Get_Texture_Format (Internal_Format, Texture.Kind);
            Data_Type := GL.Pixels.Queries.Get_Texture_Type (Internal_Format, Texture.Kind);

            Header.Internal_Format := Internal_Format;
            Header.Format    := Format;
            Header.Data_Type := Data_Type;
         end;
      end if;

      declare
         function Get_Level_Data
           (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
         is (if Compressed then Get_Compressed_Data (Level) else Get_Data (Level));

         Bytes : constant Byte_Array_Pointers.Pointer
           := Orka.KTX.Create_KTX_Bytes (Header, Get_Level_Data'Access);
      begin
         Location.Write_Data (Path, Bytes.Get);
      end;
   end Write_Texture;

end Orka.Resources.Textures.KTX;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@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 System;

with Ada.Exceptions;
with Ada.Real_Time;
with Ada.Unchecked_Deallocation;

with GL.Low_Level.Enums;
with GL.Types;
with GL.Pixels.Extensions;
with GL.Pixels.Queries;

with Orka.Jobs;
with Orka.Logging;
with Orka.KTX;

package body Orka.Resources.Textures.KTX is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;

   package Messages is new Orka.Logging.Messages (Resource_Loader);

   type KTX_Load_Job is new Jobs.Abstract_Job and Jobs.GPU_Job with record
      Data    : Loaders.Resource_Data;
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Context : Jobs.Execution_Context'Class);

   -----------------------------------------------------------------------------

   use all type Ada.Real_Time.Time;

   function Read_Texture
     (Bytes : Byte_Array_Pointers.Constant_Reference;
      Path  : String;
      Start : Ada.Real_Time.Time) return GL.Objects.Textures.Texture
   is
      T1 : Ada.Real_Time.Time renames Start;
      T2 : constant Ada.Real_Time.Time := Clock;

      use Ada.Streams;
      use GL.Low_Level.Enums;
      use type GL.Types.Size;

      T3, T4, T5, T6 : Ada.Real_Time.Time;
   begin
      if not Orka.KTX.Valid_Identifier (Bytes) then
         raise Texture_Load_Error with Path & " is not a KTX file";
      end if;

      declare
         Header : constant Orka.KTX.Header := Orka.KTX.Get_Header (Bytes);
         Levels : constant GL.Types.Size   := GL.Types.Size'Max (1, Header.Mipmap_Levels);

         Texture  : GL.Objects.Textures.Texture (Header.Kind);

         Width  : constant GL.Types.Size := Header.Width;
         Height :          GL.Types.Size := Header.Height;
         Depth  :          GL.Types.Size := Header.Depth;
      begin
         T3 := Clock;

         if not Header.Compressed
           and then Header.Data_Type in GL.Pixels.Extensions.Packed_Data_Type
         then
            raise GL.Feature_Not_Supported_Exception with
              "Packed data type " & Header.Data_Type'Image & " is not supported yet";
         end if;

         --  Allocate storage
         case Header.Kind is
            when Texture_2D_Array =>
               Depth := Header.Array_Elements;
            when Texture_1D_Array =>
               Height := Header.Array_Elements;
               pragma Assert (Depth = 0);
            when Texture_Cube_Map_Array =>
               --  For a cube map array, depth is the number of layer-faces
               Depth := Header.Array_Elements * 6;
            when Texture_3D =>
               null;
            when Texture_2D | Texture_Cube_Map =>
               pragma Assert (Depth = 0);
            when Texture_1D =>
               if Header.Compressed then
                  raise Texture_Load_Error with Path & " has unknown 1D compressed format";
               end if;
               pragma Assert (Height = 0);
               pragma Assert (Depth = 0);
            when others =>
               raise Program_Error;
         end case;

         if Header.Compressed then
            Texture.Allocate_Storage (Levels, 1, Header.Compressed_Format,
              Width, Height, Depth);
         else
            Texture.Allocate_Storage (Levels, 1, Header.Internal_Format,
              Width, Height, Depth);
         end if;

         case Header.Kind is
            when Texture_1D =>
               Height := 1;
               Depth  := 1;
            when Texture_1D_Array | Texture_2D =>
               Depth := 1;
            when Texture_2D_Array | Texture_3D =>
               null;
            when Texture_Cube_Map | Texture_Cube_Map_Array =>
               --  Texture_Cube_Map uses 2D storage, but 3D load operation
               --  according to table 8.15 of the OpenGL specification

               --  For a cube map, depth is the number of faces, for
               --  a cube map array, depth is the number of layer-faces
               Depth := GL.Types.Size'Max (1, Header.Array_Elements) * 6;
            when others =>
               raise Program_Error;
         end case;
         T4 := Clock;

         --  TODO Handle KTXorientation key value pair

         --  Upload texture data
         declare
            Image_Size_Index : Stream_Element_Offset
              := Orka.KTX.Get_Data_Offset (Bytes, Header.Bytes_Key_Value);

            Cube_Map : constant Boolean := Header.Kind = Texture_Cube_Map;
         begin
            for Level in 0 .. Levels - 1 loop
               declare
                  Face_Size : constant Natural := Orka.KTX.Get_Length (Bytes, Image_Size_Index);
                  --  If not Cube_Map, then Face_Size is the size of the whole level

                  Cube_Padding : constant Natural := 3 - ((Face_Size + 3) mod 4);
                  Image_Size   : constant Natural
                    := (if Cube_Map then (Face_Size + Cube_Padding) * 6 else Face_Size);
                  -- If Cube_Map then Levels = 1 so no need to add it to the expression

                  --  Compute size of the whole mipmap level
                  Mip_Padding : constant Natural := 3 - ((Image_Size + 3) mod 4);
                  Mipmap_Size : constant Natural := 4 + Image_Size + Mip_Padding;

                  Offset : constant Stream_Element_Offset := Image_Size_Index + 4;
                  pragma Assert
                    (Offset + Stream_Element_Offset (Image_Size) - 1 <= Bytes.Value'Last);
                  Image_Data : constant System.Address := Bytes (Offset)'Address;
                  --  TODO Unpack_Alignment must be 4, but Load_From_Data wants 1 | 2 | 4
                  --  depending on Header.Data_Type

                  Level_Width  : constant GL.Types.Size := Texture.Width  (Level);
                  Level_Height : constant GL.Types.Size := Texture.Height (Level);
                  Level_Depth  : constant GL.Types.Size :=
                    (if Cube_Map then 6 else Texture.Depth (Level));
               begin
                  if Header.Compressed then
                     Texture.Load_From_Data (Level, 0, 0, 0, Level_Width, Level_Height, Level_Depth,
                       Header.Compressed_Format, GL.Types.Int (Image_Size), Image_Data);
                  else
                     Texture.Load_From_Data (Level, 0, 0, 0, Level_Width, Level_Height, Level_Depth,
                       Header.Format, Header.Data_Type, Image_Data);
                  end if;

                  Image_Size_Index := Image_Size_Index + Stream_Element_Offset (Mipmap_Size);
               end;
            end loop;
         end;
         T5 := Clock;

         --  Generate a full mipmap pyramid if Mipmap_Levels = 0
         if Header.Mipmap_Levels = 0 then
            Texture.Generate_Mipmap;
         end if;
         T6 := Clock;

         Messages.Log (Info, "Loaded texture " & Path & " in " &
           Logging.Trim (Logging.Image (T6 - T1)));
         Messages.Log (Info, "  size:   " &
            Logging.Trim (Width'Image) & " x " &
            Logging.Trim (Height'Image) & " x " &
            Logging.Trim (Depth'Image) &
            ", mipmap levels:" & Levels'Image);
         Messages.Log (Info, "  kind:   " & Header.Kind'Image);
         if Header.Compressed then
            Messages.Log (Info, "  format: " & Header.Compressed_Format'Image);
         else
            Messages.Log (Info, "  format: " & Header.Internal_Format'Image);
         end if;

         Messages.Log (Info, "  statistics:");
         Messages.Log (Info, "    reading file:   " & Logging.Image (T2 - T1));
         Messages.Log (Info, "    parsing header: " & Logging.Image (T3 - T2));
         Messages.Log (Info, "    storage:        " & Logging.Image (T4 - T3));
         Messages.Log (Info, "    buffers:        " & Logging.Image (T5 - T4));
         if Header.Mipmap_Levels = 0 then
            Messages.Log (Info, "    generating mipmap:" & Logging.Image (T6 - T5));
         end if;

         return Texture;
      end;
   exception
      when Error : Orka.KTX.Invalid_Enum_Error =>
         declare
            Message : constant String := Ada.Exceptions.Exception_Message (Error);
         begin
            raise Texture_Load_Error with Path & " has " & Message;
         end;
   end Read_Texture;

   function Read_Texture
     (Location : Locations.Location_Ptr;
      Path     : String) return GL.Objects.Textures.Texture
   is
      Start_Time : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
   begin
      return Read_Texture (Location.Read_Data (Path).Get, Path, Start_Time);
   end Read_Texture;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Context : Jobs.Execution_Context'Class)
   is
      Bytes : Byte_Array_Pointers.Constant_Reference := Object.Data.Bytes.Get;
      Path  : String renames SU.To_String (Object.Data.Path);

      Resource : constant Texture_Ptr := new Texture'(others => <>);
   begin
      Resource.Texture.Replace_Element (Read_Texture (Bytes, Path, Object.Data.Start_Time));

      --  Register resource at the resource manager
      Object.Manager.Add_Resource (Path, Resource_Ptr (Resource));
   end Execute;

   -----------------------------------------------------------------------------
   --                                 Loader                                  --
   -----------------------------------------------------------------------------

   type KTX_Loader is limited new Loaders.Loader with record
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   function Extension (Object : KTX_Loader) return Loaders.Extension_String is ("ktx");

   overriding
   procedure Load
     (Object   : KTX_Loader;
      Data     : Loaders.Resource_Data;
      Enqueue  : not null access procedure (Element : Jobs.Job_Ptr);
      Location : Locations.Location_Ptr)
   is
      Job : constant Jobs.Job_Ptr := new KTX_Load_Job'
        (Jobs.Abstract_Job with
          Data    => Data,
          Manager => Object.Manager);
   begin
      Enqueue (Job);
   end Load;

   function Create_Loader
     (Manager : Managers.Manager_Ptr) return Loaders.Loader_Ptr
   is (new KTX_Loader'(Manager => Manager));

   -----------------------------------------------------------------------------
   --                                 Writer                                  --
   -----------------------------------------------------------------------------

   procedure Write_Texture
     (Texture  : GL.Objects.Textures.Texture;
      Location : Locations.Writable_Location_Ptr;
      Path     : String)
   is
      package Textures renames GL.Objects.Textures;
      package Pointers is new Textures.Texture_Pointers (Byte_Pointers);

      Format    : GL.Pixels.Format    := GL.Pixels.RGBA;
      Data_Type : GL.Pixels.Data_Type := GL.Pixels.Float;
      --  Note: unused if texture is compressed

      Base_Level : constant := 0;

      use Ada.Streams;
      use all type GL.Low_Level.Enums.Texture_Kind;
      use type GL.Types.Size;

      Compressed : constant Boolean := Texture.Compressed;

      Header : Orka.KTX.Header (Compressed);

      function Convert
        (Bytes : in out GL.Types.UByte_Array_Access) return Byte_Array_Pointers.Pointer
      is
         Pointer : Byte_Array_Pointers.Pointer;
         Result  : constant Byte_Array_Access := new Byte_Array (1 .. Bytes'Length);

         procedure Free is new Ada.Unchecked_Deallocation
           (Object => GL.Types.UByte_Array, Name => GL.Types.UByte_Array_Access);
      begin
         for Index in Bytes'Range loop
            declare
               Target_Index : constant Stream_Element_Offset
                 := Stream_Element_Offset (Index - Bytes'First + 1);
            begin
               Result (Target_Index) := Stream_Element (Bytes (Index));
            end;
         end loop;
         Free (Bytes);
         Pointer.Set (Result);
         return Pointer;
      end Convert;

      function Convert
        (Bytes : in out Pointers.Element_Array_Access) return Byte_Array_Pointers.Pointer
      is
         Pointer : Byte_Array_Pointers.Pointer;
         Result  : constant Byte_Array_Access := new Byte_Array (1 .. Bytes'Length);
      begin
         Result.all := Bytes.all;
         Pointers.Free (Bytes);
         Pointer.Set (Result);
         return Pointer;
      end Convert;

      function Get_Data
        (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
      is
         Data : Pointers.Element_Array_Access;
      begin
         Data := Pointers.Get_Data (Texture, Level, 0, 0, 0,
           Texture.Width (Level), Texture.Height (Level), Texture.Depth (Level),
           Format, Data_Type);
         return Convert (Data);
      end Get_Data;

      function Get_Compressed_Data
        (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
      is
         Data : GL.Types.UByte_Array_Access;
      begin
         Data := Textures.Get_Compressed_Data (Texture, Level, 0, 0, 0,
           Texture.Width (Level), Texture.Height (Level), Texture.Depth (Level),
           Texture.Compressed_Format);
         return Convert (Data);
      end Get_Compressed_Data;
   begin
      Header.Kind := Texture.Kind;

      Header.Width := Texture.Width (Base_Level);
      case Texture.Kind is
         when Texture_3D =>
            Header.Height := Texture.Height (Base_Level);
            Header.Depth  := Texture.Depth (Base_Level);
         when Texture_2D | Texture_2D_Array | Texture_Cube_Map | Texture_Cube_Map_Array =>
            Header.Height := Texture.Height (Base_Level);
            Header.Depth  := 0;
         when Texture_1D | Texture_1D_Array =>
            Header.Height := 0;
            Header.Depth  := 0;
         when others =>
            raise Program_Error;
      end case;

      case Texture.Kind is
         when Texture_1D_Array =>
            Header.Array_Elements := Texture.Height (Base_Level);
         when Texture_2D_Array =>
            Header.Array_Elements := Texture.Depth (Base_Level);
         when Texture_Cube_Map_Array =>
            Header.Array_Elements := Texture.Depth (Base_Level) / 6;
         when Texture_1D | Texture_2D | Texture_3D | Texture_Cube_Map =>
            Header.Array_Elements := 0;
         when others =>
            raise Program_Error;
      end case;

      Header.Mipmap_Levels   := Texture.Mipmap_Levels;
      Header.Bytes_Key_Value := 0;

      if Compressed then
         Header.Compressed_Format := Texture.Compressed_Format;
      else
         declare
            Internal_Format : constant GL.Pixels.Internal_Format
              := Texture.Internal_Format;
         begin
            Format := GL.Pixels.Queries.Get_Texture_Format (Internal_Format, Texture.Kind);
            Data_Type := GL.Pixels.Queries.Get_Texture_Type (Internal_Format, Texture.Kind);

            Header.Internal_Format := Internal_Format;
            Header.Format    := Format;
            Header.Data_Type := Data_Type;
         end;
      end if;

      declare
         function Get_Level_Data
           (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
         is (if Compressed then Get_Compressed_Data (Level) else Get_Data (Level));

         Bytes : constant Byte_Array_Pointers.Pointer
           := Orka.KTX.Create_KTX_Bytes (Header, Get_Level_Data'Access);
      begin
         Location.Write_Data (Path, Bytes.Get);
      end;
   end Write_Texture;

end Orka.Resources.Textures.KTX;

orka: Fix loading cube map texture from KTX file

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


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

with MAT.Types;
with MAT.Events.Targets;
package MAT.Formats is

   type Format_Type is (BRIEF, NORMAL);

   --  Format the address into a string.
   function Addr (Value : in MAT.Types.Target_Addr) return String;

   --  Format the size into a string.
   function Size (Value : in MAT.Types.Target_Size) return String;

   --  Format the time relative to the start time.
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String;

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

   --  Format a file, line, function information into a string.
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String;

   --  Format a short description of the event.
   function Event (Item : in MAT.Events.Targets.Probe_Event_Type;
                   Mode : in Format_Type := NORMAL) return String;

   --  Format a short description of the event.
   function Event (Item       : in MAT.Events.Targets.Probe_Event_Type;
                   Related    : in MAT.Events.Targets.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String;

end MAT.Formats;

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

with MAT.Types;
with MAT.Events.Targets;
package MAT.Formats is

   type Format_Type is (BRIEF, NORMAL);

   --  Format the address into a string.
   function Addr (Value : in MAT.Types.Target_Addr) return String;

   --  Format the size into a string.
   function Size (Value : in MAT.Types.Target_Size) return String;

   --  Format the time relative to the start time.
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String;

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

   --  Format a file, line, function information into a string.
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String;

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

   --  Format a short description of the event.
   function Event (Item : in MAT.Events.Targets.Probe_Event_Type;
                   Mode : in Format_Type := NORMAL) return String;

   --  Format a short description of the event.
   function Event (Item       : in MAT.Events.Targets.Probe_Event_Type;
                   Related    : in MAT.Events.Targets.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String;

end MAT.Formats;

Declare the Event function to print an event range


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

with MAT.Types;
with MAT.Memory;
with MAT.Events.Tools;
package MAT.Formats is

   type Format_Type is (BRIEF, NORMAL);

   --  Format the PID into a string.
   function Pid (Value : in MAT.Types.Target_Process_Ref) return String;

   --  Format the address into a string.
   function Addr (Value : in MAT.Types.Target_Addr) return String;

   --  Format the size into a string.
   function Size (Value : in MAT.Types.Target_Size) return String;

   --  Format the memory growth size into a string.
   function Size (Alloced : in MAT.Types.Target_Size;
                  Freed   : in MAT.Types.Target_Size) return String;

   --  Format the time relative to the start time.
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String;

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

   --  Format a file, line, function information into a string.
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String;

   --  Format an event range description.
   function Event (First : in MAT.Events.Target_Event_Type;
                   Last  : in MAT.Events.Target_Event_Type) return String;

   --  Format a short description of the event.
   function Event (Item : in MAT.Events.Target_Event_Type;
                   Mode : in Format_Type := NORMAL) return String;

   --  Format a short description of the event.
   function Event (Item       : in MAT.Events.Target_Event_Type;
                   Related    : in MAT.Events.Tools.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  Format a short description of the memory allocation slot.
   function Slot (Value      : in MAT.Types.Target_Addr;
                  Item       : in MAT.Memory.Allocation;
                  Start_Time : in MAT.Types.Target_Tick_Ref) return String;

end MAT.Formats;

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

with MAT.Types;
with MAT.Memory;
with MAT.Events.Tools;
package MAT.Formats is

   type Format_Type is (BRIEF, NORMAL);

   --  Format the PID into a string.
   function Pid (Value : in MAT.Types.Target_Process_Ref) return String;

   --  Format the address into a string.
   function Addr (Value : in MAT.Types.Target_Addr) return String;

   --  Format the size into a string.
   function Size (Value : in MAT.Types.Target_Size) return String;

   --  Format the memory growth size into a string.
   function Size (Alloced : in MAT.Types.Target_Size;
                  Freed   : in MAT.Types.Target_Size) return String;

   --  Format the time relative to the start time.
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String;

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

   --  Format a file, line, function information into a string.
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String;

   --  Format an event range description.
   function Event (First : in MAT.Events.Target_Event_Type;
                   Last  : in MAT.Events.Target_Event_Type) return String;

   --  Format a short description of the event.
   function Event (Item : in MAT.Events.Target_Event_Type;
                   Mode : in Format_Type := NORMAL) return String;

   --  Format a short description of the event.
   function Event (Item       : in MAT.Events.Target_Event_Type;
                   Related    : in MAT.Events.Tools.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  Format the difference between two event IDs (offset).
   function Offset (First  : in MAT.Events.Event_Id_Type;
                    Second : in MAT.Events.Event_Id_Type) return String;

   --  Format a short description of the memory allocation slot.
   function Slot (Value      : in MAT.Types.Target_Addr;
                  Item       : in MAT.Memory.Allocation;
                  Start_Time : in MAT.Types.Target_Tick_Ref) return String;

end MAT.Formats;

Declare the Offset function to format an event Id difference


-----------------------------------------------------------------------
--  ado-queries-tests -- Test loading of database queries
--  Copyright (C) 2011, 2012, 2013, 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.
-----------------------------------------------------------------------

with Util.Test_Caller;
with Util.Properties;

with ADO.Drivers.Connections;
with ADO.Queries.Loaders;
package body ADO.Queries.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Queries.Read_Query",
                       Test_Load_Queries'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Initialize",
                       Test_Initialize'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Set_Query",
                       Test_Set_Query'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Set_Limit",
                       Test_Set_Limit'Access);
   end Add_Tests;

   package Simple_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/simple-query.xml",
                                   Sha1 => "");

   package Multi_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/multi-query.xml",
                                   Sha1 => "");

   package Simple_Query is
     new ADO.Queries.Loaders.Query (Name => "simple-query",
                                    File => Simple_Query_File.File'Access);

   package Simple_Query_2 is
     new ADO.Queries.Loaders.Query (Name => "simple-query",
                                    File => Multi_Query_File.File'Access);

   package Index_Query is
     new ADO.Queries.Loaders.Query (Name => "index",
                                    File => Multi_Query_File.File'Access);

   package Value_Query is
     new ADO.Queries.Loaders.Query (Name => "value",
                                    File => Multi_Query_File.File'Access);

   pragma Warnings (Off, Simple_Query_2);
   pragma Warnings (Off, Value_Query);

   procedure Test_Load_Queries (T : in out Test) is
      use ADO.Drivers.Connections;

      Mysql_Driver  : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("mysql");
      Sqlite_Driver : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("sqlite");
      Props         : constant Util.Properties.Manager := Util.Tests.Get_Properties;
   begin
      --  Configure the XML query loader.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"),
                                      Props.Get ("ado.queries.load", "false") = "true");

      declare
         SQL : constant String := ADO.Queries.Get_SQL (Simple_Query.Query'Access, 0, False);
      begin
         Assert_Equals (T, "select count(*) from user", SQL, "Invalid query for 'simple-query'");
      end;

      declare
         SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access, 0, False);
      begin
         Assert_Equals (T, "select 0", SQL, "Invalid query for 'index'");
      end;

      if Mysql_Driver /= null then
         declare
            SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access,
                                                          Mysql_Driver.Get_Driver_Index,
                                                          False);
         begin
            Assert_Equals (T, "select 1", SQL, "Invalid query for 'index' (MySQL driver)");
         end;
      end if;
      if Sqlite_Driver /= null then
         declare
            SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access,
                                                          Sqlite_Driver.Get_Driver_Index, False);
         begin
            Assert_Equals (T, "select 0", SQL, "Invalid query for 'index' (SQLite driver)");
         end;
      end if;
   end Test_Load_Queries;

   --  ------------------------------
   --  Test the Initialize operation called several times
   --  ------------------------------
   procedure Test_Initialize (T : in out Test) is
      use ADO.Drivers.Connections;

      Props : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Info  : Query_Info_Ref.Ref;
   begin
      --  Configure and load the XML queries.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"), True);
      T.Assert (not Simple_Query.Query.Query.Get.Is_Null, "The simple query was not loaded");
      T.Assert (not Index_Query.Query.Query.Get.Is_Null, "The index query was not loaded");
      Info := Simple_Query.Query.Query.Get;

      --  Re-configure but do not reload.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"), False);
      T.Assert (Info.Value = Simple_Query.Query.Query.Get.Value,
                "The simple query instance was not changed");

      --  Configure again and reload.  The query info must have changed.
      ADO.Queries.Loaders.Initialize (Props.Get ("ado.queries.paths", ".;db"), True);
      T.Assert (Info.Value /= Simple_Query.Query.Query.Get.Value,
                "The simple query instance was not changed");

      --  Due to the reference held by 'Info', it refers to the data loaded first.
      T.Assert (Length (Info.Value.Main_Query (0).SQL) > 0, "The old query is not valid");
   end Test_Initialize;

   --  ------------------------------
   --  Test the Set_Query operation.
   --  ------------------------------
   procedure Test_Set_Query (T : in out Test) is
      Query : ADO.Queries.Context;
   begin
      Query.Set_Query ("simple-query");

      declare
         SQL : constant String := Query.Get_SQL (0);
      begin
         Assert_Equals (T, "select count(*) from user", SQL, "Invalid query for 'simple-query'");
      end;
   end Test_Set_Query;

   --  ------------------------------
   --  Test the Set_Limit operation.
   --  ------------------------------
   procedure Test_Set_Limit (T : in out Test) is
      Query : ADO.Queries.Context;
   begin
      Query.Set_Query ("index");
      Query.Set_Limit (0, 10);
      Assert_Equals (T, 0, Query.Get_First_Row_Index, "Invalid first row index");
      Assert_Equals (T, 10, Query.Get_Last_Row_Index, "Invalid last row index");
   end Test_Set_Limit;

end ADO.Queries.Tests;

-----------------------------------------------------------------------
--  ado-queries-tests -- Test loading of database queries
--  Copyright (C) 2011, 2012, 2013, 2014, 2015, 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.Test_Caller;
with Util.Properties;

with ADO.Drivers.Connections;
with ADO.Queries.Loaders;
package body ADO.Queries.Tests is

   use Util.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Queries.Read_Query",
                       Test_Load_Queries'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Initialize",
                       Test_Initialize'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Set_Query",
                       Test_Set_Query'Access);
      Caller.Add_Test (Suite, "Test ADO.Queries.Set_Limit",
                       Test_Set_Limit'Access);
   end Add_Tests;

   package Simple_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/simple-query.xml",
                                   Sha1 => "");

   package Multi_Query_File is
     new ADO.Queries.Loaders.File (Path => "regtests/files/multi-query.xml",
                                   Sha1 => "");

   package Simple_Query is
     new ADO.Queries.Loaders.Query (Name => "simple-query",
                                    File => Simple_Query_File.File'Access);

   package Simple_Query_2 is
     new ADO.Queries.Loaders.Query (Name => "simple-query",
                                    File => Multi_Query_File.File'Access);

   package Index_Query is
     new ADO.Queries.Loaders.Query (Name => "index",
                                    File => Multi_Query_File.File'Access);

   package Value_Query is
     new ADO.Queries.Loaders.Query (Name => "value",
                                    File => Multi_Query_File.File'Access);

   pragma Warnings (Off, Simple_Query_2);
   pragma Warnings (Off, Value_Query);

   procedure Test_Load_Queries (T : in out Test) is
      use ADO.Drivers.Connections;
      use type ADO.Drivers.Driver_Index;

      Mysql_Driver  : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("mysql");
      Sqlite_Driver : constant Driver_Access := ADO.Drivers.Connections.Get_Driver ("sqlite");
      Props         : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Config        : ADO.Drivers.Connections.Configuration;
      Manager       : Query_Manager;
   begin
      --  Configure the XML query loader.
      ADO.Queries.Loaders.Initialize (Manager, Config);

      declare
         SQL : constant String := ADO.Queries.Get_SQL (Simple_Query.Query'Access, Manager, False);
      begin
         Assert_Equals (T, "select count(*) from user", SQL, "Invalid query for 'simple-query'");
      end;

      declare
         SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access, Manager, False);
      begin
         Assert_Equals (T, "select 0", SQL, "Invalid query for 'index'");
      end;

      if Mysql_Driver /= null and then Manager.Driver = Mysql_Driver.Get_Driver_Index then
         declare
            SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access,
                                                          Manager,
                                                          False);
         begin
            Assert_Equals (T, "select 1", SQL, "Invalid query for 'index' (MySQL driver)");
         end;
      end if;
      if Sqlite_Driver /= null then
         declare
            SQL : constant String := ADO.Queries.Get_SQL (Index_Query.Query'Access,
                                                          Manager, False);
         begin
            Assert_Equals (T, "select 0", SQL, "Invalid query for 'index' (SQLite driver)");
         end;
      end if;
   end Test_Load_Queries;

   --  ------------------------------
   --  Test the Initialize operation called several times
   --  ------------------------------
   procedure Test_Initialize (T : in out Test) is
      use ADO.Drivers.Connections;

      Props : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Config        : ADO.Drivers.Connections.Configuration;
      Manager : Query_Manager;
      Info  : Query_Info_Ref.Ref;
   begin
      --  Configure and load the XML queries.
      ADO.Queries.Loaders.Initialize (Manager, Config);
      --  T.Assert (not Simple_Query.Query.Query.Get.Is_Null, "The simple query was not loaded");
      --  T.Assert (not Index_Query.Query.Query.Get.Is_Null, "The index query was not loaded");
--        Info := Simple_Query.Query.Query.Get;

      --  Re-configure but do not reload.
      ADO.Queries.Loaders.Initialize (Manager, Config);
--        T.Assert (Info.Value = Simple_Query.Query.Query.Get.Value,
--                  "The simple query instance was not changed");

      --  Configure again and reload.  The query info must have changed.
      ADO.Queries.Loaders.Initialize (Manager, Config);
--        T.Assert (Info.Value /= Simple_Query.Query.Query.Get.Value,
--                  "The simple query instance was not changed");

      --  Due to the reference held by 'Info', it refers to the data loaded first.
--        T.Assert (Length (Info.Value.Main_Query (0).SQL) > 0, "The old query is not valid");
   end Test_Initialize;

   --  ------------------------------
   --  Test the Set_Query operation.
   --  ------------------------------
   procedure Test_Set_Query (T : in out Test) is
      Query : ADO.Queries.Context;
      Props : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Manager : Query_Manager;
      Config        : ADO.Drivers.Connections.Configuration;
   begin
      ADO.Queries.Loaders.Initialize (Manager, Config);
      Query.Set_Query ("simple-query");

      declare
         SQL : constant String := Query.Get_SQL (Manager);
      begin
         Assert_Equals (T, "select count(*) from user", SQL, "Invalid query for 'simple-query'");
      end;
   end Test_Set_Query;

   --  ------------------------------
   --  Test the Set_Limit operation.
   --  ------------------------------
   procedure Test_Set_Limit (T : in out Test) is
      Query : ADO.Queries.Context;
      Props : constant Util.Properties.Manager := Util.Tests.Get_Properties;
      Config        : ADO.Drivers.Connections.Configuration;
      Manager : Query_Manager;
   begin
      ADO.Queries.Loaders.Initialize (Manager, Config);
      Query.Set_Query ("index");
      Query.Set_Limit (0, 10);
      Assert_Equals (T, 0, Query.Get_First_Row_Index, "Invalid first row index");
      Assert_Equals (T, 10, Query.Get_Last_Row_Index, "Invalid last row index");
   end Test_Set_Limit;

end ADO.Queries.Tests;

Update the tests to use the Query_Manager


------------------------------------------------------------------------------
--                                                                          --
--                       Copyright (C) 2017, 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.   --
--                                                                          --
------------------------------------------------------------------------------

package HiFive1 is
end HiFive1;

------------------------------------------------------------------------------
--                                                                          --
--                       Copyright (C) 2017, 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 FE310.Device; use FE310.Device;
with FE310.GPIO;   use FE310.GPIO;

package HiFive1 is

   HF1_Pin_0  : GPIO_Point renames P16;
   HF1_Pin_1  : GPIO_Point renames P17;
   HF1_Pin_2  : GPIO_Point renames P18;
   HF1_Pin_3  : GPIO_Point renames P19; --  Green LED
   HF1_Pin_4  : GPIO_Point renames P20;
   HF1_Pin_5  : GPIO_Point renames P21; --  Blue LED
   HF1_Pin_6  : GPIO_Point renames P22; --  Red LED
   HF1_Pin_7  : GPIO_Point renames P23;
   HF1_Pin_8  : GPIO_Point renames P00;
   HF1_Pin_9  : GPIO_Point renames P01;
   HF1_Pin_10 : GPIO_Point renames P02;
   HF1_Pin_11 : GPIO_Point renames P03;
   HF1_Pin_12 : GPIO_Point renames P04;
   HF1_Pin_13 : GPIO_Point renames P05;
   --  HF1_Pin_14 is not connected
   HF1_Pin_15 : GPIO_Point renames P09;
   HF1_Pin_16 : GPIO_Point renames P10;
   HF1_Pin_17 : GPIO_Point renames P11;
   HF1_Pin_18 : GPIO_Point renames P12;
   HF1_Pin_19 : GPIO_Point renames P13;

end HiFive1;

Add pin definitions

HiFive1: Add pin definitions