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

with Util.Beans.Objects;

--  The Gen.Model.Mappings package controls the mappings to convert an XML
--  type into the Ada type.
package Gen.Model.Mappings is

   ADA_MAPPING    : constant String := "Ada05";

   MySQL_MAPPING  : constant String := "MySQL";

   SQLite_MAPPING : constant String := "SQLite";

   Postgresql_MAPPING : constant String := "Postgresql";

   type Basic_Type is (T_BOOLEAN, T_INTEGER, T_DATE, T_ENUM, T_IDENTIFIER, T_STRING, T_BLOB,
                       T_ENTITY_TYPE, T_BEAN, T_TABLE);

   --  ------------------------------
   --  Mapping Definition
   --  ------------------------------
   type Mapping_Definition;
   type Mapping_Definition_Access is access all Mapping_Definition'Class;

   type Mapping_Definition is new Definition with record
      Target        : Ada.Strings.Unbounded.Unbounded_String;
      Kind          : Basic_Type := T_INTEGER;
      Allow_Null    : Mapping_Definition_Access;
      Nullable      : Boolean := False;
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Mapping_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Find the mapping for the given type name.
   function Find_Type (Name       : in Ada.Strings.Unbounded.Unbounded_String;
                       Allow_Null : in Boolean)
                       return Mapping_Definition_Access;

   --  Get the type name.
   function Get_Type_Name (From : Mapping_Definition) return String;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type);

   --  Register a type mapping From that is mapped to Target.
   procedure Register_Type (Target        : in String;
                            From          : in String;
                            Kind          : in Basic_Type;
                            Allow_Null    : in Boolean);

   --  Setup the type mapping for the language identified by the given name.
   procedure Set_Mapping_Name (Name : in String);

   package Mapping_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type        => Ada.Strings.Unbounded.Unbounded_String,
                                     Element_Type    => Mapping_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => Ada.Strings.Unbounded."=");

   subtype Map is Mapping_Maps.Map;

   subtype Cursor is Mapping_Maps.Cursor;

end Gen.Model.Mappings;

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

with Util.Beans.Objects;

--  The Gen.Model.Mappings package controls the mappings to convert an XML
--  type into the Ada type.
package Gen.Model.Mappings is

   ADA_MAPPING    : constant String := "Ada05";

   MySQL_MAPPING  : constant String := "MySQL";

   SQLite_MAPPING : constant String := "SQLite";

   Postgresql_MAPPING : constant String := "Postgresql";

   type Basic_Type is (T_BOOLEAN, T_INTEGER, T_DATE, T_ENUM, T_IDENTIFIER, T_STRING, T_BLOB,
                       T_ENTITY_TYPE, T_BEAN, T_TABLE);

   --  ------------------------------
   --  Mapping Definition
   --  ------------------------------
   type Mapping_Definition;
   type Mapping_Definition_Access is access all Mapping_Definition'Class;

   type Mapping_Definition is new Definition with record
      Target        : Ada.Strings.Unbounded.Unbounded_String;
      Kind          : Basic_Type := T_INTEGER;
      Allow_Null    : Mapping_Definition_Access;
      Nullable      : Boolean := False;
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Mapping_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Find the mapping for the given type name.
   function Find_Type (Name       : in Ada.Strings.Unbounded.Unbounded_String;
                       Allow_Null : in Boolean)
                       return Mapping_Definition_Access;

   --  Get the type name according to the mapping definition.
   function Get_Type_Name (Name : in Ada.Strings.Unbounded.Unbounded_String) return String;

   --  Get the type name.
   function Get_Type_Name (From : Mapping_Definition) return String;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type);

   --  Register a type mapping From that is mapped to Target.
   procedure Register_Type (Target        : in String;
                            From          : in String;
                            Kind          : in Basic_Type;
                            Allow_Null    : in Boolean);

   --  Setup the type mapping for the language identified by the given name.
   procedure Set_Mapping_Name (Name : in String);

   package Mapping_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type        => Ada.Strings.Unbounded.Unbounded_String,
                                     Element_Type    => Mapping_Definition_Access,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Keys => Ada.Strings.Unbounded."=");

   subtype Map is Mapping_Maps.Map;

   subtype Cursor is Mapping_Maps.Cursor;

end Gen.Model.Mappings;

Declare a Get_Type_Name function to get a type using the mapping table


-----------------------------------------------------------------------
--  util-texts-builders -- Text builder
--  Copyright (C) 2013, 2016, 2017, 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 Ada.Unchecked_Deallocation;

