-----------------------------------------------------------------------
--  util-strings -- Various String Utility
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings;
with Ada.Strings.Unbounded;
with Ada.Containers;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Hashed_Sets;
private with Util.Concurrent.Counters;
package Util.Strings is

   pragma Preelaborate;

   --  Constant string access
   type Name_Access is access constant String;

   --  Compute the hash value of the string.
   function Hash (Key : Name_Access) return Ada.Containers.Hash_Type;

   --  Returns true if left and right strings are equivalent.
   function Equivalent_Keys (Left, Right : Name_Access) return Boolean;

   --  Search for the first occurrence of the character in the string
   --  after the from index.  This implementation is 3-times faster than
   --  the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Index (Source : in String;
                   Char   : in Character;
                   From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the character in the string
   --  before the from index and going backward.
   --  This implementation is 3-times faster than the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Rindex (Source : in String;
                    Ch     : in Character;
                    From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the pattern in the string.
   function Index (Source  : in String;
                   Pattern : in String;
                   From    : in Positive;
                   Going   : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Integer) return String;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Long_Long_Integer) return String;

   package String_Access_Map is new Ada.Containers.Hashed_Maps
     (Key_Type        => Name_Access,
      Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Keys => Equivalent_Keys);

   package String_Set is new Ada.Containers.Hashed_Sets
     (Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Elements => Equivalent_Keys);

   --  String reference
   type String_Ref is private;

   --  Create a string reference from a string.
   function To_String_Ref (S : in String) return String_Ref;

   --  Create a string reference from an unbounded string.
   function To_String_Ref (S : in Ada.Strings.Unbounded.Unbounded_String) return String_Ref;

   --  Get the string
   function To_String (S : in String_Ref) return String;

   --  Get the string as an unbounded string
   function To_Unbounded_String (S : in String_Ref) return Ada.Strings.Unbounded.Unbounded_String;

   --  Compute the hash value of the string reference.
   function Hash (Key : in String_Ref) return Ada.Containers.Hash_Type;

   --  Returns true if left and right string references are equivalent.
   function Equivalent_Keys (Left, Right : in String_Ref) return Boolean;
   function "=" (Left, Right : in String_Ref) return Boolean renames Equivalent_Keys;
   function "=" (Left  : in String_Ref;
                 Right : in String) return Boolean;
   function "=" (Left  : in String_Ref;
                 Right : in Ada.Strings.Unbounded.Unbounded_String) return Boolean;

   --  Returns the string length.
   function Length (S : in String_Ref) return Natural;

private
   pragma Inline (To_String_Ref);
   pragma Inline (To_String);

   type String_Record (Len : Natural) is limited record
      Counter : Util.Concurrent.Counters.Counter;
      Str     : String (1 .. Len);
   end record;
   type String_Record_Access is access all String_Record;

   type String_Ref is new Ada.Finalization.Controlled with record
      Str : String_Record_Access := null;
   end record;

   --  Increment the reference counter.
   overriding
   procedure Adjust (Object : in out String_Ref);

   --  Decrement the reference counter and free the allocated string.
   overriding
   procedure Finalize (Object : in out String_Ref);

end Util.Strings;

-----------------------------------------------------------------------
--  util-strings -- Various String Utility
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings;
with Ada.Strings.Unbounded;
with Ada.Containers;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Hashed_Sets;
private with Util.Concurrent.Counters;
package Util.Strings is

   pragma Preelaborate;

   --  Constant string access
   type Name_Access is access constant String;

   --  Compute the hash value of the string.
   function Hash (Key : Name_Access) return Ada.Containers.Hash_Type;

   --  Returns true if left and right strings are equivalent.
   function Equivalent_Keys (Left, Right : Name_Access) return Boolean;

   --  Search for the first occurrence of the character in the string
   --  after the from index.  This implementation is 3-times faster than
   --  the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Index (Source : in String;
                   Char   : in Character;
                   From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the character in the string
   --  before the from index and going backward.
   --  This implementation is 3-times faster than the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Rindex (Source : in String;
                    Ch     : in Character;
                    From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the pattern in the string.
   function Index (Source  : in String;
                   Pattern : in String;
                   From    : in Positive;
                   Going   : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural;

   --  Returns True if the source string starts with the given prefix.
   function Starts_With (Source  : in String;
                         Prefix  : in String) return Boolean;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Integer) return String;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Long_Long_Integer) return String;

   package String_Access_Map is new Ada.Containers.Hashed_Maps
     (Key_Type        => Name_Access,
      Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Keys => Equivalent_Keys);

   package String_Set is new Ada.Containers.Hashed_Sets
     (Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Elements => Equivalent_Keys);

   --  String reference
   type String_Ref is private;

   --  Create a string reference from a string.
   function To_String_Ref (S : in String) return String_Ref;

   --  Create a string reference from an unbounded string.
   function To_String_Ref (S : in Ada.Strings.Unbounded.Unbounded_String) return String_Ref;

   --  Get the string
   function To_String (S : in String_Ref) return String;

   --  Get the string as an unbounded string
   function To_Unbounded_String (S : in String_Ref) return Ada.Strings.Unbounded.Unbounded_String;

   --  Compute the hash value of the string reference.
   function Hash (Key : in String_Ref) return Ada.Containers.Hash_Type;

   --  Returns true if left and right string references are equivalent.
   function Equivalent_Keys (Left, Right : in String_Ref) return Boolean;
   function "=" (Left, Right : in String_Ref) return Boolean renames Equivalent_Keys;
   function "=" (Left  : in String_Ref;
                 Right : in String) return Boolean;
   function "=" (Left  : in String_Ref;
                 Right : in Ada.Strings.Unbounded.Unbounded_String) return Boolean;

   --  Returns the string length.
   function Length (S : in String_Ref) return Natural;

private
   pragma Inline (To_String_Ref);
   pragma Inline (To_String);

   type String_Record (Len : Natural) is limited record
      Counter : Util.Concurrent.Counters.Counter;
      Str     : String (1 .. Len);
   end record;
   type String_Record_Access is access all String_Record;

   type String_Ref is new Ada.Finalization.Controlled with record
      Str : String_Record_Access := null;
   end record;

   --  Increment the reference counter.
   overriding
   procedure Adjust (Object : in out String_Ref);

   --  Decrement the reference counter and free the allocated string.
   overriding
   procedure Finalize (Object : in out String_Ref);

end Util.Strings;

Declare the Starts_With function to check if a string starts with a given prefix


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

with Wiki.Attributes;
with Wiki.Documents;
with Wiki.Filters;

--  == Plugins ==
--  The <b>Wiki.Plugins</b> package defines the plugin interface that is used by the wiki
--  engine to provide pluggable extensions in the Wiki.
--
package Wiki.Plugins is

   pragma Preelaborate;

   type Plugin_Context;

   type Wiki_Plugin is limited interface;
   type Wiki_Plugin_Access is access all Wiki_Plugin'Class;
   type Plugin_Factory is limited interface;
   type Plugin_Factory_Access is access all Plugin_Factory'Class;

   --  Find a plugin knowing its name.
   function Find (Factory : in Plugin_Factory;
                  Name    : in String) return Wiki_Plugin_Access is abstract;

   type Plugin_Context is limited record
      Previous    : access Plugin_Context;
      Filters     : Wiki.Filters.Filter_Chain;
      Factory     : Plugin_Factory_Access;
      Variables   : Wiki.Attributes.Attribute_List;
      Syntax      : Wiki.Wiki_Syntax;
      Is_Hidden   : Boolean := False;
      Is_Included : Boolean := False;
   end record;

   --  Expand the plugin configured with the parameters for the document.
   procedure Expand (Plugin   : in out Wiki_Plugin;
                     Document : in out Wiki.Documents.Document;
                     Params   : in out Wiki.Attributes.Attribute_List;
                     Context  : in Plugin_Context) is abstract;

end Wiki.Plugins;

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

with Wiki.Attributes;
with Wiki.Documents;
with Wiki.Filters;
with Wiki.Strings;

--  == Plugins ==
--  The <b>Wiki.Plugins</b> package defines the plugin interface that is used by the wiki
--  engine to provide pluggable extensions in the Wiki.
--
package Wiki.Plugins is

   pragma Preelaborate;

   type Plugin_Context;

   type Wiki_Plugin is limited interface;
   type Wiki_Plugin_Access is access all Wiki_Plugin'Class;
   type Plugin_Factory is limited interface;
   type Plugin_Factory_Access is access all Plugin_Factory'Class;

   --  Find a plugin knowing its name.
   function Find (Factory : in Plugin_Factory;
                  Name    : in String) return Wiki_Plugin_Access is abstract;

   type Plugin_Context is limited record
      Previous    : access Plugin_Context;
      Filters     : Wiki.Filters.Filter_Chain;
      Factory     : Plugin_Factory_Access;
      Variables   : Wiki.Attributes.Attribute_List;
      Syntax      : Wiki.Wiki_Syntax;
      Ident       : Wiki.Strings.UString;
      Is_Hidden   : Boolean := False;
      Is_Included : Boolean := False;
   end record;

   --  Expand the plugin configured with the parameters for the document.
   procedure Expand (Plugin   : in out Wiki_Plugin;
                     Document : in out Wiki.Documents.Document;
                     Params   : in out Wiki.Attributes.Attribute_List;
                     Context  : in Plugin_Context) is abstract;

end Wiki.Plugins;

Add an Ident member to the wiki context

Add an Ident member to the wiki context


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

with Ada.Real_Time; use Ada.Real_Time;

with STM32.RCC;     use STM32.RCC;

with STM32_SVD.I2C; use STM32_SVD.I2C;

package body STM32.I2C is

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

   procedure Configure
     (Port        : in out I2C_Port;
      Clock_Speed : Word;
      Mode        : I2C_Device_Mode;
      Duty_Cycle  : I2C_Duty_Cycle;
      Own_Address : Half_Word;
      Ack         : I2C_Acknowledgement;
      Ack_Address : I2C_Acknowledge_Address)
   is
      CR1        : CR1_Register;
      CCR        : CCR_Register;
      OAR1       : OAR1_Register;
      PCLK1      : constant Word := System_Clock_Frequencies.PCLK1;
      Freq_Range : constant Half_Word := Half_Word (PCLK1 / 1_000_000);
   begin
      --  Load CR2 and clear FREQ
      Port.CR2 :=
        (LAST    => 0,
         DMAEN   => 0,
         ITBUFEN => 0,
         ITEVTEN => 0,
         ITERREN => 0,
         FREQ    => UInt6 (Freq_Range),
         others  => <>);

      Set_State (Port, Disabled);

      if Clock_Speed <= 100_000 then
        --  Mode selection to Standard Mode
         CCR.F_S := 0;
         CCR.CCR := UInt12 (PCLK1 / (Clock_Speed * 2));

         if CCR.CCR < 4 then
            CCR.CCR := 4;
         end if;

         Port.TRISE.TRISE := UInt6 (Freq_Range + 1);

      else
         --  Fast mode
         CCR.F_S := 1;

         if Duty_Cycle = DutyCycle_2 then
            CCR.CCR := UInt12 (Pclk1 / (Clock_Speed * 3));
         else
            CCR.CCR := UInt12 (Pclk1 / (Clock_Speed * 25));
            CCR.DUTY := 1;
         end if;

         if CCR.CCR = 0 then
            CCR.CCR := 1;
         end if;

         CCR.CCR := CCR.CCR or 16#80#;

         Port.TRISE.TRISE := UInt6 ((Word (Freq_Range) * 300) / 1000 + 1);
      end if;

      Port.CCR := CCR;

      Set_State (Port, Enabled);

      CR1 := Port.CR1;
      case Mode is
         when I2C_Mode =>
            CR1.SMBUS := 0;
            CR1.SMBTYPE := 0;
         when SMBusDevice_Mode =>
            CR1.SMBUS := 1;
            CR1.SMBTYPE := 0;
         when SMBusHost_Mode =>
            CR1.SMBUS := 1;
            CR1.SMBTYPE := 1;
      end case;
      CR1.ACK := I2C_Acknowledgement'Enum_Rep (Ack);
      Port.CR1 := CR1;

      OAR1.ADDMODE := (if Ack_Address = AcknowledgedAddress_10bit
                       then 1 else 0);
      case Ack_Address is
         when AcknowledgedAddress_7bit =>
            OAR1.ADD0  := 0;
            OAR1.ADD7  := UInt7 (Own_Address / 2);
            OAR1.ADD10 := 0;
         when AcknowledgedAddress_10bit =>
            OAR1.Add0  := Bit (Own_Address and 2#1#);
            OAR1.ADD7  := UInt7 ((Own_Address / 2) and 2#1111111#);
            OAR1.Add10 := UInt2 (Own_Address / 2 ** 8);
      end case;

      Port.OAR1 := OAR1;
   end Configure;

   ---------------
   -- Set_State --
   ---------------

   procedure Set_State (Port : in out I2C_Port; State : I2C_State) is
   begin
      Port.CR1.PE := (if State = Enabled then 1 else 0);
   end Set_State;

   ------------------
   -- Port_Enabled --
   ------------------

   function Port_Enabled (Port : I2C_Port) return Boolean is
   begin
      return Port.CR1.PE = 1;
   end Port_Enabled;

   --------------------
   -- Generate_Start --
   --------------------

   procedure Generate_Start (Port : in out I2C_Port; State : I2C_State) is
   begin
      Port.CR1.START := (if State = Enabled then 1 else 0);
   end Generate_Start;

   -------------------
   -- Generate_Stop --
   -------------------

   procedure Generate_Stop (Port : in out I2C_Port; State : I2C_State) is
   begin
      Port.CR1.STOP := (if State = Enabled then 1 else 0);
   end Generate_Stop;

   --------------------
   -- Send_7Bit_Addr --
   --------------------

   procedure Send_7Bit_Address
     (Port      : in out I2C_Port;
      Address   : Byte;
      Direction : I2C_Direction)
   is
      Destination : Byte;
   begin
      if Direction = Receiver then
         Destination := Address or 2#1#;
      else
         Destination := Address and (not 2#1#);
      end if;

      Port.DR.DR := Destination;
   end Send_7Bit_Address;

   --------------
   -- Get_Flag --
   --------------

   function Status (Port : I2C_Port; Flag : I2C_Status_Flag) return Boolean is
   begin
      case Flag is
         when Start_Bit =>
            return Port.SR1.SB = 1;
         when Address_Sent =>
            return Port.SR1.ADDR = 1;
         when Byte_Transfer_Finished =>
            return Port.SR1.BTF = 1;
         when Address_Sent_10bit =>
            return Port.SR1.ADD10 = 1;
         when Stop_Detection =>
            return Port.SR1.STOPF = 1;
         when Rx_Data_Register_Not_Empty =>
            return Port.SR1.RxNE = 1;
         when Tx_Data_Register_Empty =>
            return Port.SR1.TxE = 1;
         when Bus_Error =>
            return Port.SR1.BERR = 1;
         when Arbitration_Lost =>
            return Port.SR1.ARLO = 1;
         when Ack_Failure =>
            return Port.SR1.AF = 1;
         when UnderOverrun =>
            return Port.SR1.OVR = 1;
         when Packet_Error =>
            return Port.SR1.PECERR = 1;
         when Timeout =>
            return Port.SR1.TIMEOUT = 1;
         when SMB_Alert =>
            return Port.SR1.SMBALERT = 1;
         when Master_Slave_Mode =>
            return Port.SR2.MSL = 1;
         when Busy =>
            return Port.SR2.BUSY = 1;
         when Transmitter_Receiver_Mode =>
            return Port.SR2.TRA = 1;
         when General_Call =>
            return Port.SR2.GENCALL = 1;
         when SMB_Default =>
            return Port.SR2.SMBDEFAULT = 1;
         when SMB_Host =>
            return Port.SR2.SMBHOST = 1;
         when Dual_Flag =>
            return Port.SR2.DUALF = 1;
      end case;
   end Status;

   ----------------
   -- Clear_Flag --
   ----------------

   procedure Clear_Status
     (Port   : in out I2C_Port;
      Target : Clearable_I2C_Status_Flag)
   is
      Unref  : Bit with Unreferenced;
   begin
      case Target is
         when Bus_Error =>
            Port.SR1.BERR := 0;
         when Arbitration_Lost =>
            Port.SR1.ARLO := 0;
         when Ack_Failure =>
            Port.SR1.AF := 0;
         when UnderOverrun =>
            Port.SR1.OVR := 0;
         when Packet_Error =>
            Port.SR1.PECERR := 0;
         when Timeout =>
            Port.SR1.TIMEOUT := 0;
         when SMB_Alert =>
            Port.SR1.SMBALERT := 0;
      end case;
   end Clear_Status;

   -------------------------------
   -- Clear_Address_Sent_Status --
   -------------------------------

   procedure Clear_Address_Sent_Status (Port : in out I2C_Port)
   is
      Unref  : Bit with Volatile, Unreferenced;
   begin
      --  To clear the ADDR flag we have to read SR2 after reading SR1.
      --  However, per the RM, section 27.6.7, page 850, we should only read
      --  SR2 if the Address_Sent flag is set in SR1, or if the Stop_Detection
      --  flag is cleared, because the Address_Sent flag could be set in
      --  the middle of reading SR1 and SR2 but will be cleared by the
      --  read sequence nonetheless.
      if Status (Port, Start_Bit) or else Status (Port, Stop_Detection) then
         Unref := Port.SR2.MSL;
      end if;
   end Clear_Address_Sent_Status;

   ---------------------------------
   -- Clear_Stop_Detection_Status --
   ---------------------------------

   procedure Clear_Stop_Detection_Status (Port : in out I2C_Port) is
      Unref  : Bit with Volatile, Unreferenced;
   begin
      Unref := Port.SR1.STOPF;
      Port.CR1.PE := 1;
   end Clear_Stop_Detection_Status;

   -------------------
   -- Wait_For_Flag --
   -------------------

   procedure Wait_For_State
     (Port     : I2C_Port;
      Queried  : I2C_Status_Flag;
      State    : I2C_State;
      Time_Out : Natural := 1_000)
   is
      Expected : constant Boolean := State = Enabled;
      Deadline : constant Time := Clock + Milliseconds (Time_Out);
   begin
      while Status (Port, Queried) /= Expected loop
         if Clock >= Deadline then
            raise I2C_Timeout;
         end if;
      end loop;
   end Wait_For_State;

   ---------------
   -- Send_Data --
   ---------------

   procedure Send_Data (Port : in out I2C_Port; Data : Byte) is
   begin
      Port.DR.DR := Data;
   end Send_Data;

   ---------------
   -- Read_Data --
   ---------------

   function Read_Data (Port : I2C_Port) return Byte is
   begin
      return Port.DR.DR;
   end Read_Data;

   --------------------
   -- Set_Ack_Config --
   --------------------

   procedure Set_Ack_Config (Port : in out I2C_Port; State : I2C_State) is
   begin
      Port.CR1.ACK := (if State = Enabled then 1 else 0);
   end Set_Ack_Config;

   ---------------------
   -- Set_Nack_Config --
   ---------------------

   procedure Set_Nack_Config
     (Port : in out I2C_Port;
      Pos  : I2C_Nack_Position)
   is
   begin
      Port.CR1.POS := (if Pos = Next then 1 else 0);
   end Set_Nack_Config;

   -----------
   -- Start --
   -----------

   procedure Start
     (Port      : in out I2C_Port;
      Address   : Byte;
      Direction : I2C_Direction)
   is
   begin
      Generate_Start (Port, Enabled);
      Wait_For_State (Port, Start_Bit, Enabled);

      Set_Ack_Config (Port, Enabled);

      Send_7Bit_Address (Port, Address, Direction);

      while not Status (Port, Address_Sent) loop
         if Status (Port, Ack_Failure) then
            raise Program_Error;
         end if;
      end loop;
      Clear_Address_Sent_Status (Port);
   end Start;

   --------------
   -- Read_Ack --
   --------------

   function Read_Ack (Port : in out I2C_Port) return Byte is
   begin
      Set_Ack_Config (Port, Enabled);
      Wait_For_State (Port, Rx_Data_Register_Not_Empty, Enabled);
      return Read_Data (Port);
   end Read_Ack;

   ---------------
   -- Read_Nack --
   ---------------

   function Read_Nack (Port : in out I2C_Port) return Byte is
   begin
      Set_Ack_Config (Port, Disabled);
      Generate_Stop (Port, Enabled);
      Wait_For_State (Port, Rx_Data_Register_Not_Empty, Enabled);
      return Read_Data (Port);
   end Read_Nack;

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

   procedure Write (Port : in out I2C_Port; Data : Byte) is
   begin
      Wait_For_State (Port, Tx_Data_Register_Empty, Enabled);
      Send_Data (Port, Data);

      while
        not Status (Port, Tx_Data_Register_Empty) or else
        not Status (Port, Byte_Transfer_Finished)
      loop
         null;
      end loop;
   end Write;

   ----------
   -- Stop --
   ----------

   procedure Stop (Port : in out I2C_Port) is
   begin
      Generate_Stop (Port, Enabled);
   end Stop;

   ----------------------
   -- Enable_Interrupt --
   ----------------------

   procedure Enable_Interrupt
     (Port   : in out I2C_Port;
      Source : I2C_Interrupt)
   is
   begin
      case Source is
         when Error_Interrupt =>
            Port.CR2.ITERREN := 1;
         when Event_Interrupt =>
            Port.CR2.ITEVTEN := 1;
         when Buffer_Interrupt =>
            Port.CR2.ITBUFEN := 1;
      end case;
   end Enable_Interrupt;

   -----------------------
   -- Disable_Interrupt --
   -----------------------

   -----------------------
   -- Disable_Interrupt --
   -----------------------

   procedure Disable_Interrupt
     (Port   : in out I2C_Port;
      Source : I2C_Interrupt)
   is
   begin
      case Source is
         when Error_Interrupt =>
            Port.CR2.ITERREN := 0;
         when Event_Interrupt =>
            Port.CR2.ITEVTEN := 0;
         when Buffer_Interrupt =>
            Port.CR2.ITBUFEN := 0;
      end case;
   end Disable_Interrupt;

   -------------
   -- Enabled --
   -------------

   function Enabled
     (Port   : in out I2C_Port;
      Source : I2C_Interrupt)
      return Boolean
   is
   begin
      case Source is
         when Error_Interrupt =>
            return Port.CR2.ITERREN = 1;
         when Event_Interrupt =>
            return Port.CR2.ITEVTEN = 1;
         when Buffer_Interrupt =>
            return Port.CR2.ITBUFEN = 1;
      end case;
   end Enabled;

end STM32.I2C;

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

with Ada.Real_Time; use Ada.Real_Time;

with STM32.RCC;     use STM32.RCC;

with STM32_SVD.I2C; use STM32_SVD.I2C;

package body STM32.I2C is

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

   procedure Configure
     (Port        : in out I2C_Port;
      Clock_Speed : Word;
      Mode        : I2C_Device_Mode;
      Duty_Cycle  : I2C_Duty_Cycle;
      Own_Address : Half_Word;
      Ack         : I2C_Acknowledgement;
      Ack_Address : I2C_Acknowledge_Address)
   is
      CR1        : CR1_Register;
      CCR        : CCR_Register;
      OAR1       : OAR1_Register;
      PCLK1      : constant Word := System_Clock_Frequencies.PCLK1;
      Freq_Range : constant Half_Word := Half_Word (PCLK1 / 1_000_000);
   begin
      if Freq_Range < 2 or else Freq_Range > 42 then
         raise Program_Error with
           "PCLK1 too high or too low: expected 2-42 MHz, current" &
           Freq_Range'Img & " MHz";
      end if;

      --  Load CR2 and clear FREQ
      Port.CR2 :=
        (LAST    => 0,
         DMAEN   => 0,
         ITBUFEN => 0,
         ITEVTEN => 0,
         ITERREN => 0,
         FREQ    => UInt6 (Freq_Range),
         others  => <>);

      Set_State (Port, Disabled);

      if Clock_Speed <= 100_000 then
        --  Mode selection to Standard Mode
         CCR.F_S := 0;
         CCR.CCR := UInt12 (PCLK1 / (Clock_Speed * 2));

         if CCR.CCR < 4 then
            CCR.CCR := 4;
         end if;

         Port.TRISE.TRISE := UInt6 (Freq_Range + 1);

      else
         --  Fast mode
         CCR.F_S := 1;

         if Duty_Cycle = DutyCycle_2 then
            CCR.CCR := UInt12 (Pclk1 / (Clock_Speed * 3));
         else
            CCR.CCR := UInt12 (Pclk1 / (Clock_Speed * 25));
            CCR.DUTY := 1;
         end if;

         if CCR.CCR = 0 then
            CCR.CCR := 1;
         end if;

         CCR.CCR := CCR.CCR or 16#80#;

         Port.TRISE.TRISE := UInt6 ((Word (Freq_Range) * 300) / 1000 + 1);
      end if;

      Port.CCR := CCR;

      Set_State (Port, Enabled);

      CR1 := Port.CR1;
      case Mode is
         when I2C_Mode =>
            CR1.SMBUS := 0;
            CR1.SMBTYPE := 0;
         when SMBusDevice_Mode =>
            CR1.SMBUS := 1;
            CR1.SMBTYPE := 0;
         when SMBusHost_Mode =>
            CR1.SMBUS := 1;
            CR1.SMBTYPE := 1;
      end case;
      CR1.ACK := I2C_Acknowledgement'Enum_Rep (Ack);
      Port.CR1 := CR1;

      OAR1.ADDMODE := (if Ack_Address = AcknowledgedAddress_10bit
                       then 1 else 0);
      case Ack_Address is
         when AcknowledgedAddress_7bit =>
            OAR1.ADD0  := 0;
            OAR1.ADD7  := UInt7 (Own_Address / 2);
            OAR1.ADD10 := 0;
         when AcknowledgedAddress_10bit =>
            OAR1.Add0  := Bit (Own_Address and 2#1#);
            OAR1.ADD7  := UInt7 ((Own_Address / 2) and 2#1111111#);
            OAR1.Add10 := UInt2 (Own_Address / 2 ** 8);
      end case;

      Port.OAR1 := OAR1;
   end Configure;

   ---------------
   -- Set_State --
   ---------------

   procedure Set_State (Port : in out I2C_Port; State : I2C_State) is
   begin
      Port.CR1.PE := (if State = Enabled then 1 else 0);
   end Set_State;

   ------------------
   -- Port_Enabled --
   ------------------

   function Port_Enabled (Port : I2C_Port) return Boolean is
   begin
      return Port.CR1.PE = 1;
   end Port_Enabled;

   --------------------
   -- Generate_Start --
   --------------------

   procedure Generate_Start (Port : in out I2C_Port; State : I2C_State) is
   begin
      Port.CR1.START := (if State = Enabled then 1 else 0);
   end Generate_Start;

   -------------------
   -- Generate_Stop --
   -------------------

   procedure Generate_Stop (Port : in out I2C_Port; State : I2C_State) is
   begin
      Port.CR1.STOP := (if State = Enabled then 1 else 0);
   end Generate_Stop;

   --------------------
   -- Send_7Bit_Addr --
   --------------------

   procedure Send_7Bit_Address
     (Port      : in out I2C_Port;
      Address   : Byte;
      Direction : I2C_Direction)
   is
      Destination : Byte;
   begin
      if Direction = Receiver then
         Destination := Address or 2#1#;
      else
         Destination := Address and (not 2#1#);
      end if;

      Port.DR.DR := Destination;
   end Send_7Bit_Address;

   --------------
   -- Get_Flag --
   --------------

   function Status (Port : I2C_Port; Flag : I2C_Status_Flag) return Boolean is
   begin
      case Flag is
         when Start_Bit =>
            return Port.SR1.SB = 1;
         when Address_Sent =>
            return Port.SR1.ADDR = 1;
         when Byte_Transfer_Finished =>
            return Port.SR1.BTF = 1;
         when Address_Sent_10bit =>
            return Port.SR1.ADD10 = 1;
         when Stop_Detection =>
            return Port.SR1.STOPF = 1;
         when Rx_Data_Register_Not_Empty =>
            return Port.SR1.RxNE = 1;
         when Tx_Data_Register_Empty =>
            return Port.SR1.TxE = 1;
         when Bus_Error =>
            return Port.SR1.BERR = 1;
         when Arbitration_Lost =>
            return Port.SR1.ARLO = 1;
         when Ack_Failure =>
            return Port.SR1.AF = 1;
         when UnderOverrun =>
            return Port.SR1.OVR = 1;
         when Packet_Error =>
            return Port.SR1.PECERR = 1;
         when Timeout =>
            return Port.SR1.TIMEOUT = 1;
         when SMB_Alert =>
            return Port.SR1.SMBALERT = 1;
         when Master_Slave_Mode =>
            return Port.SR2.MSL = 1;
         when Busy =>
            return Port.SR2.BUSY = 1;
         when Transmitter_Receiver_Mode =>
            return Port.SR2.TRA = 1;
         when General_Call =>
            return Port.SR2.GENCALL = 1;
         when SMB_Default =>
            return Port.SR2.SMBDEFAULT = 1;
         when SMB_Host =>
            return Port.SR2.SMBHOST = 1;
         when Dual_Flag =>
            return Port.SR2.DUALF = 1;
      end case;
   end Status;

   ----------------
   -- Clear_Flag --
   ----------------

   procedure Clear_Status
     (Port   : in out I2C_Port;
      Target : Clearable_I2C_Status_Flag)
   is
      Unref  : Bit with Unreferenced;
   begin
      case Target is
         when Bus_Error =>
            Port.SR1.BERR := 0;
         when Arbitration_Lost =>
            Port.SR1.ARLO := 0;
         when Ack_Failure =>
            Port.SR1.AF := 0;
         when UnderOverrun =>
            Port.SR1.OVR := 0;
         when Packet_Error =>
            Port.SR1.PECERR := 0;
         when Timeout =>
            Port.SR1.TIMEOUT := 0;
         when SMB_Alert =>
            Port.SR1.SMBALERT := 0;
      end case;
   end Clear_Status;

   -------------------------------
   -- Clear_Address_Sent_Status --
   -------------------------------

   procedure Clear_Address_Sent_Status (Port : in out I2C_Port)
   is
      Unref  : Bit with Volatile, Unreferenced;
   begin
      --  ADDR is cleared after reading both SR1 and SR2
      Unref := Port.SR1.ADDR;
      Unref := Port.SR2.MSL;
   end Clear_Address_Sent_Status;

   ---------------------------------
   -- Clear_Stop_Detection_Status --
   ---------------------------------

   procedure Clear_Stop_Detection_Status (Port : in out I2C_Port) is
      Unref  : Bit with Volatile, Unreferenced;
   begin
      Unref := Port.SR1.STOPF;
      Port.CR1.PE := 1;
   end Clear_Stop_Detection_Status;

   -------------------
   -- Wait_For_Flag --
   -------------------

   procedure Wait_For_State
     (Port     : I2C_Port;
      Queried  : I2C_Status_Flag;
      State    : I2C_State;
      Time_Out : Natural := 1_000)
   is
      Expected : constant Boolean := State = Enabled;
      Deadline : constant Time := Clock + Milliseconds (Time_Out);
   begin
      while Status (Port, Queried) /= Expected loop
         if Clock >= Deadline then
            raise I2C_Timeout;
         end if;
      end loop;
   end Wait_For_State;

   ---------------
   -- Send_Data --
   ---------------

   procedure Send_Data (Port : in out I2C_Port; Data : Byte) is
   begin
      Port.DR.DR := Data;
   end Send_Data;

   ---------------
   -- Read_Data --
   ---------------

   function Read_Data (Port : I2C_Port) return Byte is
   begin
      return Port.DR.DR;
   end Read_Data;

   --------------------
   -- Set_Ack_Config --
   --------------------

   procedure Set_Ack_Config (Port : in out I2C_Port; State : I2C_State) is
   begin
      Port.CR1.ACK := (if State = Enabled then 1 else 0);
   end Set_Ack_Config;

   ---------------------
   -- Set_Nack_Config --
   ---------------------

   procedure Set_Nack_Config
     (Port : in out I2C_Port;
      Pos  : I2C_Nack_Position)
   is
   begin
      Port.CR1.POS := (if Pos = Next then 1 else 0);
   end Set_Nack_Config;

   -----------
   -- Start --
   -----------

   procedure Start
     (Port      : in out I2C_Port;
      Address   : Byte;
      Direction : I2C_Direction)
   is
   begin
      Generate_Start (Port, Enabled);
      Wait_For_State (Port, Start_Bit, Enabled);

      Set_Ack_Config (Port, Enabled);

      Send_7Bit_Address (Port, Address, Direction);

      while not Status (Port, Address_Sent) loop
         if Status (Port, Ack_Failure) then
            raise Program_Error;
         end if;
      end loop;
      Clear_Address_Sent_Status (Port);
   end Start;

   --------------
   -- Read_Ack --
   --------------

   function Read_Ack (Port : in out I2C_Port) return Byte is
   begin
      Set_Ack_Config (Port, Enabled);
      Wait_For_State (Port, Rx_Data_Register_Not_Empty, Enabled);
      return Read_Data (Port);
   end Read_Ack;

   ---------------
   -- Read_Nack --
   ---------------

   function Read_Nack (Port : in out I2C_Port) return Byte is
   begin
      Set_Ack_Config (Port, Disabled);
      Generate_Stop (Port, Enabled);
      Wait_For_State (Port, Rx_Data_Register_Not_Empty, Enabled);
      return Read_Data (Port);
   end Read_Nack;

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

   procedure Write (Port : in out I2C_Port; Data : Byte) is
   begin
      Wait_For_State (Port, Tx_Data_Register_Empty, Enabled);
      Send_Data (Port, Data);

      while
        not Status (Port, Tx_Data_Register_Empty) or else
        not Status (Port, Byte_Transfer_Finished)
      loop
         null;
      end loop;
   end Write;

   ----------
   -- Stop --
   ----------

   procedure Stop (Port : in out I2C_Port) is
   begin
      Generate_Stop (Port, Enabled);
   end Stop;

   ----------------------
   -- Enable_Interrupt --
   ----------------------

   procedure Enable_Interrupt
     (Port   : in out I2C_Port;
      Source : I2C_Interrupt)
   is
   begin
      case Source is
         when Error_Interrupt =>
            Port.CR2.ITERREN := 1;
         when Event_Interrupt =>
            Port.CR2.ITEVTEN := 1;
         when Buffer_Interrupt =>
            Port.CR2.ITBUFEN := 1;
      end case;
   end Enable_Interrupt;

   -----------------------
   -- Disable_Interrupt --
   -----------------------

   -----------------------
   -- Disable_Interrupt --
   -----------------------

   procedure Disable_Interrupt
     (Port   : in out I2C_Port;
      Source : I2C_Interrupt)
   is
   begin
      case Source is
         when Error_Interrupt =>
            Port.CR2.ITERREN := 0;
         when Event_Interrupt =>
            Port.CR2.ITEVTEN := 0;
         when Buffer_Interrupt =>
            Port.CR2.ITBUFEN := 0;
      end case;
   end Disable_Interrupt;

   -------------
   -- Enabled --
   -------------

   function Enabled
     (Port   : in out I2C_Port;
      Source : I2C_Interrupt)
      return Boolean
   is
   begin
      case Source is
         when Error_Interrupt =>
            return Port.CR2.ITERREN = 1;
         when Event_Interrupt =>
            return Port.CR2.ITEVTEN = 1;
         when Buffer_Interrupt =>
            return Port.CR2.ITBUFEN = 1;
      end case;
   end Enabled;

end STM32.I2C;

Fix the START status clearing of the I2C peripheral.


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

with Util.Test_Caller;
with Util.Assertions;
with Util.Strings;
with Util.Log.Loggers;

package body Wiki.Filters.Html.Tests is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Wiki.Filters");

   package Caller is new Util.Test_Caller (Test, "Wikis.Filters.Html");

   procedure Assert_Equals is
      new Util.Assertions.Assert_Equals_T (Html_Tag_Type);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Wiki.Filters.Html.Find_Tag",
                       Test_Find_Tag'Access);
   end Add_Tests;

   --  Test Find_Tag operation.
   procedure Test_Find_Tag (T : in out Test) is
   begin
      for I in Html_Tag_Type'Range loop
         declare
            Name : constant String := Html_Tag_Type'Image (I);
            Wname : constant Wide_Wide_String := Html_Tag_Type'Wide_Wide_Image (I);
            Pos  : constant Natural := Util.Strings.Index (Name, '_');
            Tag  : constant Html_Tag_Type := Find_Tag (WName (WName'First .. Pos - 1));
         begin
            Log.Info ("Checking tag {0}", Name);
            Assert_Equals (T, I, Tag, "Find_Tag failed");
         end;
      end loop;
   end Test_Find_Tag;

end Wiki.Filters.Html.Tests;

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

with Util.Test_Caller;
with Util.Assertions;
with Util.Strings;
with Util.Log.Loggers;

package body Wiki.Filters.Html.Tests is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Wiki.Filters");

   package Caller is new Util.Test_Caller (Test, "Wikis.Filters.Html");

   procedure Assert_Equals is
      new Util.Assertions.Assert_Equals_T (Html_Tag_Type);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Wiki.Filters.Html.Find_Tag",
                       Test_Find_Tag'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test Find_Tag operation.
   --  ------------------------------
   procedure Test_Find_Tag (T : in out Test) is
   begin
      for I in Html_Tag_Type'Range loop
         declare
            Name  : constant String := Html_Tag_Type'Image (I);
            Wname : constant Wide_Wide_String := Html_Tag_Type'Wide_Wide_Image (I);
            Pos   : constant Natural := Util.Strings.Index (Name, '_');
            Tag   : constant Html_Tag_Type := Find_Tag (Wname (Wname'First .. Pos - 1));
         begin
            Log.Info ("Checking tag {0}", Name);
            Assert_Equals (T, I, Tag, "Find_Tag failed");

            Assert_Equals (T, UNKNOWN_TAG, Find_Tag (Wname (Wname'First .. Pos - 1) & "x"),
                          "Find_Tag must return UNKNOWN_TAG");
         end;
      end loop;
   end Test_Find_Tag;

end Wiki.Filters.Html.Tests;

Add some tests for Find_Tag operation

Add some tests for Find_Tag operation


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

with Ada.Finalization;
with Ada.Strings.Unbounded;
package Util.Processes is

   Invalid_State : exception;

   Process_Error : exception;

   --  The optional process pipes:
   --

   --
NONE

   --
the process will inherit the standard input, output and error.

   --
READ

   --
a pipe is created to read the process standard output.

   --
READ_ERROR

   --
a pipe is created to read the process standard error.  The output and input are
   --    inherited.

   --
READ_ALL

   --
similar to READ the same pipe is used for the process standard error.

   --
WRITE

   --
a pipe is created to write on the process standard input.

   --
READ_WRITE

   --
Combines the READ and WRITE modes.

   --
READ_WRITE_ALL

   --
Combines the READ_ALL and WRITE modes.

   --

   type Pipe_Mode is (NONE, READ, READ_ERROR, READ_ALL, WRITE, READ_WRITE, READ_WRITE_ALL);

   subtype String_Access is Ada.Strings.Unbounded.String_Access;

   subtype File_Type is Util.Systems.Types.File_Type;

   type Argument_List is array (Positive range <>) of String_Access;

   subtype Process_Identifier is Util.Systems.Os.Process_Identifier;
   use type Util.Systems.Os.Process_Identifier;

   --  ------------------------------
   --  Process
   --  ------------------------------
   type Process is limited private;

   --  Before launching the process, redirect the input stream of the process
   --  to the specified file.
   --  Raises Invalid_State if the process is running.
   procedure Set_Input_Stream (Proc : in out Process;
                               File : in String);

   --  Set the output stream of the process.
   --  Raises Invalid_State if the process is running.
   procedure Set_Output_Stream (Proc   : in out Process;
                                File   : in String;
                                Append : in Boolean := False);

   --  Set the error stream of the process.
   --  Raises Invalid_State if the process is running.
   procedure Set_Error_Stream (Proc   : in out Process;
                               File   : in String;
                               Append : in Boolean := False);

   --  Set the working directory that the process will use once it is created.
   --  The directory must exist or the Invalid_Directory exception will be raised.
   procedure Set_Working_Directory (Proc : in out Process;
                                    Path : in String);

   --  Set the shell executable path to use to launch a command.  The default on Unix is
   --  the /bin/sh command.  Argument splitting is done by the /bin/sh -c command.
   --  When setting an empty shell command, the argument splitting is done by the
   --  <tt>Spawn</tt> procedure.
   procedure Set_Shell (Proc  : in out Process;
                        Shell : in String);

   --  Closes the given file descriptor in the child process before executing the command.
   procedure Add_Close (Proc  : in out Process;
                        Fd    : in File_Type);

   --  Append the argument to the current process argument list.
   --  Raises Invalid_State if the process is running.
   procedure Append_Argument (Proc : in out Process;
                              Arg  : in String);

   --  Set the environment variable to be used by the process before its creation.
   procedure Set_Environment (Proc  : in out Process;
                              Name  : in String;
                              Value : in String);

   procedure Set_Environment (Proc    : in out Process;
                              Iterate : not null access
                                procedure
                                  (Process : not null access procedure
                                     (Name  : in String;
                                      Value : in String)));

   --  Spawn a new process with the given command and its arguments.  The standard input, output
   --  and error streams are either redirected to a file or to a stream object.
   procedure Spawn (Proc      : in out Process;
                    Command   : in String;
                    Arguments : in Argument_List;
                    Mode      : in Pipe_Mode := NONE);
   procedure Spawn (Proc      : in out Process;
                    Arguments : in Util.Strings.Vectors.Vector;
                    Mode      : in Pipe_Mode := NONE);
   procedure Spawn (Proc      : in out Process;
                    Command   : in String;
                    Mode      : in Pipe_Mode := NONE);
   procedure Spawn (Proc      : in out Process;
                    Mode      : in Pipe_Mode := NONE);

   --  Wait for the process to terminate.
   procedure Wait (Proc : in out Process);

   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   procedure Stop (Proc   : in out Process;
                   Signal : in Positive := 15);

   --  Get the process exit status.
   function Get_Exit_Status (Proc : in Process) return Integer;

   --  Get the process identifier.
   function Get_Pid (Proc : in Process) return Process_Identifier;

   --  Returns True if the process is running.
   function Is_Running (Proc : in Process) return Boolean;

   --  Get the process input stream allowing to write on the process standard input.
   function Get_Input_Stream (Proc : in Process) return Util.Streams.Output_Stream_Access;

   --  Get the process output stream allowing to read the process standard output.
   function Get_Output_Stream (Proc : in Process) return Util.Streams.Input_Stream_Access;

   --  Get the process error stream allowing to read the process standard output.
   function Get_Error_Stream (Proc : in Process) return Util.Streams.Input_Stream_Access;

private

   type File_Type_Array is array (Positive range <>) of File_Type;
   type File_Type_Array_Access is access all File_Type_Array;

   --  The System_Process interface is specific to the system.  On Unix, it holds the
   --  process identifier.  On Windows, more information is necessary, including the process
   --  and thread handles.  It's a little bit overkill to setup an interface for this but
   --  it looks cleaner than having specific system fields here.
   type System_Process is limited interface;
   type System_Process_Access is access all System_Process'Class;

   type Process is new Ada.Finalization.Limited_Controlled with record
      Pid        : Process_Identifier := -1;
      Sys        : System_Process_Access := null;
      Exit_Value : Integer := -1;
      Dir        : Ada.Strings.Unbounded.Unbounded_String;
      In_File    : Ada.Strings.Unbounded.Unbounded_String;
      Out_File   : Ada.Strings.Unbounded.Unbounded_String;
      Err_File   : Ada.Strings.Unbounded.Unbounded_String;
      Shell      : Ada.Strings.Unbounded.Unbounded_String;
      Out_Append : Boolean := False;
      Err_Append : Boolean := False;
      Output     : Util.Streams.Input_Stream_Access := null;
      Input      : Util.Streams.Output_Stream_Access := null;
      Error      : Util.Streams.Input_Stream_Access := null;
      To_Close   : File_Type_Array_Access;
   end record;

   --  Initialize the process instance.
   overriding
   procedure Initialize (Proc : in out Process);

   --  Deletes the process instance.
   overriding
   procedure Finalize (Proc : in out Process);

   --  Wait for the process to exit.
   procedure Wait (Sys     : in out System_Process;
                   Proc    : in out Process'Class;
                   Timeout : in Duration) is abstract;

   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   procedure Stop (Sys    : in out System_Process;
                   Proc   : in out Process'Class;
                   Signal : in Positive := 15) is abstract;

   --  Spawn a new process.
   procedure Spawn (Sys  : in out System_Process;
                    Proc : in out Process'Class;
                    Mode : in Pipe_Mode := NONE) is abstract;

   --  Clear the program arguments.
   procedure Clear_Arguments (Sys : in out System_Process) is abstract;

   --  Append the argument to the process argument list.
   procedure Append_Argument (Sys : in out System_Process;
                              Arg : in String) is abstract;

   --  Set the environment variable to be used by the process before its creation.
   procedure Set_Environment (Sys   : in out System_Process;
                              Name  : in String;
                              Value : in String) is abstract;

   --  Set the process input, output and error streams to redirect and use specified files.
   procedure Set_Streams (Sys           : in out System_Process;
                          Input         : in String;
                          Output        : in String;
                          Error         : in String;
                          Append_Output : in Boolean;
                          Append_Error  : in Boolean;
                          To_Close      : in File_Type_Array_Access) is abstract;

   --  Deletes the storage held by the system process.
   procedure Finalize (Sys : in out System_Process) is abstract;

end Util.Processes;

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

with Ada.Finalization;
with Ada.Strings.Unbounded;
package Util.Processes is

   Invalid_State : exception;

   Process_Error : exception;

   --  The optional process pipes:
   --

   --
NONE

   --
the process will inherit the standard input, output and error.

   --
READ

   --
a pipe is created to read the process standard output.

   --
READ_ERROR

   --
a pipe is created to read the process standard error.  The output and input are
   --    inherited.

   --
READ_ALL

   --
similar to READ the same pipe is used for the process standard error.

   --
WRITE

   --
a pipe is created to write on the process standard input.

   --
READ_WRITE

   --
Combines the READ and WRITE modes.

   --
READ_WRITE_ALL

   --
Combines the READ_ALL and WRITE modes.

   --

   type Pipe_Mode is (NONE, READ, READ_ERROR, READ_ALL, WRITE, READ_WRITE, READ_WRITE_ALL);

   subtype String_Access is Ada.Strings.Unbounded.String_Access;

   subtype File_Type is Util.Systems.Types.File_Type;

   type Argument_List is array (Positive range <>) of String_Access;

   subtype Process_Identifier is Util.Systems.Os.Process_Identifier;
   use type Util.Systems.Os.Process_Identifier;

   --  ------------------------------
   --  Process
   --  ------------------------------
   type Process is limited private;

   --  Before launching the process, redirect the input stream of the process
   --  to the specified file.
   --  Raises Invalid_State if the process is running.
   procedure Set_Input_Stream (Proc : in out Process;
                               File : in String);

   --  Set the output stream of the process.
   --  Raises Invalid_State if the process is running.
   procedure Set_Output_Stream (Proc   : in out Process;
                                File   : in String;
                                Append : in Boolean := False);

   --  Set the error stream of the process.
   --  Raises Invalid_State if the process is running.
   procedure Set_Error_Stream (Proc   : in out Process;
                               File   : in String;
                               Append : in Boolean := False);

   --  Set the working directory that the process will use once it is created.
   --  The directory must exist or the Invalid_Directory exception will be raised.
   procedure Set_Working_Directory (Proc : in out Process;
                                    Path : in String);

   --  Set the shell executable path to use to launch a command.  The default on Unix is
   --  the /bin/sh command.  Argument splitting is done by the /bin/sh -c command.
   --  When setting an empty shell command, the argument splitting is done by the
   --  <tt>Spawn</tt> procedure.
   procedure Set_Shell (Proc  : in out Process;
                        Shell : in String);

   --  Closes the given file descriptor in the child process before executing the command.
   procedure Add_Close (Proc  : in out Process;
                        Fd    : in File_Type);

   --  Append the argument to the current process argument list.
   --  Raises Invalid_State if the process is running.
   procedure Append_Argument (Proc : in out Process;
                              Arg  : in String);

   --  Set the environment variable to be used by the process before its creation.
   procedure Set_Environment (Proc  : in out Process;
                              Name  : in String;
                              Value : in String);

   procedure Set_Environment (Proc    : in out Process;
                              Iterate : not null access
                                procedure
                                  (Process : not null access procedure
                                     (Name  : in String;
                                      Value : in String)));

   --  Import the default environment variables from the current process.
   procedure Set_Default_Environment (Proc : in out Process);

   --  Spawn a new process with the given command and its arguments.  The standard input, output
   --  and error streams are either redirected to a file or to a stream object.
   procedure Spawn (Proc      : in out Process;
                    Command   : in String;
                    Arguments : in Argument_List;
                    Mode      : in Pipe_Mode := NONE);
   procedure Spawn (Proc      : in out Process;
                    Arguments : in Util.Strings.Vectors.Vector;
                    Mode      : in Pipe_Mode := NONE);
   procedure Spawn (Proc      : in out Process;
                    Command   : in String;
                    Mode      : in Pipe_Mode := NONE);
   procedure Spawn (Proc      : in out Process;
                    Mode      : in Pipe_Mode := NONE);

   --  Wait for the process to terminate.
   procedure Wait (Proc : in out Process);

   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   procedure Stop (Proc   : in out Process;
                   Signal : in Positive := 15);

   --  Get the process exit status.
   function Get_Exit_Status (Proc : in Process) return Integer;

   --  Get the process identifier.
   function Get_Pid (Proc : in Process) return Process_Identifier;

   --  Returns True if the process is running.
   function Is_Running (Proc : in Process) return Boolean;

   --  Get the process input stream allowing to write on the process standard input.
   function Get_Input_Stream (Proc : in Process) return Util.Streams.Output_Stream_Access;

   --  Get the process output stream allowing to read the process standard output.
   function Get_Output_Stream (Proc : in Process) return Util.Streams.Input_Stream_Access;

   --  Get the process error stream allowing to read the process standard output.
   function Get_Error_Stream (Proc : in Process) return Util.Streams.Input_Stream_Access;

private

   type File_Type_Array is array (Positive range <>) of File_Type;
   type File_Type_Array_Access is access all File_Type_Array;

   --  The System_Process interface is specific to the system.  On Unix, it holds the
   --  process identifier.  On Windows, more information is necessary, including the process
   --  and thread handles.  It's a little bit overkill to setup an interface for this but
   --  it looks cleaner than having specific system fields here.
   type System_Process is limited interface;
   type System_Process_Access is access all System_Process'Class;

   type Process is new Ada.Finalization.Limited_Controlled with record
      Pid        : Process_Identifier := -1;
      Sys        : System_Process_Access := null;
      Exit_Value : Integer := -1;
      Dir        : Ada.Strings.Unbounded.Unbounded_String;
      In_File    : Ada.Strings.Unbounded.Unbounded_String;
      Out_File   : Ada.Strings.Unbounded.Unbounded_String;
      Err_File   : Ada.Strings.Unbounded.Unbounded_String;
      Shell      : Ada.Strings.Unbounded.Unbounded_String;
      Out_Append : Boolean := False;
      Err_Append : Boolean := False;
      Output     : Util.Streams.Input_Stream_Access := null;
      Input      : Util.Streams.Output_Stream_Access := null;
      Error      : Util.Streams.Input_Stream_Access := null;
      To_Close   : File_Type_Array_Access;
   end record;

   --  Initialize the process instance.
   overriding
   procedure Initialize (Proc : in out Process);

   --  Deletes the process instance.
   overriding
   procedure Finalize (Proc : in out Process);

   --  Wait for the process to exit.
   procedure Wait (Sys     : in out System_Process;
                   Proc    : in out Process'Class;
                   Timeout : in Duration) is abstract;

   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   procedure Stop (Sys    : in out System_Process;
                   Proc   : in out Process'Class;
                   Signal : in Positive := 15) is abstract;

   --  Spawn a new process.
   procedure Spawn (Sys  : in out System_Process;
                    Proc : in out Process'Class;
                    Mode : in Pipe_Mode := NONE) is abstract;

   --  Clear the program arguments.
   procedure Clear_Arguments (Sys : in out System_Process) is abstract;

   --  Append the argument to the process argument list.
   procedure Append_Argument (Sys : in out System_Process;
                              Arg : in String) is abstract;

   --  Set the environment variable to be used by the process before its creation.
   procedure Set_Environment (Sys   : in out System_Process;
                              Name  : in String;
                              Value : in String) is abstract;

   --  Set the process input, output and error streams to redirect and use specified files.
   procedure Set_Streams (Sys           : in out System_Process;
                          Input         : in String;
                          Output        : in String;
                          Error         : in String;
                          Append_Output : in Boolean;
                          Append_Error  : in Boolean;
                          To_Close      : in File_Type_Array_Access) is abstract;

   --  Deletes the storage held by the system process.
   procedure Finalize (Sys : in out System_Process) is abstract;

end Util.Processes;

Declare the Set_Default_Environment procedure


-----------------------------------------------------------------------
--  Memory Events - Definition and Analysis of memory 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.Memory.Readers;
package body MAT.Memory.Targets is

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

   --  ------------------------------
   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   --  ------------------------------
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class) is
      Memory_Reader : constant MAT.Memory.Readers.Memory_Reader_Access
        := new MAT.Memory.Readers.Memory_Servant;
   begin
      Memory.Reader := Memory_Reader.all'Access;
      Memory_Reader.Data := Memory'Unrestricted_Access;
      MAT.Memory.Readers.Register (Reader, Memory_Reader);
   end Initialize;

   --  ------------------------------
   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   --  ------------------------------
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Malloc (Addr, Slot);
   end Probe_Malloc;

   --  ------------------------------
   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   --  ------------------------------
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Free (Addr, Slot);
   end Probe_Free;

   --  ------------------------------
   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   --  ------------------------------
   procedure Probe_Realloc (Memory : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation) is
   begin
      Memory.Memory.Probe_Realloc (Addr, Old_Addr, Slot);
   end Probe_Realloc;

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type) is
   begin
      Memory.Memory.Create_Frame (Pc, Result);
   end Create_Frame;

   --  ------------------------------
   --  Collect the information about memory slot sizes allocated by the application.
   --  ------------------------------
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
   begin
      Memory.Memory.Size_Information (Sizes);
   end Size_Information;

   --  ------------------------------
   --  Find from the memory map the memory slots whose address intersects
   --  the region [From .. To] and add the memory slot in the <tt>Into</tt> list if
   --  it does not already contains the memory slot.
   --  ------------------------------
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Into   : in out MAT.Memory.Allocation_Map) is
   begin
      Memory.Memory.Find (From, To, Into);
   end Find;

   protected body Memory_Allocator is

      --  ------------------------------
      --  Remove the memory region [Addr .. Addr + Size] from the free list.
      --  ------------------------------
      procedure Remove_Free (Addr : in MAT.Types.Target_Addr;
                             Size : in MAT.Types.Target_Size) is
         Iter : Allocation_Cursor;
         Last : constant MAT.Types.Target_Addr := Addr + MAT.Types.Target_Addr (Size);
         Slot : Allocation;
      begin
         --  Walk the list of free blocks and remove all the blocks which intersect the region
         --  [Addr .. Addr + Slot.Size].  We start walking at the first block below and near
         --  the address.  Slots are then removed when they intersect the malloc'ed region.
         Iter := Freed_Slots.Floor (Addr);
         while Allocation_Maps.Has_Element (Iter) loop
            declare
               Freed_Addr : constant MAT.Types.Target_Addr := Allocation_Maps.Key (Iter);
            begin
               exit when Freed_Addr > Last;
               Slot := Allocation_Maps.Element (Iter);
               if Freed_Addr + MAT.Types.Target_Addr (Slot.Size) > Addr then
                  Freed_Slots.Delete (Iter);
                  Iter := Freed_Slots.Floor (Addr);
               else
                  Allocation_Maps.Next (Iter);
               end if;
            end;
         end loop;
      end Remove_Free;

      --  ------------------------------
      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      --  ------------------------------
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation) is
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Malloc at {0} size {1}", MAT.Types.Hex_Image (Addr),
                       MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         Remove_Free (Addr, Slot.Size);
         Used_Slots.Insert (Addr, Slot);
      end Probe_Malloc;

      --  ------------------------------
      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      --  ------------------------------
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation) is
         Item : Allocation;
         Iter : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Free {0}", MAT.Types.Hex_Image (Addr));
         end if;
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            MAT.Frames.Release (Item.Frame);
            Used_Slots.Delete (Iter);
            Item.Frame := Slot.Frame;
            Freed_Slots.Insert (Addr, Item);
         end if;
      end Probe_Free;

      --  ------------------------------
      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      --  ------------------------------
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation) is
         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation);

         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation) is
            pragma Unreferenced (Key);
         begin
            Element.Size := Slot.Size;
            MAT.Frames.Release (Element.Frame);
            Element.Frame := Slot.Frame;
         end Update_Size;

         Pos      : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Realloc {0} to {1} size {2}", MAT.Types.Hex_Image (Old_Addr),
                       MAT.Types.Hex_Image (Addr), MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         if Addr /= 0 then
            Pos := Used_Slots.Find (Old_Addr);
            if Allocation_Maps.Has_Element (Pos) then
               if Addr = Old_Addr then
                  Used_Slots.Update_Element (Pos, Update_Size'Access);
               else
                  Used_Slots.Delete (Pos);
                  Used_Slots.Insert (Addr, Slot);
               end if;
            else
               Used_Slots.Insert (Addr, Slot);
            end if;
            Remove_Free (Addr, Slot.Size);
         end if;
      end Probe_Realloc;

      --  ------------------------------
      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      --  ------------------------------
      procedure Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type) is
      begin
         MAT.Frames.Insert (Frames, Pc, Result);
      end Create_Frame;

      --  ------------------------------
      --  Collect the information about memory slot sizes allocated by the application.
      --  ------------------------------
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
      begin
         MAT.Memory.Tools.Size_Information (Used_Slots, Sizes);
      end Size_Information;

      --  ------------------------------
      --  Find from the memory map the memory slots whose address intersects
      --  the region [From .. To] and add the memory slot in the <tt>Into</tt> list if
      --  it does not already contains the memory slot.
      --  ------------------------------
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Into   : in out MAT.Memory.Allocation_Map) is
      begin
         MAT.Memory.Tools.Find (Used_Slots, From, To, Into);
      end Find;

   end Memory_Allocator;

end MAT.Memory.Targets;

-----------------------------------------------------------------------
--  Memory Events - Definition and Analysis of memory 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.Memory.Readers;
package body MAT.Memory.Targets is

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

   --  ------------------------------
   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   --  ------------------------------
   procedure Initialize (Memory : in out Target_Memory;
                         Reader : in out MAT.Readers.Manager_Base'Class) is
      Memory_Reader : constant MAT.Memory.Readers.Memory_Reader_Access
        := new MAT.Memory.Readers.Memory_Servant;
   begin
      Memory.Reader := Memory_Reader.all'Access;
      Memory_Reader.Data := Memory'Unrestricted_Access;
      MAT.Memory.Readers.Register (Reader, Memory_Reader);
   end Initialize;

   --  ------------------------------
   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   --  ------------------------------
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Malloc (Addr, Slot);
   end Probe_Malloc;

   --  ------------------------------
   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   --  ------------------------------
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation) is
   begin
      Memory.Memory.Probe_Free (Addr, Slot);
   end Probe_Free;

   --  ------------------------------
   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   --  ------------------------------
   procedure Probe_Realloc (Memory : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation) is
   begin
      Memory.Memory.Probe_Realloc (Addr, Old_Addr, Slot);
   end Probe_Realloc;

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Create_Frame (Memory : in out Target_Memory;
                           Pc     : in MAT.Frames.Frame_Table;
                           Result : out MAT.Frames.Frame_Type) is
   begin
      Memory.Memory.Create_Frame (Pc, Result);
   end Create_Frame;

   --  ------------------------------
   --  Collect the information about memory slot sizes allocated by the application.
   --  ------------------------------
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
   begin
      Memory.Memory.Size_Information (Sizes);
   end Size_Information;

   --  ------------------------------
   --  Collect the information about threads and the memory allocations they've made.
   --  ------------------------------
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map) is
   begin
      Memory.Memory.Thread_Information (Threads);
   end Thread_Information;

   --  ------------------------------
   --  Find from the memory map the memory slots whose address intersects
   --  the region [From .. To] and add the memory slot in the <tt>Into</tt> list if
   --  it does not already contains the memory slot.
   --  ------------------------------
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Into   : in out MAT.Memory.Allocation_Map) is
   begin
      Memory.Memory.Find (From, To, Into);
   end Find;

   protected body Memory_Allocator is

      --  ------------------------------
      --  Remove the memory region [Addr .. Addr + Size] from the free list.
      --  ------------------------------
      procedure Remove_Free (Addr : in MAT.Types.Target_Addr;
                             Size : in MAT.Types.Target_Size) is
         Iter : Allocation_Cursor;
         Last : constant MAT.Types.Target_Addr := Addr + MAT.Types.Target_Addr (Size);
         Slot : Allocation;
      begin
         --  Walk the list of free blocks and remove all the blocks which intersect the region
         --  [Addr .. Addr + Slot.Size].  We start walking at the first block below and near
         --  the address.  Slots are then removed when they intersect the malloc'ed region.
         Iter := Freed_Slots.Floor (Addr);
         while Allocation_Maps.Has_Element (Iter) loop
            declare
               Freed_Addr : constant MAT.Types.Target_Addr := Allocation_Maps.Key (Iter);
            begin
               exit when Freed_Addr > Last;
               Slot := Allocation_Maps.Element (Iter);
               if Freed_Addr + MAT.Types.Target_Addr (Slot.Size) > Addr then
                  Freed_Slots.Delete (Iter);
                  Iter := Freed_Slots.Floor (Addr);
               else
                  Allocation_Maps.Next (Iter);
               end if;
            end;
         end loop;
      end Remove_Free;

      --  ------------------------------
      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      --  ------------------------------
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation) is
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Malloc at {0} size {1}", MAT.Types.Hex_Image (Addr),
                       MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         Remove_Free (Addr, Slot.Size);
         Used_Slots.Insert (Addr, Slot);
      end Probe_Malloc;

      --  ------------------------------
      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      --  ------------------------------
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation) is
         Item : Allocation;
         Iter : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Free {0}", MAT.Types.Hex_Image (Addr));
         end if;
         Iter := Used_Slots.Find (Addr);
         if Allocation_Maps.Has_Element (Iter) then
            Item := Allocation_Maps.Element (Iter);
            MAT.Frames.Release (Item.Frame);
            Used_Slots.Delete (Iter);
            Item.Frame := Slot.Frame;
            Freed_Slots.Insert (Addr, Item);
         end if;
      end Probe_Free;

      --  ------------------------------
      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      --  ------------------------------
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation) is
         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation);

         procedure Update_Size (Key     : in MAT.Types.Target_Addr;
                                Element : in out Allocation) is
            pragma Unreferenced (Key);
         begin
            Element.Size := Slot.Size;
            MAT.Frames.Release (Element.Frame);
            Element.Frame := Slot.Frame;
         end Update_Size;

         Pos      : Allocation_Cursor;
      begin
         if Log.Get_Level = Util.Log.DEBUG_LEVEL then
            Log.Debug ("Realloc {0} to {1} size {2}", MAT.Types.Hex_Image (Old_Addr),
                       MAT.Types.Hex_Image (Addr), MAT.Types.Target_Size'Image (Slot.Size));
         end if;
         if Addr /= 0 then
            Pos := Used_Slots.Find (Old_Addr);
            if Allocation_Maps.Has_Element (Pos) then
               if Addr = Old_Addr then
                  Used_Slots.Update_Element (Pos, Update_Size'Access);
               else
                  Used_Slots.Delete (Pos);
                  Used_Slots.Insert (Addr, Slot);
               end if;
            else
               Used_Slots.Insert (Addr, Slot);
            end if;
            Remove_Free (Addr, Slot.Size);
         end if;
      end Probe_Realloc;

      --  ------------------------------
      --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
      --  If the frame is already known, the frame reference counter is incremented.
      --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
      --  ------------------------------
      procedure Create_Frame (Pc     : in MAT.Frames.Frame_Table;
                              Result : out MAT.Frames.Frame_Type) is
      begin
         MAT.Frames.Insert (Frames, Pc, Result);
      end Create_Frame;

      --  ------------------------------
      --  Collect the information about memory slot sizes allocated by the application.
      --  ------------------------------
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map) is
      begin
         MAT.Memory.Tools.Size_Information (Used_Slots, Sizes);
      end Size_Information;

      --  ------------------------------
      --  Collect the information about threads and the memory allocations they've made.
      --  ------------------------------
      procedure Thread_Information (Threads : in out Memory_Info_Map) is
      begin
         MAT.Memory.Tools.Thread_Information (Used_Slots, Threads);
      end Thread_Information;

      --  ------------------------------
      --  Find from the memory map the memory slots whose address intersects
      --  the region [From .. To] and add the memory slot in the <tt>Into</tt> list if
      --  it does not already contains the memory slot.
      --  ------------------------------
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Into   : in out MAT.Memory.Allocation_Map) is
      begin
         MAT.Memory.Tools.Find (Used_Slots, From, To, Into);
      end Find;

   end Memory_Allocator;

end MAT.Memory.Targets;

Implement the Thread_Information procedures