package body Util.Texts.Builders is

   --  ------------------------------
   --  Get the length of the item builder.
   --  ------------------------------
   function Length (Source : in Builder) return Natural is
   begin
      return Source.Length;
   end Length;

   --  ------------------------------
   --  Get the capacity of the builder.
   --  ------------------------------
   function Capacity (Source : in Builder) return Natural is
      B : constant Block_Access := Source.Current;
   begin
      return Source.Length + B.Len - B.Last;
   end Capacity;

   --  ------------------------------
   --  Get the builder block size.
   --  ------------------------------
   function Block_Size (Source : in Builder) return Positive is
   begin
      return Source.Block_Size;
   end Block_Size;

   --  ------------------------------
   --  Set the block size for the allocation of next chunks.
   --  ------------------------------
   procedure Set_Block_Size (Source : in out Builder;
                             Size   : in Positive) is
   begin
      Source.Block_Size := Size;
   end Set_Block_Size;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Input) is
      B     : Block_Access := Source.Current;
      Start : Natural := New_Item'First;
      Last  : constant Natural := New_Item'Last;
   begin
      while Start <= Last loop
         declare
            Space : Natural := B.Len - B.Last;
            Size  : constant Natural := Last - Start + 1;
         begin
            if Space > Size then
               Space := Size;
            elsif Space = 0 then
               if Size > Source.Block_Size then
                  B.Next_Block := new Block (Size);
               else
                  B.Next_Block := new Block (Source.Block_Size);
               end if;
               B := B.Next_Block;
               Source.Current := B;
               if B.Len > Size then
                  Space := Size;
               else
                  Space  := B.Len;
               end if;
            end if;
            B.Content (B.Last + 1 .. B.Last + Space) := New_Item (Start .. Start + Space - 1);
            Source.Length := Source.Length + Space;
            B.Last := B.Last + Space;
            Start  := Start + Space;
         end;
      end loop;
   end Append;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Element_Type) is
      B     : Block_Access := Source.Current;
   begin
      if B.Len = B.Last then
         B.Next_Block := new Block (Source.Block_Size);
         B := B.Next_Block;
         Source.Current := B;
      end if;
      Source.Length := Source.Length + 1;
      B.Last := B.Last + 1;
      B.Content (B.Last) := New_Item;
   end Append;

   procedure Inline_Append (Source   : in out Builder) is
      B     : Block_Access := Source.Current;
      Last  : Natural;
   begin
      loop
         if B.Len = B.Last then
            B.Next_Block := new Block (Source.Block_Size);
            B := B.Next_Block;
            Source.Current := B;
         end if;
         Process (B.Content (B.Last + 1 .. B.Len), Last);
         exit when Last > B.Len or Last <= B.Last;
         Source.Length := Source.Length + Last - B.Last;
         B.Last := Last;
         exit when Last < B.Len;
      end loop;
   end Inline_Append;

   --  ------------------------------
   --  Clear the source freeing any storage allocated for the buffer.
   --  ------------------------------
   procedure Clear (Source : in out Builder) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Block, Name => Block_Access);
      Current, Next : Block_Access;
   begin
      Next := Source.First.Next_Block;
      while Next /= null loop
         Current := Next;
         Next    := Current.Next_Block;
         Free (Current);
      end loop;
      Source.First.Next_Block := null;
      Source.First.Last       := 0;
      Source.Current          := Source.First'Unchecked_Access;
      Source.Length           := 0;
   end Clear;

   --  ------------------------------
   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   --  ------------------------------
   procedure Iterate (Source  : in Builder;
                      Process : not null access procedure (Chunk : in Input)) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Iterate;

   procedure Inline_Iterate (Source  : in Builder) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Inline_Iterate;

   --  ------------------------------
   --  Return the content starting from the tail and up to <tt>Length</tt> items.
   --  ------------------------------
   function Tail (Source : in Builder;
                  Length : in Natural) return Input is
      Last : constant Natural := Source.Current.Last;
   begin
      if Last >= Length then
         return Source.Current.Content (Last - Length + 1 .. Last);
      elsif Length >= Source.Length then
         return To_Array (Source);
      else
         declare
            Result  : Input (1 .. Length);
            Offset  : Natural := Source.Length - Length;
            B       : access constant Block := Source.First'Access;
            Src_Pos : Positive := 1;
            Dst_Pos : Positive := 1;
            Len     : Natural;
         begin
            --  Skip the data moving to next blocks as needed.
            while Offset /= 0 loop
               if Offset < B.Last then
                  Src_Pos := Offset + 1;
                  Offset := 0;
               else
                  Offset := Offset - B.Last + 1;
                  B := B.Next_Block;
               end if;
            end loop;

            --  Copy what remains until we reach the length.
            while Dst_Pos <= Length loop
               Len := B.Last - Src_Pos + 1;
               Result (Dst_Pos .. Dst_Pos + Len - 1) := B.Content (Src_Pos .. B.Last);
               Src_Pos := 1;
               Dst_Pos := Dst_Pos + Len;
               B := B.Next_Block;
            end loop;
            return Result;
         end;
      end if;
   end Tail;

   --  ------------------------------
   --  Get the buffer content as an array.
   --  ------------------------------
   function To_Array (Source : in Builder) return Input is
      Result : Input (1 .. Source.Length);
   begin
      if Source.First.Last > 0 then
         declare
            Pos : Positive := Source.First.Last;
            B   : Block_Access := Source.First.Next_Block;
         begin
            Result (1 .. Pos) := Source.First.Content (1 .. Pos);
            while B /= null loop
               Result (Pos + 1 .. Pos + B.Last) := B.Content (1 .. B.Last);
               Pos := Pos + B.Last;
               B   := B.Next_Block;
            end loop;
         end;
      end if;
      return Result;
   end To_Array;

   --  ------------------------------
   --  Get the element at the given position.
   --  ------------------------------
   function Element (Source   : in Builder;
                     Position : in Positive) return Element_Type is
   begin
      if Position <= Source.First.Last then
         return Source.First.Content (Position);
      else
         declare
            Pos : Positive := Position - Source.First.Last;
            B   : Block_Access := Source.First.Next_Block;
         begin
            loop
               if Pos <= B.Last then
                  return B.Content (Pos);
               end if;
               Pos := Pos - B.Last;
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Element;

   --  ------------------------------
   --  Find the position of some content by running the `Index` function.
   --  The `Index` function is called with chunks starting at the given position and
   --  until it returns a positive value or we reach the last chunk.  It must return
   --  the found position in the chunk.
   --  ------------------------------
   function Find (Source   : in Builder;
                  Position : in Positive) return Natural is
      Result : Natural;
   begin
      if Position <= Source.First.Last then
         Result := Index (Source.First.Content (Position .. Source.First.Last));
         if Result > 0 then
            return Result;
         end if;
      end if;
      declare
         Pos    : Integer := Position - Source.First.Last;
         Offset : Positive := Source.First.Last;
         B      : Block_Access := Source.First.Next_Block;
      begin
         loop
            if B = null then
               return 0;
            end if;
            if Pos <= B.Last then
               Result := Index (B.Content (1 .. B.Last));
               if Result > 0 then
                  return Offset + Result;
               end if;
            end if;
            Pos := Pos - B.Last;
            Offset := Offset + B.Last;
            B := B.Next_Block;
         end loop;
      end;
   end Find;

   --  ------------------------------
   --  Call the <tt>Process</tt> procedure with the full buffer content, trying to avoid
   --  secondary stack copies as much as possible.
   --  ------------------------------
   procedure Get (Source : in Builder) is
   begin
      if Source.Length < Source.First.Len then
         Process (Source.First.Content (1 .. Source.Length));
      else
         declare
            Content : constant Input := To_Array (Source);
         begin
            Process (Content);
         end;
      end if;
   end Get;

   --  ------------------------------
   --  Format the message and replace occurrences of argument patterns by
   --  their associated value.
   --  Returns the formatted message in the stream
   --  ------------------------------
   procedure Format (Into      : in out Builder;
                     Message   : in Input;
                     Arguments : in Value_List) is
      C       : Element_Type;
      Old_Pos : Natural;
      N       : Natural := 0;
      Pos     : Natural := Message'First;
      First   : Natural := Pos;
   begin
      --  Replace {N} with arg1, arg2, arg3 or ?
      while Pos <= Message'Last loop
         C := Message (Pos);
         if Element_Type'Pos (C) = Character'Pos ('{') and then Pos + 1 <= Message'Last then
            if First /= Pos then
               Append (Into, Message (First .. Pos - 1));
            end if;
            N := 0;
            Pos := Pos + 1;
            C := Message (Pos);

            --  Handle {} replacement to emit the current argument and advance argument position.
            if Element_Type'Pos (C) = Character'Pos ('}') then
               Pos := Pos + 1;
               if N >= Arguments'Length then
                  First := Pos - 2;
               else
                  Append (Into, Arguments (N + Arguments'First));
                  First := Pos;
               end if;
               N := N + 1;
            else
               N := 0;
               Old_Pos := Pos - 1;
               loop
                  if Element_Type'Pos (C) >= Character'Pos ('0')
                    and Element_Type'Pos (C) <= Character'Pos ('9')
                  then
                     N := N * 10 + Natural (Element_Type'Pos (C) - Character'Pos ('0'));
                     Pos := Pos + 1;
                     if Pos > Message'Last then
                        First := Old_Pos;
                        exit;
                     end if;
                  elsif Element_Type'Pos (C) = Character'Pos ('}') then
                     Pos := Pos + 1;
                     if N >= Arguments'Length then
                        First := Old_Pos;
                     else
                        Append (Into, Arguments (N + Arguments'First));
                        First := Pos;
                     end if;
                     exit;
                  else
                     First := Old_Pos;
                     exit;
                  end if;
                  C := Message (Pos);
               end loop;
            end if;
         else
            Pos := Pos + 1;
         end if;
      end loop;
      if First /= Pos then
         Append (Into, Message (First .. Pos - 1));
      end if;
   end Format;

   --  ------------------------------
   --  Setup the builder.
   --  ------------------------------
   overriding
   procedure Initialize (Source : in out Builder) is
   begin
      Source.Current := Source.First'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Finalize the builder releasing the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Source : in out Builder) is
   begin
      Clear (Source);
   end Finalize;

end Util.Texts.Builders;

-----------------------------------------------------------------------
--  util-texts-builders -- Text builder
--  Copyright (C) 2013, 2016, 2017, 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 Ada.Unchecked_Deallocation;

package body Util.Texts.Builders is

   --  ------------------------------
   --  Get the length of the item builder.
   --  ------------------------------
   function Length (Source : in Builder) return Natural is
   begin
      return Source.Length;
   end Length;

   --  ------------------------------
   --  Get the capacity of the builder.
   --  ------------------------------
   function Capacity (Source : in Builder) return Natural is
      B : constant Block_Access := Source.Current;
   begin
      return Source.Length + B.Len - B.Last;
   end Capacity;

   --  ------------------------------
   --  Get the builder block size.
   --  ------------------------------
   function Block_Size (Source : in Builder) return Positive is
   begin
      return Source.Block_Size;
   end Block_Size;

   --  ------------------------------
   --  Set the block size for the allocation of next chunks.
   --  ------------------------------
   procedure Set_Block_Size (Source : in out Builder;
                             Size   : in Positive) is
   begin
      Source.Block_Size := Size;
   end Set_Block_Size;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Input) is
      B     : Block_Access := Source.Current;
      Start : Natural := New_Item'First;
      Last  : constant Natural := New_Item'Last;
   begin
      while Start <= Last loop
         declare
            Space : Natural := B.Len - B.Last;
            Size  : constant Natural := Last - Start + 1;
         begin
            if Space > Size then
               Space := Size;
            elsif Space = 0 then
               if Size > Source.Block_Size then
                  B.Next_Block := new Block (Size);
               else
                  B.Next_Block := new Block (Source.Block_Size);
               end if;
               B := B.Next_Block;
               Source.Current := B;
               if B.Len > Size then
                  Space := Size;
               else
                  Space  := B.Len;
               end if;
            end if;
            B.Content (B.Last + 1 .. B.Last + Space) := New_Item (Start .. Start + Space - 1);
            Source.Length := Source.Length + Space;
            B.Last := B.Last + Space;
            Start  := Start + Space;
         end;
      end loop;
   end Append;

   --  ------------------------------
   --  Append the <tt>New_Item</tt> at the end of the source growing the buffer if necessary.
   --  ------------------------------
   procedure Append (Source   : in out Builder;
                     New_Item : in Element_Type) is
      B     : Block_Access := Source.Current;
   begin
      if B.Len = B.Last then
         B.Next_Block := new Block (Source.Block_Size);
         B := B.Next_Block;
         Source.Current := B;
      end if;
      Source.Length := Source.Length + 1;
      B.Last := B.Last + 1;
      B.Content (B.Last) := New_Item;
   end Append;

   procedure Inline_Append (Source   : in out Builder) is
      B     : Block_Access := Source.Current;
      Last  : Natural;
   begin
      loop
         if B.Len = B.Last then
            B.Next_Block := new Block (Source.Block_Size);
            B := B.Next_Block;
            Source.Current := B;
         end if;
         Process (B.Content (B.Last + 1 .. B.Len), Last);
         exit when Last > B.Len or Last <= B.Last;
         Source.Length := Source.Length + Last - B.Last;
         B.Last := Last;
         exit when Last < B.Len;
      end loop;
   end Inline_Append;

   --  ------------------------------
   --  Append in `Into` builder the `Content` builder starting at `From` position
   --  and the up to and including the `To` position.
   --  ------------------------------
   procedure Append (Into    : in out Builder;
                     Content : in Builder;
                     From    : in Positive;
                     To      : in Positive) is
   begin
      if From <= Content.First.Last then
         if To <= Content.First.Last then
            Append (Into, Content.First.Content (From .. To));
            return;
         end if;
         Append (Into, Content.First.Content (From .. Content.First.Last));
      end if;
      declare
         Pos    : Integer := From - Into.First.Last;
         Last   : Integer := To - Into.First.Last;
         B      : Block_Access := Into.First.Next_Block;
      begin
         loop
            if B = null then
               return;
            end if;
            if Pos <= B.Last then
               if Last <= B.Last then
                  Append (Into, B.Content (1 .. Last));
                  return;
               end if;
               Append (Into, B.Content (1 .. B.Last));
            end if;
            Pos := Pos - B.Last;
            Last := Last - B.Last;
            B := B.Next_Block;
         end loop;
      end;
   end Append;

   --  ------------------------------
   --  Clear the source freeing any storage allocated for the buffer.
   --  ------------------------------
   procedure Clear (Source : in out Builder) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Block, Name => Block_Access);
      Current, Next : Block_Access;
   begin
      Next := Source.First.Next_Block;
      while Next /= null loop
         Current := Next;
         Next    := Current.Next_Block;
         Free (Current);
      end loop;
      Source.First.Next_Block := null;
      Source.First.Last       := 0;
      Source.Current          := Source.First'Unchecked_Access;
      Source.Length           := 0;
   end Clear;

   --  ------------------------------
   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   --  ------------------------------
   procedure Iterate (Source  : in Builder;
                      Process : not null access procedure (Chunk : in Input)) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Iterate;

   procedure Inline_Iterate (Source  : in Builder) is
   begin
      if Source.First.Last > 0 then
         Process (Source.First.Content (1 .. Source.First.Last));
         declare
            B : Block_Access := Source.First.Next_Block;
         begin
            while B /= null loop
               Process (B.Content (1 .. B.Last));
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Inline_Iterate;

   --  ------------------------------
   --  Return the content starting from the tail and up to <tt>Length</tt> items.
   --  ------------------------------
   function Tail (Source : in Builder;
                  Length : in Natural) return Input is
      Last : constant Natural := Source.Current.Last;
   begin
      if Last >= Length then
         return Source.Current.Content (Last - Length + 1 .. Last);
      elsif Length >= Source.Length then
         return To_Array (Source);
      else
         declare
            Result  : Input (1 .. Length);
            Offset  : Natural := Source.Length - Length;
            B       : access constant Block := Source.First'Access;
            Src_Pos : Positive := 1;
            Dst_Pos : Positive := 1;
            Len     : Natural;
         begin
            --  Skip the data moving to next blocks as needed.
            while Offset /= 0 loop
               if Offset < B.Last then
                  Src_Pos := Offset + 1;
                  Offset := 0;
               else
                  Offset := Offset - B.Last + 1;
                  B := B.Next_Block;
               end if;
            end loop;

            --  Copy what remains until we reach the length.
            while Dst_Pos <= Length loop
               Len := B.Last - Src_Pos + 1;
               Result (Dst_Pos .. Dst_Pos + Len - 1) := B.Content (Src_Pos .. B.Last);
               Src_Pos := 1;
               Dst_Pos := Dst_Pos + Len;
               B := B.Next_Block;
            end loop;
            return Result;
         end;
      end if;
   end Tail;

   --  ------------------------------
   --  Get the buffer content as an array.
   --  ------------------------------
   function To_Array (Source : in Builder) return Input is
      Result : Input (1 .. Source.Length);
   begin
      if Source.First.Last > 0 then
         declare
            Pos : Positive := Source.First.Last;
            B   : Block_Access := Source.First.Next_Block;
         begin
            Result (1 .. Pos) := Source.First.Content (1 .. Pos);
            while B /= null loop
               Result (Pos + 1 .. Pos + B.Last) := B.Content (1 .. B.Last);
               Pos := Pos + B.Last;
               B   := B.Next_Block;
            end loop;
         end;
      end if;
      return Result;
   end To_Array;

   --  ------------------------------
   --  Get the element at the given position.
   --  ------------------------------
   function Element (Source   : in Builder;
                     Position : in Positive) return Element_Type is
   begin
      if Position <= Source.First.Last then
         return Source.First.Content (Position);
      else
         declare
            Pos : Positive := Position - Source.First.Last;
            B   : Block_Access := Source.First.Next_Block;
         begin
            loop
               if Pos <= B.Last then
                  return B.Content (Pos);
               end if;
               Pos := Pos - B.Last;
               B := B.Next_Block;
            end loop;
         end;
      end if;
   end Element;

   --  ------------------------------
   --  Find the position of some content by running the `Index` function.
   --  The `Index` function is called with chunks starting at the given position and
   --  until it returns a positive value or we reach the last chunk.  It must return
   --  the found position in the chunk.
   --  ------------------------------
   function Find (Source   : in Builder;
                  Position : in Positive) return Natural is
      Result : Natural;
   begin
      if Position <= Source.First.Last then
         Result := Index (Source.First.Content (Position .. Source.First.Last));
         if Result > 0 then
            return Result;
         end if;
      end if;
      declare
         Pos    : Integer := Position - Source.First.Last;
         Offset : Positive := Source.First.Last;
         B      : Block_Access := Source.First.Next_Block;
      begin
         loop
            if B = null then
               return 0;
            end if;
            if Pos <= B.Last then
               if Pos > 0 then
                  Result := Index (B.Content (Pos .. B.Last));
               else
                  Result := Index (B.Content (1 .. B.Last));
               end if;
               if Result > 0 then
                  return Offset + Result;
               end if;
            end if;
            Pos := Pos - B.Last;
            Offset := Offset + B.Last;
            B := B.Next_Block;
         end loop;
      end;
   end Find;

   --  ------------------------------
   --  Call the <tt>Process</tt> procedure with the full buffer content, trying to avoid
   --  secondary stack copies as much as possible.
   --  ------------------------------
   procedure Get (Source : in Builder) is
   begin
      if Source.Length < Source.First.Len then
         Process (Source.First.Content (1 .. Source.Length));
      else
         declare
            Content : constant Input := To_Array (Source);
         begin
            Process (Content);
         end;
      end if;
   end Get;

   --  ------------------------------
   --  Format the message and replace occurrences of argument patterns by
   --  their associated value.
   --  Returns the formatted message in the stream
   --  ------------------------------
   procedure Format (Into      : in out Builder;
                     Message   : in Input;
                     Arguments : in Value_List) is
      C       : Element_Type;
      Old_Pos : Natural;
      N       : Natural := 0;
      Pos     : Natural := Message'First;
      First   : Natural := Pos;
   begin
      --  Replace {N} with arg1, arg2, arg3 or ?
      while Pos <= Message'Last loop
         C := Message (Pos);
         if Element_Type'Pos (C) = Character'Pos ('{') and then Pos + 1 <= Message'Last then
            if First /= Pos then
               Append (Into, Message (First .. Pos - 1));
            end if;
            N := 0;
            Pos := Pos + 1;
            C := Message (Pos);

            --  Handle {} replacement to emit the current argument and advance argument position.
            if Element_Type'Pos (C) = Character'Pos ('}') then
               Pos := Pos + 1;
               if N >= Arguments'Length then
                  First := Pos - 2;
               else
                  Append (Into, Arguments (N + Arguments'First));
                  First := Pos;
               end if;
               N := N + 1;
            else
               N := 0;
               Old_Pos := Pos - 1;
               loop
                  if Element_Type'Pos (C) >= Character'Pos ('0')
                    and Element_Type'Pos (C) <= Character'Pos ('9')
                  then
                     N := N * 10 + Natural (Element_Type'Pos (C) - Character'Pos ('0'));
                     Pos := Pos + 1;
                     if Pos > Message'Last then
                        First := Old_Pos;
                        exit;
                     end if;
                  elsif Element_Type'Pos (C) = Character'Pos ('}') then
                     Pos := Pos + 1;
                     if N >= Arguments'Length then
                        First := Old_Pos;
                     else
                        Append (Into, Arguments (N + Arguments'First));
                        First := Pos;
                     end if;
                     exit;
                  else
                     First := Old_Pos;
                     exit;
                  end if;
                  C := Message (Pos);
               end loop;
            end if;
         else
            Pos := Pos + 1;
         end if;
      end loop;
      if First /= Pos then
         Append (Into, Message (First .. Pos - 1));
      end if;
   end Format;

   --  ------------------------------
   --  Setup the builder.
   --  ------------------------------
   overriding
   procedure Initialize (Source : in out Builder) is
   begin
      Source.Current := Source.First'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Finalize the builder releasing the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Source : in out Builder) is
   begin
      Clear (Source);
   end Finalize;

end Util.Texts.Builders;

Implement the new Append procedure

Implement the new Append procedure


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

package body Util.Streams.Pipes is

   --  -----------------------
   --  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 (Stream : in out Pipe_Stream;
                        Shell  : in String) is
   begin
      Util.Processes.Set_Shell (Stream.Proc, Shell);
   end Set_Shell;

   --  -----------------------
   --  Open a pipe to read or write to an external process.  The pipe is created and the
   --  command is executed with the input and output streams redirected through the pipe.
   --  -----------------------
   procedure Open (Stream  : in out Pipe_Stream;
                   Command : in String;
                   Mode    : in Pipe_Mode := READ) is
   begin
      Util.Processes.Spawn (Stream.Proc, Command, Mode);
   end Open;

   --  -----------------------
   --  Close the pipe and wait for the external process to terminate.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Pipe_Stream) is
   begin
      Util.Processes.Wait (Stream.Proc);
   end Close;

   --  -----------------------
   --  Get the process exit status.
   --  -----------------------
   function Get_Exit_Status (Stream : in Pipe_Stream) return Integer is
   begin
      return Util.Processes.Get_Exit_Status (Stream.Proc);
   end Get_Exit_Status;

   --  -----------------------
   --  Returns True if the process is running.
   --  -----------------------
   function Is_Running (Stream : in Pipe_Stream) return Boolean is
   begin
      return Util.Processes.Is_Running (Stream.Proc);
   end Is_Running;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   overriding
   procedure Write (Stream : in out Pipe_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Output : constant Streams.Output_Stream_Access := Processes.Get_Input_Stream (Stream.Proc);
   begin
      if Output = null then
         raise Ada.IO_Exceptions.Status_Error with "Process is not launched";
      end if;
      Output.Write (Buffer);
   end Write;

   --  -----------------------
   --  Read into the buffer as many bytes as possible and return in
   --  <b>last</b> the position of the last byte read.
   --  -----------------------
   overriding
   procedure Read (Stream : in out Pipe_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Input : constant Streams.Input_Stream_Access := Processes.Get_Output_Stream (Stream.Proc);
   begin
      if Input = null then
         raise Ada.IO_Exceptions.Status_Error with "Process is not launched";
      end if;
      Input.Read (Into, Last);
   end Read;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   overriding
   procedure Finalize (Object : in out Pipe_Stream) is
   begin
      null;
   end Finalize;

end Util.Streams.Pipes;

-----------------------------------------------------------------------
--  util-streams-raw -- Raw streams for Unix based systems
--  Copyright (C) 2011, 2013, 2016, 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.IO_Exceptions;

package body Util.Streams.Pipes is

   --  -----------------------
   --  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 (Stream : in out Pipe_Stream;
                        Shell  : in String) is
   begin
      Util.Processes.Set_Shell (Stream.Proc, Shell);
   end Set_Shell;

   --  -----------------------
   --  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 (Stream : in out Pipe_Stream;
                               File   : in String) is
   begin
      Util.Processes.Set_Input_Stream (Stream.Proc, File);
   end Set_Input_Stream;

   --  -----------------------
   --  Set the output stream of the process.
   --  Raises Invalid_State if the process is running.
   --  -----------------------
   procedure Set_Output_Stream (Stream : in out Pipe_Stream;
                                File   : in String;
                                Append : in Boolean := False) is
   begin
      Util.Processes.Set_Output_Stream (Stream.Proc, File, Append);
   end Set_Output_Stream;

   --  -----------------------
   --  Set the error stream of the process.
   --  Raises Invalid_State if the process is running.
   --  -----------------------
   procedure Set_Error_Stream (Stream : in out Pipe_Stream;
                               File   : in String;
                               Append : in Boolean := False) is
   begin
      Util.Processes.Set_Error_Stream (Stream.Proc, File, Append);
   end Set_Error_Stream;

   --  -----------------------
   --  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 (Stream : in out Pipe_Stream;
                                    Path   : in String) is
   begin
      Util.Processes.Set_Working_Directory (Stream.Proc, Path);
   end Set_Working_Directory;

   --  -----------------------
   --  Open a pipe to read or write to an external process.  The pipe is created and the
   --  command is executed with the input and output streams redirected through the pipe.
   --  -----------------------
   procedure Open (Stream  : in out Pipe_Stream;
                   Command : in String;
                   Mode    : in Pipe_Mode := READ) is
   begin
      Util.Processes.Spawn (Stream.Proc, Command, Mode);
   end Open;

   --  -----------------------
   --  Close the pipe and wait for the external process to terminate.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Pipe_Stream) is
   begin
      Util.Processes.Wait (Stream.Proc);
   end Close;

   --  -----------------------
   --  Get the process exit status.
   --  -----------------------
   function Get_Exit_Status (Stream : in Pipe_Stream) return Integer is
   begin
      return Util.Processes.Get_Exit_Status (Stream.Proc);
   end Get_Exit_Status;

   --  -----------------------
   --  Returns True if the process is running.
   --  -----------------------
   function Is_Running (Stream : in Pipe_Stream) return Boolean is
   begin
      return Util.Processes.Is_Running (Stream.Proc);
   end Is_Running;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   overriding
   procedure Write (Stream : in out Pipe_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Output : constant Streams.Output_Stream_Access := Processes.Get_Input_Stream (Stream.Proc);
   begin
      if Output = null then
         raise Ada.IO_Exceptions.Status_Error with "Process is not launched";
      end if;
      Output.Write (Buffer);
   end Write;

   --  -----------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  -----------------------
   overriding
   procedure Read (Stream : in out Pipe_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Input : constant Streams.Input_Stream_Access := Processes.Get_Output_Stream (Stream.Proc);
   begin
      if Input = null then
         raise Ada.IO_Exceptions.Status_Error with "Process is not launched";
      end if;
      Input.Read (Into, Last);
   end Read;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   overriding
   procedure Finalize (Object : in out Pipe_Stream) is
   begin
      null;
   end Finalize;

end Util.Streams.Pipes;

Implement Set_Input_Stream, Set_Output_Stream, Set_Error_Stream, Set_Working_Directory procedures


package HAL.Filesystem is

   subtype Pathname is String;

   type File_Kind is (Regular_File, Directory);

   type File_Mode is (Read_Only, Write_Only, Read_Write);

   type Permission_Kind  is (Others_Execute, Others_Write, Others_Read,
                             Group_Execute,  Group_Write,  Group_Read,
                             Owner_Execute,  Owner_Write,  Owner_Read);

   type Permission_Set is array (Permission_Kind) of Boolean;

   type Status_Kind is (Status_Ok,
                        Symbolic_Links_Loop,
                        Permission_Denied,
                        Input_Output_Error,
                        No_Such_File_Or_Directory,
                        Filename_Is_Too_Long,
                        Not_A_Directory,
                        Representation_Overflow,
                        Invalid_Argument,
                        Not_Enough_Space,
                        Not_Enough_Memory,
                        Bad_Address,
                        File_Exists,
                        Read_Only_File_System,
                        Operation_Not_Permitted,
                        No_Space_Left_On_Device,
                        Too_Many_Links,
                        Resource_Busy,
                        Buffer_Is_Too_Small,
                        Read_Would_Block,
                        Call_Was_Interrupted);

   type FS_Driver is limited interface;
   type FS_Driver_Ref is access all FS_Driver'Class;

   function Create_Node (This : in out FS_Driver;
                         Path : Pathname;
                         Kind : File_Kind)
                         return Status_Kind is abstract;
end HAL.Filesystem;

with Interfaces; use Interfaces;
package HAL.Filesystem is

   subtype Pathname is String;

   type File_Kind is (Regular_File, Directory);

   type File_Mode is (Read_Only, Write_Only, Read_Write);

   type Permission_Kind  is (Others_Execute, Others_Write, Others_Read,
                             Group_Execute,  Group_Write,  Group_Read,
                             Owner_Execute,  Owner_Write,  Owner_Read);

   type Permission_Set is array (Permission_Kind) of Boolean;

   type Status_Kind is (Status_Ok,
                        Symbolic_Links_Loop,
                        Permission_Denied,
                        Input_Output_Error,
                        No_Such_File_Or_Directory,
                        Filename_Is_Too_Long,
                        Not_A_Directory,
                        Representation_Overflow,
                        Invalid_Argument,
                        Not_Enough_Space,
                        Not_Enough_Memory,
                        Bad_Address,
                        File_Exists,
                        Read_Only_File_System,
                        Operation_Not_Permitted,
                        No_Space_Left_On_Device,
                        Too_Many_Links,
                        Resource_Busy,
                        Buffer_Is_Too_Small,
                        Read_Would_Block,
                        Call_Was_Interrupted);

   type User_ID is new Natural;
   type Group_ID is new Natural;
   type IO_Count is new Unsigned_64;

   type FS_Driver is limited interface;
   type FS_Driver_Ref is access all FS_Driver'Class;

   function Create_Node (This : in out FS_Driver;
                         Path : Pathname;
                         Kind : File_Kind)
                         return Status_Kind is abstract;

   function Create_Directory (This : in out FS_Driver;
                              Path : Pathname)
                              return Status_Kind is abstract;

   function Unlink (This : in out FS_Driver;
                    Path : Pathname)
                    return Status_Kind is abstract;

   function Remove_Directory (This : in out FS_Driver;
                              Path : Pathname)
                              return Status_Kind is abstract;

   function Rename (This : in out FS_Driver;
                    Old_Path : Pathname;
                    New_Path : Pathname)
                    return Status_Kind is abstract;

   function Change_Permissions (This        : in out FS_Driver;
                                Path        : Pathname;
                                Permissions : Permission_Set)
                                return Status_Kind is abstract;

   function Change_Owner_And_Group (This  : in out FS_Driver;
                                    Path  : Pathname;
                                    Owner : User_ID;
                                    Group : Group_ID)
                                    return Status_Kind is abstract;

   function Change_Permissions (This   : in out FS_Driver;
                                Path   : Pathname;
                                Lenght : IO_Count)
                                return Status_Kind is abstract;

end HAL.Filesystem;

Add a few function in the file system interface


------------------------------------------------------------------------------
--                                                                          --
--                    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_gpio.c                                          --
--   @author  MCD Application Team                                          --
--   @version V1.1.0                                                        --
--   @date    19-June-2014                                                  --
--   @brief   GPIO HAL module driver.                                       --
--                                                                          --
--   COPYRIGHT(c) 2014 STMicroelectronics                                   --
------------------------------------------------------------------------------

with System;              use System;
with STM32_SVD.GPIO;      use STM32_SVD.GPIO;

with STM32.RCC;
with STM32.SYSCFG;
with System.Machine_Code;

package body STM32.GPIO is

   procedure Lock_The_Pin (Port : in out Internal_GPIO_Port;  Pin : Short);
   --  This is the routine that actually locks the pin for the port. It is an
   --  internal routine and has no preconditions. We use it to avoid redundant
   --  calls to the precondition that checks that the pin is not already
   --  locked. The redundancy would otherwise occur because the routine that
   --  locks an array of pins is implemented by calling the routine that locks
   --  a single pin: both those Lock routines have a precondition that checks
   --  that the pin(s) is not already being locked.

   -------------
   -- Any_Set --
   -------------

   function Any_Set (Pins : GPIO_Points) return Boolean is
   begin
      for Pin of Pins loop
         if Pin.Set then
            return True;
         end if;
      end loop;

      return False;
   end Any_Set;

   ---------
   -- Set --
   ---------

   overriding
   function Set (This : GPIO_Point) return Boolean is
     (This.Periph.IDR.IDR.Arr (This.Pin));

   -------------
   -- All_Set --
   -------------

   function All_Set (Pins : GPIO_Points) return Boolean is
   begin
      for Pin of Pins loop
         if not Pin.Set then
            return False;
         end if;
      end loop;

      return True;
   end All_Set;

   ---------
   -- Set --
   ---------

   overriding
   procedure Set (This : in out GPIO_Point) is
   begin
      This.Periph.BSRR.BS.Arr (This.Pin) := True;
   end Set;

   ---------
   -- Set --
   ---------

   procedure Set (Pins : in out GPIO_Points) is
   begin
      for Pin of Pins loop
         Pin.Set;
      end loop;
   end Set;

   -----------
   -- Clear --
   -----------

   overriding
   procedure Clear (This : in out GPIO_Point) is
   begin
      This.Periph.BSRR.BR.Arr (This.Pin) := True;
   end Clear;

   -----------
   -- Clear --
   -----------

   procedure Clear (Pins : in out GPIO_Points) is
   begin
      for Pin of Pins loop
         Pin.Clear;
      end loop;
   end Clear;

   ------------
   -- Toggle --
   ------------

   overriding
   procedure Toggle (This : in out GPIO_Point) is
   begin
      This.Periph.ODR.ODR.Arr (This.Pin) :=
        not This.Periph.ODR.ODR.Arr (This.Pin);
   end Toggle;

   ------------
   -- Toggle --
   ------------

   procedure Toggle (Points : in out GPIO_Points) is
   begin
      for Point of Points loop
         Point.Toggle;
      end loop;
   end Toggle;

   ------------
   -- Locked --
   ------------

   function Locked (Pin : GPIO_Point) return Boolean is
     (Pin.Periph.LCKR.LCK.Arr (Pin.Pin));

   ------------------
   -- Lock_The_Pin --
   ------------------

   procedure Lock_The_Pin (Port : in out Internal_GPIO_Port;  Pin : Short) is
      Temp : Word;
      pragma Volatile (Temp);

      use System.Machine_Code;
      use ASCII;
   begin
      --  As per the Reference Manual (RM0090; Doc ID 018909 Rev 6) pg 282,
      --  a specific sequence is required to set the Lock bit. Throughout the
      --  sequence the same value for the lower 15 bits of the word must be
      --  used (ie the pin number). The lock bit is referred to as LCKK in
      --  the doc.

--        Temp := LCCK or Pin'Enum_Rep;
--
--        --  set the lock bit
--        Port.LCKR := Temp;
--
--        --  clear the lock bit
--        Port.LCKR := Pin'Enum_Rep;
--
--        --  set the lock bit again
--        Port.LCKR := Temp;
--
--        --  read the lock bit
--        Temp := Port.LCKR;
--
--        --  read the lock bit again
--        Temp := Port.LCKR;

      --  We use the following assembly language sequence because the above
      --  high-level version in Ada works only if the optimizer is enabled.
      --  This is not an issue specific to Ada. If you need a specific sequence
      --  of instructions you should really specify those instructions.
      --  We don't want the functionality to depend on the switches, and we
      --  don't want to preclude debugging, hence the following:

      Asm ("orr  r3, %2, #65536"  & LF & HT &
           "str  r3, %0"          & LF & HT &
           "ldr  r3, %0"          & LF & HT &  -- temp <- pin or LCCK
           "str  r3, [%1, #28]"   & LF & HT &  -- temp -> lckr
           "str  %2, [%1, #28]"   & LF & HT &  -- pin -> lckr
           "ldr  r3, %0"          & LF & HT &
           "str  r3, [%1, #28]"   & LF & HT &  -- temp -> lckr
           "ldr  r3, [%1, #28]"   & LF & HT &
           "str  r3, %0"          & LF & HT &  -- temp <- lckr
           "ldr  r3, [%1, #28]"   & LF & HT &
           "str  r3, %0"          & LF & HT,   -- temp <- lckr
           Inputs => (Address'Asm_Input ("r", Port'Address), -- %1
                     (Short'Asm_Input ("r", Pin))),            -- %2
           Outputs => (Word'Asm_Output ("=m", Temp)),  -- %0
           Volatile => True,
           Clobber  => ("r2, r3"));
   end Lock_The_Pin;

   ----------
   -- Lock --
   ----------

   procedure Lock (Point : GPIO_Point) is
   begin
      Lock_The_Pin (Point.Periph.all, Shift_Left (1, Point.Pin));
   end Lock;

   ----------
   -- Lock --
   ----------

   procedure Lock (Points : GPIO_Points) is
   begin
      for Point of Points loop
         Point.Lock;
      end loop;
   end Lock;

   ------------------
   -- Configure_IO --
   ------------------

   procedure Configure_IO
     (Point  : GPIO_Point;
      Config : GPIO_Port_Configuration)
   is
      MODER   : MODER_Register   := Point.Periph.MODER;
      OTYPER  : OTYPER_Register  := Point.Periph.OTYPER;
      OSPEEDR : OSPEEDR_Register := Point.Periph.OSPEEDR;
      PUPDR   : PUPDR_Register   := Point.Periph.PUPDR;

   begin
      MODER.Arr (Point.Pin)     :=
        Pin_IO_Modes'Enum_Rep (Config.Mode);
      OTYPER.OT.Arr (Point.Pin) := Config.Output_Type = Open_Drain;
      OSPEEDR.Arr (Point.Pin) :=
        Pin_Output_Speeds'Enum_Rep (Config.Speed);
      PUPDR.Arr (Point.Pin)     :=
        Internal_Pin_Resistors'Enum_Rep (Config.Resistors);

      Point.Periph.MODER   := MODER;
      Point.Periph.OTYPER  := OTYPER;
      Point.Periph.OSPEEDR := OSPEEDR;
      Point.Periph.PUPDR   := PUPDR;
   end Configure_IO;

   ------------------
   -- Configure_IO --
   ------------------

   procedure Configure_IO
     (Points : GPIO_Points;
      Config : GPIO_Port_Configuration)
   is
   begin
      for Point of Points loop
         Point.Configure_IO (Config);
      end loop;
   end Configure_IO;

   ----------------------------------
   -- Configure_Alternate_Function --
   ----------------------------------

   procedure Configure_Alternate_Function
     (Point : GPIO_Point;
      AF    : GPIO_Alternate_Function)
   is
   begin
      if Point.Pin < 8 then
         Point.Periph.AFRL.Arr (Point.Pin) := UInt4 (AF);
      else
         Point.Periph.AFRH.Arr (Point.Pin) := UInt4 (AF);
      end if;
   end Configure_Alternate_Function;

   ----------------------------------
   -- Configure_Alternate_Function --
   ----------------------------------

   procedure Configure_Alternate_Function
     (Points : GPIO_Points;
      AF     : GPIO_Alternate_Function)
   is
   begin
      for Point of Points loop
         Point.Configure_Alternate_Function (AF);
      end loop;
   end Configure_Alternate_Function;

   -------------------------------
   -- Get_Interrupt_Line_Number --
   -------------------------------

   function Get_Interrupt_Line_Number
     (Point : GPIO_Point) return EXTI.External_Line_Number
   is
   begin
      return EXTI.External_Line_Number'Val (Point.Pin);
   end Get_Interrupt_Line_Number;

   -----------------------
   -- Configure_Trigger --
   -----------------------

   procedure Configure_Trigger
     (Point   : GPIO_Point;
      Trigger : EXTI.External_Triggers)
   is
      use STM32.EXTI;
      Line : constant External_Line_Number :=
        External_Line_Number'Val (Point.Pin);
      use STM32.SYSCFG, STM32.RCC;
   begin
      SYSCFG_Clock_Enable;

      Connect_External_Interrupt (Point);
      if Trigger in Interrupt_Triggers then
         Enable_External_Interrupt (Line, Trigger);
      else
         Enable_External_Event (Line, Trigger);
      end if;
   end Configure_Trigger;

   -----------------------
   -- Configure_Trigger --
   -----------------------

   procedure Configure_Trigger
     (Points  : GPIO_Points;
      Trigger : EXTI.External_Triggers)
   is
   begin
      for Point of Points loop
         Point.Configure_Trigger (Trigger);
      end loop;
   end Configure_Trigger;

end STM32.GPIO;

------------------------------------------------------------------------------
--                                                                          --
--                    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_gpio.c                                          --
--   @author  MCD Application Team                                          --
--   @version V1.1.0                                                        --
--   @date    19-June-2014                                                  --
--   @brief   GPIO HAL module driver.                                       --
--                                                                          --
--   COPYRIGHT(c) 2014 STMicroelectronics                                   --
------------------------------------------------------------------------------

with System;              use System;
with STM32_SVD.GPIO;      use STM32_SVD.GPIO;

with STM32.RCC;
with STM32.SYSCFG;
with System.Machine_Code;

package body STM32.GPIO is

   procedure Lock_The_Pin (Port : in out Internal_GPIO_Port;  Pin : Short);
   --  This is the routine that actually locks the pin for the port. It is an
   --  internal routine and has no preconditions. We use it to avoid redundant
   --  calls to the precondition that checks that the pin is not already
   --  locked. The redundancy would otherwise occur because the routine that
   --  locks an array of pins is implemented by calling the routine that locks
   --  a single pin: both those Lock routines have a precondition that checks
   --  that the pin(s) is not already being locked.

   -------------
   -- Any_Set --
   -------------

   function Any_Set (Pins : GPIO_Points) return Boolean is
   begin
      for Pin of Pins loop
         if Pin.Set then
            return True;
         end if;
      end loop;

      return False;
   end Any_Set;

   ---------
   -- Set --
   ---------

   overriding
   function Set (This : GPIO_Point) return Boolean is
     (This.Periph.IDR.IDR.Arr (This.Pin));

   -------------
   -- All_Set --
   -------------

   function All_Set (Pins : GPIO_Points) return Boolean is
   begin
      for Pin of Pins loop
         if not Pin.Set then
            return False;
         end if;
      end loop;

      return True;
   end All_Set;

   ---------
   -- Set --
   ---------

   overriding
   procedure Set (This : in out GPIO_Point) is
   begin
      This.Periph.BSRR.BS.Arr (This.Pin) := True;
   end Set;

   ---------
   -- Set --
   ---------

   procedure Set (Pins : in out GPIO_Points) is
   begin
      for Pin of Pins loop
         Pin.Set;
      end loop;
   end Set;

   -----------
   -- Clear --
   -----------

   overriding
   procedure Clear (This : in out GPIO_Point) is
   begin
      This.Periph.BSRR.BR.Arr (This.Pin) := True;
   end Clear;

   -----------
   -- Clear --
   -----------

   procedure Clear (Pins : in out GPIO_Points) is
   begin
      for Pin of Pins loop
         Pin.Clear;
      end loop;
   end Clear;

   ------------
   -- Toggle --
   ------------

   overriding
   procedure Toggle (This : in out GPIO_Point) is
   begin
      This.Periph.ODR.ODR.Arr (This.Pin) :=
        not This.Periph.ODR.ODR.Arr (This.Pin);
   end Toggle;

   ------------
   -- Toggle --
   ------------

   procedure Toggle (Points : in out GPIO_Points) is
   begin
      for Point of Points loop
         Point.Toggle;
      end loop;
   end Toggle;

   ------------
   -- Locked --
   ------------

   function Locked (Pin : GPIO_Point) return Boolean is
     (Pin.Periph.LCKR.LCK.Arr (Pin.Pin));

   ------------------
   -- Lock_The_Pin --
   ------------------

   procedure Lock_The_Pin (Port : in out Internal_GPIO_Port;  Pin : Short) is
      Temp : Word;
      pragma Volatile (Temp);

      use System.Machine_Code;
      use ASCII;
   begin
      --  As per the Reference Manual (RM0090; Doc ID 018909 Rev 6) pg 282,
      --  a specific sequence is required to set the Lock bit. Throughout the
      --  sequence the same value for the lower 15 bits of the word must be
      --  used (ie the pin number). The lock bit is referred to as LCKK in
      --  the doc.

--        Temp := LCCK or Pin'Enum_Rep;
--
--        --  set the lock bit
--        Port.LCKR := Temp;
--
--        --  clear the lock bit
--        Port.LCKR := Pin'Enum_Rep;
--
--        --  set the lock bit again
--        Port.LCKR := Temp;
--
--        --  read the lock bit
--        Temp := Port.LCKR;
--
--        --  read the lock bit again
--        Temp := Port.LCKR;

      --  We use the following assembly language sequence because the above
      --  high-level version in Ada works only if the optimizer is enabled.
      --  This is not an issue specific to Ada. If you need a specific sequence
      --  of instructions you should really specify those instructions.
      --  We don't want the functionality to depend on the switches, and we
      --  don't want to preclude debugging, hence the following:

      Asm ("orr  r3, %2, #65536"  & LF & HT &
           "str  r3, %0"          & LF & HT &
           "ldr  r3, %0"          & LF & HT &  -- temp <- pin or LCCK
           "str  r3, [%1, #28]"   & LF & HT &  -- temp -> lckr
           "str  %2, [%1, #28]"   & LF & HT &  -- pin -> lckr
           "ldr  r3, %0"          & LF & HT &
           "str  r3, [%1, #28]"   & LF & HT &  -- temp -> lckr
           "ldr  r3, [%1, #28]"   & LF & HT &
           "str  r3, %0"          & LF & HT &  -- temp <- lckr
           "ldr  r3, [%1, #28]"   & LF & HT &
           "str  r3, %0"          & LF & HT,   -- temp <- lckr
           Inputs => (Address'Asm_Input ("r", Port'Address), -- %1
                     (Short'Asm_Input ("r", Pin))),            -- %2
           Outputs => (Word'Asm_Output ("=m", Temp)),  -- %0
           Volatile => True,
           Clobber  => ("r2, r3"));
   end Lock_The_Pin;

   ----------
   -- Lock --
   ----------

   procedure Lock (Point : GPIO_Point) is
   begin
      Lock_The_Pin (Point.Periph.all, Shift_Left (1, Point.Pin));
   end Lock;

   ----------
   -- Lock --
   ----------

   procedure Lock (Points : GPIO_Points) is
   begin
      for Point of Points loop
         if not Locked (Point) then
            Point.Lock;
         end if;
      end loop;
   end Lock;

   ------------------
   -- Configure_IO --
   ------------------

   procedure Configure_IO
     (Point  : GPIO_Point;
      Config : GPIO_Port_Configuration)
   is
      MODER   : MODER_Register   := Point.Periph.MODER;
      OTYPER  : OTYPER_Register  := Point.Periph.OTYPER;
      OSPEEDR : OSPEEDR_Register := Point.Periph.OSPEEDR;
      PUPDR   : PUPDR_Register   := Point.Periph.PUPDR;

   begin
      MODER.Arr (Point.Pin)     :=
        Pin_IO_Modes'Enum_Rep (Config.Mode);
      OTYPER.OT.Arr (Point.Pin) := Config.Output_Type = Open_Drain;
      OSPEEDR.Arr (Point.Pin) :=
        Pin_Output_Speeds'Enum_Rep (Config.Speed);
      PUPDR.Arr (Point.Pin)     :=
        Internal_Pin_Resistors'Enum_Rep (Config.Resistors);

      Point.Periph.MODER   := MODER;
      Point.Periph.OTYPER  := OTYPER;
      Point.Periph.OSPEEDR := OSPEEDR;
      Point.Periph.PUPDR   := PUPDR;
   end Configure_IO;

   ------------------
   -- Configure_IO --
   ------------------

   procedure Configure_IO
     (Points : GPIO_Points;
      Config : GPIO_Port_Configuration)
   is
   begin
      for Point of Points loop
         Point.Configure_IO (Config);
      end loop;
   end Configure_IO;

   ----------------------------------
   -- Configure_Alternate_Function --
   ----------------------------------

   procedure Configure_Alternate_Function
     (Point : GPIO_Point;
      AF    : GPIO_Alternate_Function)
   is
   begin
      if Point.Pin < 8 then
         Point.Periph.AFRL.Arr (Point.Pin) := UInt4 (AF);
      else
         Point.Periph.AFRH.Arr (Point.Pin) := UInt4 (AF);
      end if;
   end Configure_Alternate_Function;

   ----------------------------------
   -- Configure_Alternate_Function --
   ----------------------------------

   procedure Configure_Alternate_Function
     (Points : GPIO_Points;
      AF     : GPIO_Alternate_Function)
   is
   begin
      for Point of Points loop
         Point.Configure_Alternate_Function (AF);
      end loop;
   end Configure_Alternate_Function;

   -------------------------------
   -- Get_Interrupt_Line_Number --
   -------------------------------

   function Get_Interrupt_Line_Number
     (Point : GPIO_Point) return EXTI.External_Line_Number
   is
   begin
      return EXTI.External_Line_Number'Val (Point.Pin);
   end Get_Interrupt_Line_Number;

   -----------------------
   -- Configure_Trigger --
   -----------------------

   procedure Configure_Trigger
     (Point   : GPIO_Point;
      Trigger : EXTI.External_Triggers)
   is
      use STM32.EXTI;
      Line : constant External_Line_Number :=
        External_Line_Number'Val (Point.Pin);
      use STM32.SYSCFG, STM32.RCC;
   begin
      SYSCFG_Clock_Enable;

      Connect_External_Interrupt (Point);
      if Trigger in Interrupt_Triggers then
         Enable_External_Interrupt (Line, Trigger);
      else
         Enable_External_Event (Line, Trigger);
      end if;
   end Configure_Trigger;

   -----------------------
   -- Configure_Trigger --
   -----------------------

   procedure Configure_Trigger
     (Points  : GPIO_Points;
      Trigger : EXTI.External_Triggers)
   is
   begin
      for Point of Points loop
         Point.Configure_Trigger (Trigger);
      end loop;
   end Configure_Trigger;

end STM32.GPIO;

Fix pre-condition issue when soft resetting boards.


------------------------------------------------------------------------------
--                                                                          --
--                    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.   --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Conversion;

with STM32.LCD;
private with STM32_SVD;

package STM32.DMA2D is
   type DMA2D_Color is record
      Alpha : Byte;
      Red   : Byte;
      Green : Byte;
      Blue  : Byte;
   end record;

   for DMA2D_Color use record
      Alpha at 3 range 0 .. 7;
      Red   at 2 range 0 .. 7;
      Green at 1 range 0 .. 7;
      Blue  at 0 range 0 .. 7;
   end record;

   --  This bit is set and cleared by software. It cannot be modified
   --  while a transfer is ongoing.
   type DMA2D_MODE is
     (
      --  Memory-to-memory (FG fetch only)
      M2M,

      --  Memory-to-memory with PFC (FG fetch only with FG PFC active)
      M2M_PFC,

      --  Memory-to-memory with blending (FG and BG fetch with PFC and
      --  blending)
      M2M_BLEND,

      --  Register-to-memory (no FG nor BG, only output stage active)
      R2M
     );
   for DMA2D_MODE'Size use 2;

   --  Configuration Error Interrupt Enable
   type DMA2D_FLAG is
     (Disable,
      Enable);

   --  Abort
   --  This bit can be used to abort the current transfer. This bit is
   --  set by software and is automatically reset by hardware when the
   --  START bit is reset.
   type DMA2D_ABORT is
     (
      --  0: No transfer abort requested
      Not_Requested,

      --  1: Transfer abort requested
      Requested);

   --  Suspend
   --  This bit can be used to suspend the current transfer. This bit
   --  is set and reset by software. It is automatically reset by
   --  hardware when the START bit is reset.
   type DMA2D_SUSPEND is
     (
      -- Transfer not suspended
      Not_Suspended,

      --  Transfer suspended
      Supended);

   --  Start
   --  This bit can be used to launch the DMA2D according to the
   --  parameters loaded in the  various configuration registers. This
   --  bit is automatically reset by the following events:
   --  - At the end of the transfer
   --  - When the data transfer is aborted by the user application by
   --    setting the ABORT bit in DMA2D_CR
   --  - When a data transfer error occurs
   --  - When the data transfer has not started due to a configuration
   --    error or another transfer operation already ongoing (automatic
   --    CLUT loading)
   type DMA2D_START is
     (Not_Started,
      Start);

   --  These bits defines the color format
   subtype DMA2D_Color_Mode is STM32.LCD.Pixel_Format;
--       (ARGB8888,
--        RGB888,
--        RGB565,
--        ARGB1555,
--        ARGB4444);
--     for DMA2D_Color_Mode'Size use 3;

   --  Alpha mode
   --  00: No modification of the foreground image alpha channel value
   --  01: Replace original foreground image alpha channel value by ALPHA[7:0]
   --  10: Replace original foreground image alpha channel value by ALPHA[7:0]
   --      multiplied with original alpha channel value
   --  other configurations are meaningless
   type DMA2D_AM is
     (NO_MODIF,
      REPLACE,
      MULTIPLY);
   for DMA2D_AM'Size use 2;

   procedure DMA2D_DeInit;

   type DMA2D_Sync_Procedure is access procedure;

   procedure DMA2D_Init
     (Init : DMA2D_Sync_Procedure;
      Wait : DMA2D_Sync_Procedure);

   type DMA2D_Buffer is record
      Addr       : System.Address;
      Width      : Natural;
      Height     : Natural;
      Color_Mode : DMA2D_Color_Mode;
      Swap_X_Y   : Boolean;
   end record;

   Null_Buffer : constant DMA2D_Buffer :=
                   (Addr       => System'To_Address (0),
                    Width      => 0,
                    Height     => 0,
                    Color_Mode => DMA2D_Color_Mode'First,
                    Swap_X_Y   => False);

   procedure DMA2D_Fill
     (Buffer      : DMA2D_Buffer;
      Color       : DMA2D_Color;
      Synchronous : Boolean := False);
   --  Fill the specified buffer with 'Color'

   procedure DMA2D_Fill
     (Buffer      : DMA2D_Buffer;
      Color       : Word;
      Synchronous : Boolean := False);
   --  Same as above, using the destination buffer native color representation

   procedure DMA2D_Set_Pixel
     (Buffer      : DMA2D_Buffer;
      X, Y        : Integer;
      Color       : DMA2D_Color;
      Synchronous : Boolean := False);

   procedure DMA2D_Set_Pixel
     (Buffer      : DMA2D_Buffer;
      X, Y        : Integer;
      Color       : Word;
      Synchronous : Boolean := False);
   --  Same as above, using the destination buffer native color representation

   procedure DMA2D_Set_Pixel_Blend
     (Buffer      : DMA2D_Buffer;
      X, Y        : Integer;
      Color       : DMA2D_Color;
      Synchronous : Boolean := False);

   procedure DMA2D_Fill_Rect
     (Buffer      : DMA2D_Buffer;
      Color       : DMA2D_Color;
      X           : Integer;
      Y           : Integer;
      Width       : Integer;
      Height      : Integer;
      Synchronous : Boolean := False);
   --  Fill the specified area of the buffer with 'Color'

   procedure DMA2D_Fill_Rect
     (Buffer      : DMA2D_Buffer;
      Color       : Word;
      X           : Integer;
      Y           : Integer;
      Width       : Integer;
      Height      : Integer;
      Synchronous : Boolean := False);
   --  Same as above, using the destination buffer native color representation

   procedure DMA2D_Draw_Rect
     (Buffer    : DMA2D_Buffer;
      Color     : DMA2D_Color;
      X         : Integer;
      Y         : Integer;
      Width     : Integer;
      Height    : Integer);
   --  Fill the specified area of the buffer with 'Color'

   procedure DMA2D_Copy_Rect
     (Src_Buffer : DMA2D_Buffer;
      X_Src      : Natural;
      Y_Src      : Natural;
      Dst_Buffer : DMA2D_Buffer;
      X_Dst      : Natural;
      Y_Dst      : Natural;
      Bg_Buffer  : DMA2D_Buffer;
      X_Bg       : Natural;
      Y_Bg       : Natural;
      Width      : Natural;
      Height     : Natural;
      Synchronous  : Boolean := False);
   --  Copy a rectangular area from Src to Dst
   --  If Blend is set, then the rectangle will be merged with the destination
   --  area, taking into account the opacity of the source. Else, it is simply
   --  copied.
   --
   --  if Bg_Buffer is not Null_Buffer, then the copy will be performed in
   --  blend mode: Bg_Buffer and Src_Buffer are combined first and then copied
   --  to Dst_Buffer.

   procedure DMA2D_Draw_Vertical_Line
     (Buffer    : DMA2D_Buffer;
      Color     : DMA2D_Color;
      X         : Integer;
      Y         : Integer;
      Height    : Integer;
      Synchronous : Boolean := False);
   --  Draws a vertical line

   procedure DMA2D_Draw_Horizontal_Line
     (Buffer    : DMA2D_Buffer;
      Color     : DMA2D_Color;
      X         : Integer;
      Y         : Integer;
      Width     : Integer;
      Synchronous : Boolean := False);
   --  Draws a vertical line

private

   function As_UInt3 is new Ada.Unchecked_Conversion
     (DMA2D_Color_Mode, STM32_SVD.UInt3);

end STM32.DMA2D;

------------------------------------------------------------------------------
--                                                                          --
--                    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.   --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Conversion;

with STM32.LCD;
private with STM32_SVD;

package STM32.DMA2D is

   type DMA2D_Color is record
      Alpha : Byte;
      Red   : Byte;
      Green : Byte;
      Blue  : Byte;
   end record;

   for DMA2D_Color use record
      Alpha at 3 range 0 .. 7;
      Red   at 2 range 0 .. 7;
      Green at 1 range 0 .. 7;
      Blue  at 0 range 0 .. 7;
   end record;

   Black : constant DMA2D_Color := (255, 0, 0, 0);
   White : constant DMA2D_Color := (255, 255, 255, 255);

   --  This bit is set and cleared by software. It cannot be modified
   --  while a transfer is ongoing.
   type DMA2D_MODE is
     (
      --  Memory-to-memory (FG fetch only)
      M2M,

      --  Memory-to-memory with PFC (FG fetch only with FG PFC active)
      M2M_PFC,

      --  Memory-to-memory with blending (FG and BG fetch with PFC and
      --  blending)
      M2M_BLEND,

      --  Register-to-memory (no FG nor BG, only output stage active)
      R2M
     );
   for DMA2D_MODE'Size use 2;

   --  Configuration Error Interrupt Enable
   type DMA2D_FLAG is
     (Disable,
      Enable);

   --  Abort
   --  This bit can be used to abort the current transfer. This bit is
   --  set by software and is automatically reset by hardware when the
   --  START bit is reset.
   type DMA2D_ABORT is
     (
      --  0: No transfer abort requested
      Not_Requested,

      --  1: Transfer abort requested
      Requested);

   --  Suspend
   --  This bit can be used to suspend the current transfer. This bit
   --  is set and reset by software. It is automatically reset by
   --  hardware when the START bit is reset.
   type DMA2D_SUSPEND is
     (
      -- Transfer not suspended
      Not_Suspended,

      --  Transfer suspended
      Supended);

   --  Start
   --  This bit can be used to launch the DMA2D according to the
   --  parameters loaded in the  various configuration registers. This
   --  bit is automatically reset by the following events:
   --  - At the end of the transfer
   --  - When the data transfer is aborted by the user application by
   --    setting the ABORT bit in DMA2D_CR
   --  - When a data transfer error occurs
   --  - When the data transfer has not started due to a configuration
   --    error or another transfer operation already ongoing (automatic
   --    CLUT loading)
   type DMA2D_START is
     (Not_Started,
      Start);

   --  These bits defines the color format
   subtype DMA2D_Color_Mode is STM32.LCD.Pixel_Format;
--       (ARGB8888,
--        RGB888,
--        RGB565,
--        ARGB1555,
--        ARGB4444);
--     for DMA2D_Color_Mode'Size use 3;

   --  Alpha mode
   --  00: No modification of the foreground image alpha channel value
   --  01: Replace original foreground image alpha channel value by ALPHA[7:0]
   --  10: Replace original foreground image alpha channel value by ALPHA[7:0]
   --      multiplied with original alpha channel value
   --  other configurations are meaningless
   type DMA2D_AM is
     (NO_MODIF,
      REPLACE,
      MULTIPLY);
   for DMA2D_AM'Size use 2;

   procedure DMA2D_DeInit;

   type DMA2D_Sync_Procedure is access procedure;

   procedure DMA2D_Init
     (Init : DMA2D_Sync_Procedure;
      Wait : DMA2D_Sync_Procedure);

   type DMA2D_Buffer is record
      Addr       : System.Address;
      Width      : Natural;
      Height     : Natural;
      Color_Mode : DMA2D_Color_Mode;
      Swap_X_Y   : Boolean;
   end record;

   Null_Buffer : constant DMA2D_Buffer :=
                   (Addr       => System'To_Address (0),
                    Width      => 0,
                    Height     => 0,
                    Color_Mode => DMA2D_Color_Mode'First,
                    Swap_X_Y   => False);

   procedure DMA2D_Fill
     (Buffer      : DMA2D_Buffer;
      Color       : DMA2D_Color;
      Synchronous : Boolean := False);
   --  Fill the specified buffer with 'Color'

   procedure DMA2D_Fill
     (Buffer      : DMA2D_Buffer;
      Color       : Word;
      Synchronous : Boolean := False);
   --  Same as above, using the destination buffer native color representation

   procedure DMA2D_Set_Pixel
     (Buffer      : DMA2D_Buffer;
      X, Y        : Integer;
      Color       : DMA2D_Color;
      Synchronous : Boolean := False);

   procedure DMA2D_Set_Pixel
     (Buffer      : DMA2D_Buffer;
      X, Y        : Integer;
      Color       : Word;
      Synchronous : Boolean := False);
   --  Same as above, using the destination buffer native color representation

   procedure DMA2D_Set_Pixel_Blend
     (Buffer      : DMA2D_Buffer;
      X, Y        : Integer;
      Color       : DMA2D_Color;
      Synchronous : Boolean := False);

   procedure DMA2D_Fill_Rect
     (Buffer      : DMA2D_Buffer;
      Color       : DMA2D_Color;
      X           : Integer;
      Y           : Integer;
      Width       : Integer;
      Height      : Integer;
      Synchronous : Boolean := False);
   --  Fill the specified area of the buffer with 'Color'

   procedure DMA2D_Fill_Rect
     (Buffer      : DMA2D_Buffer;
      Color       : Word;
      X           : Integer;
      Y           : Integer;
      Width       : Integer;
      Height      : Integer;
      Synchronous : Boolean := False);
   --  Same as above, using the destination buffer native color representation

   procedure DMA2D_Draw_Rect
     (Buffer    : DMA2D_Buffer;
      Color     : DMA2D_Color;
      X         : Integer;
      Y         : Integer;
      Width     : Integer;
      Height    : Integer);
   --  Fill the specified area of the buffer with 'Color'

   procedure DMA2D_Copy_Rect
     (Src_Buffer : DMA2D_Buffer;
      X_Src      : Natural;
      Y_Src      : Natural;
      Dst_Buffer : DMA2D_Buffer;
      X_Dst      : Natural;
      Y_Dst      : Natural;
      Bg_Buffer  : DMA2D_Buffer;
      X_Bg       : Natural;
      Y_Bg       : Natural;
      Width      : Natural;
      Height     : Natural;
      Synchronous  : Boolean := False);
   --  Copy a rectangular area from Src to Dst
   --  If Blend is set, then the rectangle will be merged with the destination
   --  area, taking into account the opacity of the source. Else, it is simply
   --  copied.
   --
   --  if Bg_Buffer is not Null_Buffer, then the copy will be performed in
   --  blend mode: Bg_Buffer and Src_Buffer are combined first and then copied
   --  to Dst_Buffer.

   procedure DMA2D_Draw_Vertical_Line
     (Buffer    : DMA2D_Buffer;
      Color     : DMA2D_Color;
      X         : Integer;
      Y         : Integer;
      Height    : Integer;
      Synchronous : Boolean := False);
   --  Draws a vertical line

   procedure DMA2D_Draw_Horizontal_Line
     (Buffer    : DMA2D_Buffer;
      Color     : DMA2D_Color;
      X         : Integer;
      Y         : Integer;
      Width     : Integer;
      Synchronous : Boolean := False);
   --  Draws a vertical line

private

   function As_UInt3 is new Ada.Unchecked_Conversion
     (DMA2D_Color_Mode, STM32_SVD.UInt3);

end STM32.DMA2D;

Add Black & White constants to the DMA2D spec.