pragma License (Modified_GPL);
------------------------------------------------------------------------------
-- EMAIL: <darkestkhan@gmail.com>                                           --
-- License: Modified GNU GPLv3 or any later as published by Free Software   --
--  Foundation (GMGPL, see COPYING file).                                   --
--                                                                          --
--                    Copyright © 2014 darkestkhan                          --
------------------------------------------------------------------------------
--  This Program is Free Software: You can redistribute it and/or modify    --
--  it under the terms of The GNU General Public License as published by    --
--    the Free Software Foundation: either version 3 of the license, or     --
--                 (at your option) any later version.                      --
--                                                                          --
--      This Program is distributed in the hope that it will be useful,     --
--      but WITHOUT ANY WARRANTY; without even the implied warranty of      --
--      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the        --
--              GNU General Public License for more details.                --
--                                                                          --
--    You should have received a copy of the GNU General Public License     --
--   along with this program.  If not, see <http://www.gnu.org/licenses/>.  --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
------------------------------------------------------------------------------
with System;

with Oto.Binary;
use Oto;

package Oto.AL is

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

                            ---------------
                            -- T Y P E S --
                            ---------------

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

  subtype Bool    is Binary.Byte;
  subtype Byte    is Binary.S_Byte;
  subtype Chat    is Binary.Byte;
  subtype Enum    is Binary.S_Word;
  subtype Int     is Integer;
  subtype Short   is Binary.S_Short;
  subtype SizeI   is Integer;
  subtype UByte   is Binary.Byte;
  subtype UInt    is Binary.Word;
  subtype UShort  is Binary.Short;
  subtype Pointer is System.Address;

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

                        -----------------------
                        -- C O N S T A N T S --
                        -----------------------

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

  -- "no distance model" or "no buffer"
  AL_NONE                                   : constant Enum := 0;

  AL_FALSE                                  : constant Bool := 0;
  AL_TRUE                                   : constant Bool := 1;

  -- Indicate Source has relative coordinates.
  AL_SOURCE_RELATIVE                        : constant Enum := 16#202#;

  -- Directional source, inner cone angle, in degrees.
  -- Range:    [0-360]
  -- Default:  360
  AL_CONE_INNER_ANGLE                       : constant Enum := 16#1001#;

  -- Directional source, outer cone angle, in degrees.
  -- Range:    [0-360]
  -- Default:  360
  AL_CONE_OUTER_ANGLE                       : constant Enum := 16#1002#;

  -- Specify the pitch to be applied at source.
  -- Range:   [0.5-2.0]
  -- Default: 1.0
  AL_PITCH                                  : constant Enum := 16#1003#;

  -- Specify the current location in three dimensional space.
  -- OpenAL, like OpenGL, uses a right handed coordinate system,
  --  where in a frontal default view X (thumb) points right,
  --  Y points up (index finger), and Z points towards the
  --  viewer/camera (middle finger).
  -- To switch from a left handed coordinate system, flip the
  --  sign on the Z coordinate.
  -- Listener position is always in the world coordinate system.
  AL_POSITION                               : constant Enum := 16#1004#;

  -- Specify the current direction.
  AL_DIRECTION                              : constant Enum := 16#1005#;

  -- Specify the current velocity in three dimensional space.
  AL_VELOCITY                               : constant Enum := 16#1006#;

  -- Indicate whether source is looping.
  -- Type: ALboolean
  -- Range:   [AL_TRUE, AL_FALSE]
  -- Default: FALSE.
  AL_LOOPING                                : constant Enum := 16#1007#;

  -- Indicate the buffer to provide sound samples.
  -- Type: ALuint.
  -- Range: any valid Buffer id.
  AL_BUFFER                                 : constant Enum := 16#1009#;

  -- Indicate the gain (volume amplification) applied.
  -- Type:  Float.
  -- Range:  ]0.0-  ]
  -- A value of 1.0 means un-attenuated/unchanged.
  -- Each division by 2 equals an attenuation of -6dB.
  -- Each multiplicaton with 2 equals an amplification of +6dB.
  -- A value of 0.0 is meaningless with respect to a logarithmic
  -- scale; it is interpreted as zero volume - the channel
  -- is effectively disabled.
  AL_GAIN                                   : constant Enum := 16#100A#;

  -- Indicate minimum source attenuation
  -- Type: Float
  -- Range:  [0.0 - 1.0]
  --
  -- Logarthmic
  AL_MIN_GAIN                               : constant Enum := 16#100D#;

  -- Indicate maximum source attenuation
  -- Type: Float
  -- Range:  [0.0 - 1.0]
  --
  -- Logarthmic
  AL_MAX_GAIN                               : constant Enum := 16#100E#;

  -- Indicate listener orientation.
  --
  -- at/up
  AL_ORIENTATION                            : constant Enum := 16#100F#;

  -- Source state information.
  AL_SOURCE_STATE                           : constant Enum := 16#1010#;
  AL_INITIAL                                : constant Enum := 16#1011#;
  AL_PLAYING                                : constant Enum := 16#1012#;
  AL_PAUSED                                 : constant Enum := 16#1013#;
  AL_STOPPED                                : constant Enum := 16#1014#;

  -- Buffer Queue params
  AL_BUFFERS_QUEUED                         : constant Enum := 16#1015#;
  AL_BUFFERS_PROCESSED                      : constant Enum := 16#1016#;

  -- Source buffer position information
  AL_SEC_OFFSET                             : constant Enum := 16#1024#;
  AL_SAMPLE_OFFSET                          : constant Enum := 16#1025#;
  AL_BYTE_OFFSET                            : constant Enum := 16#1026#;

  -- Source type (Static, Streaming or undetermined)
  -- Source is Static if a Buffer has been attached using AL_BUFFER
  -- Source is Streaming if one or more Buffers have been attached using alSourceQueueBuffers
  -- Source is undetermined when it has the NULL buffer attached
  AL_SOURCE_TYPE                            : constant Enum := 16#1027#;
  AL_STATIC                                 : constant Enum := 16#1028#;
  AL_STREAMING                              : constant Enum := 16#1029#;
  AL_UNDETERMINED                           : constant Enum := 16#1030#;

  -- Sound samples: format specifier.
  AL_FORMAT_MONO8                           : constant Enum := 16#1100#;
  AL_FORMAT_MONO16                          : constant Enum := 16#1101#;
  AL_FORMAT_STEREO8                         : constant Enum := 16#1102#;
  AL_FORMAT_STEREO16                        : constant Enum := 16#1103#;

  -- source specific reference distance
  -- Type: Float
  -- Range:  0.0 - +inf
  --
  -- At 0.0, no distance attenuation occurs.  Default is 1.0.
  AL_REFERENCE_DISTANCE                     : constant Enum := 16#1020#;

  -- source specific rolloff factor
  -- Type: Float
  -- Range:  0.0 - +inf
  AL_ROLLOFF_FACTOR                         : constant Enum := 16#1021#;

  -- Directional source, outer cone gain.
  --
  -- Default:  0.0
  -- Range:    [0.0 - 1.0]
  -- Logarithmic
  AL_CONE_OUTER_GAIN                        : constant Enum := 16#1022#;

  -- Indicate distance above which sources are not
  -- attenuated using the inverse clamped distance model.
  --
  -- Default: +inf
  -- Type: Float
  -- Range:  0.0 - +inf
  AL_MAX_DISTANCE                           : constant Enum := 16#1023#;

  -- Sound samples: frequency, in units of Hertz [Hz].
  -- This is the number of samples per second. Half of the
  --  sample frequency marks the maximum significant
  --  frequency component.
  AL_FREQUENCY                              : constant Enum := 16#2001#;
  AL_BITS                                   : constant Enum := 16#2002#;
  AL_CHANNELS                               : constant Enum := 16#2003#;
  AL_SIZE                                   : constant Enum := 16#2004#;

  -- Buffer state.
  --
  -- Not supported for public use (yet).
  AL_UNUSED                                 : constant Enum := 16#2010#;
  AL_PENDING                                : constant Enum := 16#2011#;
  AL_PROCESSED                              : constant Enum := 16#2012#;

  -- Errors: No Error.
  AL_NO_ERROR                               : constant Enum := 0;

  -- Invalid Name paramater passed to AL call.
  AL_INVALID_NAME                           : constant Enum := 16#A001#;

  -- Invalid parameter passed to AL call.
  AL_INVALID_ENUM                           : constant Enum := 16#A002#;

  -- Invalid enum parameter value.
  AL_INVALID_VALUE                          : constant Enum := 16#A003#;

  -- Illegal call.
  AL_INVALID_OPERATION                      : constant Enum := 16#A004#;

  -- No mojo.
  AL_OUT_OF_MEMORY                          : constant Enum := 16#A005#;

  -- Context strings: Vendor Name.
  AL_VENDOR                                 : constant Enum := 16#B001#;
  AL_VERSION                                : constant Enum := 16#B002#;
  AL_RENDERER                               : constant Enum := 16#B003#;
  AL_EXTENSIONS                             : constant Enum := 16#B004#;

  -- Doppler scale.  Default 1.0
  AL_DOPPLER_FACTOR                         : constant Enum := 16#C000#;

  -- Tweaks speed of propagation.
  AL_DOPPLER_VELOCITY                       : constant Enum := 16#C001#;

  -- Speed of Sound in units per second
  AL_SPEED_OF_SOUND                         : constant Enum := 16#C003#;

  -- Distance models
  --
  -- used in conjunction with DistanceModel
  --
  -- implicit: NONE, which disances distance attenuation.
  AL_DISTANCE_MODEL                         : constant Enum := 16#D000#;
  AL_INVERSE_DISTANCE                       : constant Enum := 16#D001#;
  AL_INVERSE_DISTANCE_CLAMPED               : constant Enum := 16#D002#;
  AL_LINEAR_DISTANCE                        : constant Enum := 16#D003#;
  AL_LINEAR_DISTANCE_CLAMPED                : constant Enum := 16#D004#;
  AL_EXPONENT_DISTANCE                      : constant Enum := 16#D005#;
  AL_EXPONENT_DISTANCE_CLAMPED              : constant Enum := 16#D006#;

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

end Oto.AL;

Define constants.

AL: Define constants.

Signed-off-by: darkestkhan <e9a7a7cf2a6af79e93742343a7a5cac5d90f9bd2@gmail.com>


-----------------------------------------------------------------------
--  mat-consoles-text - Text console interface
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Text_IO;
with Glib;
with Gtk.Frame;
with Gtk.List_Store;
with Gtk.Tree_Model;
with Gtk.Cell_Renderer_Text;
with Gtk.Tree_View;
package MAT.Consoles.Gtkmat is

   type Console_Type is new MAT.Consoles.Console_Type with private;
   type Console_Type_Access is access all Console_Type'Class;

   --  Initialize the console to display the result in the Gtk frame.
   procedure Initialize (Console : in out Console_Type;
                         Frame   : in Gtk.Frame.Gtk_Frame);

   --  Report a notice message.
   overriding
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String);

   --  Report an error message.
   overriding
   procedure Error (Console : in out Console_Type;
                    Message : in String);

   --  Print the field value for the given field.
   overriding
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String);

   --  Print the title for the given field.
   overriding
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String);

   --  Start a new title in a report.
   overriding
   procedure Start_Title (Console : in out Console_Type);

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type);

   --  Start a new row in a report.
   overriding
   procedure Start_Row (Console : in out Console_Type);

   --  Finish a new row in a report.
   overriding
   procedure End_Row (Console : in out Console_Type);

private

   type Column_Type is record
      Field : Field_Type;
      Title : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Column_Array is array (1 .. Field_Type'Pos (Field_Type'Last)) of Column_Type;

   type Field_Index_Array is array (Field_Type) of Glib.Gint;

   type Console_Type is new MAT.Consoles.Console_Type with record
      Frame       : Gtk.Frame.Gtk_Frame;
--        Model       : Gtk.Tree_Model.Gtk_Tree_Model;
      List        : Gtk.List_Store.Gtk_List_Store;
      Current_Row : Gtk.Tree_Model.Gtk_Tree_Iter;
      File        : Ada.Text_IO.File_Type;
      Indexes     : Field_Index_Array;
      Columns     : Column_Array;
      Tree        : Gtk.Tree_View.Gtk_Tree_View;
      Col_Text    : Gtk.Cell_Renderer_Text.Gtk_Cell_renderer_Text;
   end record;

end MAT.Consoles.Gtkmat;

Define the MAT.Consoles.Gtkmat package with support for a console output in Gtk


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

with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with Ada.Directories;
with Ada.Containers.Vectors;
with Ada.Strings.Fixed;
with Util.Log.Loggers;
package body Util.Properties.Bundles is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Util.Properties.Bundles");

   procedure Free is
     new Ada.Unchecked_Deallocation (Manager'Class,
                                     Bundle_Manager_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (String,
                                     Util.Strings.String_Access);

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is new Util.Properties.Interface_P.Manager with private;
      type Manager_Object_Access is access all Manager;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager; Name : in Value)
                       return Boolean;

      --  Returns the property value.  Raises an exception if not found.
      function Get (Self : in Manager; Name : in Value)
                    return Value;

      procedure Insert (Self : in out Manager; Name : in Value;
                        Item : in Value);

      --  Set the value of the property.  The property is created if it
      --  does not exists.
      procedure Set (Self : in out Manager; Name : in Value;
                     Item : in Value);

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager; Name : in Value);

      procedure Load_Properties (Self : in out Manager;
                                 File : in String);

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                           return Util.Properties.Interface_P.Manager_Access;

      procedure Delete (Self : in Manager;
                        Obj : in out Util.Properties.Interface_P.Manager_Access);

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array;

      procedure Add_Bundle (Self : in out Manager;
                            Props : in Util.Properties.Manager_Access);
   private
      use type Util.Properties.Manager_Access;

      package PropertyList is new Ada.Containers.Vectors
        (Element_Type => Util.Properties.Manager_Access,
         Index_Type => Natural,
           "=" => "=");

      type Manager is new Util.Properties.Interface_P.Manager with record
         List  : PropertyList.Vector;
         Props : aliased Util.Properties.Manager;
      end record;

      procedure Free is
        new Ada.Unchecked_Deallocation (Manager,
                                        Manager_Object_Access);
   end Interface_P;

   procedure Add_Bundle (Self  : in out Manager;
                         Props : in Manager_Access) is
      use type Util.Properties.Interface_P.Manager_Access;
   begin
      Interface_P.Manager'Class (Self.Impl.all).Add_Bundle (Props);
   end Add_Bundle;

   procedure Initialize (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
      Object.Impl.Count := 1;
   end Initialize;

   procedure Adjust (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      if Object.Impl /= null then
         Object.Impl.Count := Object.Impl.Count + 1;
      else
         Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
         Object.Impl.Count := 1;
      end if;
   end Adjust;

   --  ------------------------------
   --  Initialize the bundle factory and specify where the property files are stored.
   --  ------------------------------
   procedure Initialize (Factory : in out Loader;
                         Path    : in String) is
   begin
      Log.Info ("Initialize bundle factory to load from {0}", Path);

      Factory.Path := To_Unbounded_String (Path);
   end Initialize;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class) is
      Found : Boolean := False;
   begin
      Log.Info ("Load bundle {0} for language {1}", Name, Locale);

      Find_Bundle (Factory, Name, Locale, Bundle, Found);
      if not Found then
         Load_Bundle (Factory, Name, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
         Find_Bundle (Factory, Name, Locale, Bundle, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
      end if;
   end Load_Bundle;

   --  ------------------------------
   --  Find the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Find_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class;
                          Found   : out Boolean) is
      use Ada.Strings;
      use type Util.Properties.Manager_Access;

      Loc_Name : constant String := '_' & Locale;
      Last_Pos : Natural := Loc_Name'Last;
   begin
      Log.Info ("Looking for bundle {0} and language {1}", Name, Locale);

      Found := False;
      Factory.Lock.Read;
      declare
         Pos : Bundle_Map.Cursor;
      begin
         while Last_Pos >= Loc_Name'First loop
            declare
               Bundle_Name : aliased constant String
                 := Name & Loc_Name (Loc_Name'First .. Last_Pos);
            begin
               Pos := Factory.Bundles.Find (Bundle_Name'Unrestricted_Access);
               if Bundle_Map.Has_Element (Pos) then
                  Bundle.Finalize;
                  Bundle.Impl := Bundle_Map.Element (Pos).Impl;
                  Bundle.Impl.Count := Bundle.Impl.Count + 1;
                  Found := True;
                  exit;
               end if;
            end;
            if Last_Pos > Loc_Name'First then
               Last_Pos := Fixed.Index (Loc_Name, "_", Last_Pos - 1, Backward);
            else
               Last_Pos := Last_Pos - 1;
            end if;
         end loop;
      exception
         when others =>
            Factory.Lock.Release_Read;
            raise;
      end;
      Factory.Lock.Release_Read;
   end Find_Bundle;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Found   : out Boolean) is
      use Ada.Directories;
      use Ada.Strings;
      use Util.Strings;
      use Ada.Containers;
      use Util.Strings.String_Set;
      use Bundle_Map;

      Path    : constant String := To_String (Factory.Path);
      Filter  : constant Filter_Type := (Ordinary_File => True, others => False);
      Pattern : constant String := Name & "*.properties";
      Ent     : Directory_Entry_Type;
      Names   : Util.Strings.String_Set.Set;
      Search  : Search_Type;
   begin
      Log.Info ("Reading bundle {1} in directory {0}", Path, Name);

      Found := False;
      Start_Search (Search, Directory => Path,
                    Pattern => Pattern, Filter => Filter);

      Factory.Lock.Write;

      begin
         --  Scan the directory and load all the property files.
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Simple      : constant String := Simple_Name (Ent);
               File_Path   : constant String := Full_Name (Ent);
               Bundle      : constant Bundle_Manager_Access := new Manager;
               Bundle_Name : constant Name_Access
                 := new String '(Simple (Simple'First .. Simple'Last - 11));
            begin
               Log.Debug ("Loading file {0}", File_Path);

               Interface_P.Manager'Class (Bundle.Impl.all).Load_Properties (File_Path);
               Factory.Bundles.Include (Key => Bundle_Name, New_Item => Bundle);
               Found := True;
               Names.Insert (Bundle_Name);
            end;
         end loop;

         --  Link the property files to implement the localization default rules.
         while Names.Length > 0 loop
            declare
               Name_Pos    : String_Set.Cursor := Names.First;
               Bundle_Name : constant Name_Access := String_Set.Element (Name_Pos);
               Idx         : Natural := Fixed.Index (Bundle_Name.all, "_", Backward);
               Bundle_Pos  : constant Bundle_Map.Cursor := Factory.Bundles.Find (Bundle_Name);
               Bundle      : constant Bundle_Manager_Access := Element (Bundle_Pos);
            begin
               Names.Delete (Name_Pos);

               --  Associate the property bundle to the first existing parent
               --  Ex:  message_fr_CA -> message_fr
               --       message_fr_CA -> message
               while Idx > 0 loop
                  declare
                     Name : aliased constant String
                       := Bundle_Name (Bundle_Name'First .. Idx - 1);
                     Pos : constant Bundle_Map.Cursor
                       := Factory.Bundles.Find (Name'Unchecked_Access);
                  begin
                     if Bundle_Map.Has_Element (Pos) then
                        Bundle.Add_Bundle (Bundle_Map.Element (Pos).all'Access);
                        Idx := 0;
                     else
                        Idx := Fixed.Index (Bundle_Name.all, "_", Idx - 1, Backward);
                     end if;
                  end;
               end loop;
            end;
         end loop;

      exception
         when others =>
            Factory.Lock.Release_Write;
            raise;
      end;
      Factory.Lock.Release_Write;

   exception
      when Name_Error =>
         Log.Error ("Cannot read directory: {0}", Path);

   end Load_Bundle;

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package body Interface_P is
      use PropertyList;

      --  ------------------------------
      --  Returns TRUE if the property exists.
      --  ------------------------------
      function Exists (Self : in Manager; Name : in Value)
                      return Boolean is
         Iter : Cursor := Self.List.First;
      begin
         if Self.Props.Exists (Name) then
            return True;
         end if;
         while Has_Element (Iter) loop
            if Element (Iter).Exists (Name) then
               return True;
            end if;
            Iter := Next (Iter);
         end loop;
         return False;
      end Exists;

      --  ------------------------------
      --  Returns the property value.  Raises an exception if not found.
      --  ------------------------------
      function Get (Self : in Manager; Name : in Value)
                   return Value is
      begin
         return Self.Props.Get (Name);

      exception
         when NO_PROPERTY =>
            declare
               Iter : Cursor := Self.List.First;
            begin
               while Has_Element (Iter) loop
                  begin
                     return Element (Iter).all.Get (Name);
                  exception
                     when NO_PROPERTY =>
                        Iter := Next (Iter);
                  end;
               end loop;
            end;
            raise;
      end Get;

      procedure Load_Properties (Self : in out Manager;
                                 File : in String) is
      begin
         Self.Props.Load_Properties (File);
      end Load_Properties;

      procedure Insert (Self : in out Manager;
                        Name : in Value;
                        Item : in Value) is
         pragma Unreferenced (Self);
         pragma Unreferenced (Name);
         pragma Unreferenced (Item);
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Insert;

      --  ------------------------------
      --  Set the value of the property.  The property is created if it
      --  does not exists.
      --  ------------------------------
      procedure Set (Self : in out Manager;
                     Name : in Value;
                     Item : in Value) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Set;

      --  ------------------------------
      --  Remove the property given its name.
      --  ------------------------------
      procedure Remove (Self : in out Manager; Name : in Value) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Remove;

      --  ------------------------------
      --  Deep copy of properties stored in 'From' to 'To'.
      --  ------------------------------
      function Create_Copy (Self : in Manager)
                            return Util.Properties.Interface_P.Manager_Access is
         pragma Unreferenced (Self);
      begin
         return null;
      end Create_Copy;

      procedure Delete (Self : in Manager;
                        Obj : in out Util.Properties.Interface_P.Manager_Access) is
         pragma Unreferenced (Self);
         Item : Manager_Object_Access := Manager (Obj.all)'Access;
      begin
         Free (Item);
      end Delete;

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array is
         Result : Name_Array (1 .. 2);
         Iter : Cursor := Self.List.First;
      begin
         while Has_Element (Iter) loop
            declare
               N : constant Name_Array := Element (Iter).Get_Names (Prefix);
            begin
               return N;
            end;
            Iter := Next (Iter);
         end loop;
         return Result;
      end Get_Names;

      procedure Add_Bundle (Self  : in out Manager;
                            Props : in Util.Properties.Manager_Access) is
      begin
         Self.List.Append (Props);
      end Add_Bundle;

   end Interface_P;

   --  ------------------------------
   --  Clear the bundle cache
   --  ------------------------------
   procedure Clear_Cache (Factory : in out Loader) is
      use Util.Strings;
      use Bundle_Map;

      function To_String_Access is
        new Ada.Unchecked_Conversion (Source => Util.Strings.Name_Access,
                                      Target => Util.Strings.String_Access);

   begin
      Log.Info ("Clearing bundle cache");

      Factory.Lock.Write;
      loop
         declare
            Pos  : Bundle_Map.Cursor := Factory.Bundles.First;
            Name : Util.Strings.String_Access;
            Node : Bundle_Manager_Access;
         begin
            exit when not Has_Element (Pos);
            Node := Element (Pos);
            Name := To_String_Access (Key (Pos));
            Factory.Bundles.Delete (Pos);
            Free (Node);
            Free (Name);
         end;
      end loop;
      Factory.Lock.Release_Write;
   end Clear_Cache;

   --  ------------------------------
   --  Finalize the bundle loader and clear the cache
   --  ------------------------------
   procedure Finalize (Factory : in out Loader) is
   begin
      Clear_Cache (Factory);
   end Finalize;

end Util.Properties.Bundles;

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

with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with Ada.Directories;
with Ada.Containers.Vectors;
with Ada.Strings.Fixed;
with Util.Log.Loggers;
package body Util.Properties.Bundles is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Util.Properties.Bundles");

   procedure Free is
     new Ada.Unchecked_Deallocation (Manager'Class,
                                     Bundle_Manager_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (String,
                                     Util.Strings.String_Access);

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is new Util.Properties.Interface_P.Manager with private;
      type Manager_Object_Access is access all Manager;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager; Name : in Value)
                       return Boolean;

      --  Returns the property value.  Raises an exception if not found.
      function Get (Self : in Manager; Name : in Value)
                    return Value;

      procedure Insert (Self : in out Manager; Name : in Value;
                        Item : in Value);

      --  Set the value of the property.  The property is created if it
      --  does not exists.
      procedure Set (Self : in out Manager; Name : in Value;
                     Item : in Value);

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager; Name : in Value);

      procedure Load_Properties (Self : in out Manager;
                                 File : in String);

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                           return Util.Properties.Interface_P.Manager_Access;

      procedure Delete (Self : in Manager;
                        Obj : in out Util.Properties.Interface_P.Manager_Access);

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array;

      procedure Add_Bundle (Self : in out Manager;
                            Props : in Util.Properties.Manager_Access);
   private
      use type Util.Properties.Manager_Access;

      package PropertyList is new Ada.Containers.Vectors
        (Element_Type => Util.Properties.Manager_Access,
         Index_Type => Natural,
           "=" => "=");

      type Manager is new Util.Properties.Interface_P.Manager with record
         List  : PropertyList.Vector;
         Props : aliased Util.Properties.Manager;
      end record;

      procedure Free is
        new Ada.Unchecked_Deallocation (Manager,
                                        Manager_Object_Access);
   end Interface_P;

   procedure Add_Bundle (Self  : in out Manager;
                         Props : in Manager_Access) is
      use type Util.Properties.Interface_P.Manager_Access;
   begin
      Interface_P.Manager'Class (Self.Impl.all).Add_Bundle (Props);
   end Add_Bundle;

   procedure Initialize (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
      Object.Impl.Count := 1;
   end Initialize;

   procedure Adjust (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      if Object.Impl /= null then
         Object.Impl.Count := Object.Impl.Count + 1;
      else
         Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
         Object.Impl.Count := 1;
      end if;
   end Adjust;

   --  ------------------------------
   --  Initialize the bundle factory and specify where the property files are stored.
   --  ------------------------------
   procedure Initialize (Factory : in out Loader;
                         Path    : in String) is
   begin
      Log.Info ("Initialize bundle factory to load from {0}", Path);

      Factory.Path := To_Unbounded_String (Path);
   end Initialize;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class) is
      Found : Boolean := False;
   begin
      Log.Info ("Load bundle {0} for language {1}", Name, Locale);

      Find_Bundle (Factory, Name, Locale, Bundle, Found);
      if not Found then
         Load_Bundle (Factory, Name, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
         Find_Bundle (Factory, Name, Locale, Bundle, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
      end if;
   end Load_Bundle;

   --  ------------------------------
   --  Find the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Find_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class;
                          Found   : out Boolean) is
      use Ada.Strings;
      use type Util.Properties.Manager_Access;

      Loc_Name : constant String := '_' & Locale;
      Last_Pos : Natural := Loc_Name'Last;
   begin
      Log.Info ("Looking for bundle {0} and language {1}", Name, Locale);

      Found := False;
      Factory.Lock.Read;
      declare
         Pos : Bundle_Map.Cursor;
      begin
         while Last_Pos >= Loc_Name'First loop
            declare
               Bundle_Name : aliased constant String
                 := Name & Loc_Name (Loc_Name'First .. Last_Pos);
            begin
               Pos := Factory.Bundles.Find (Bundle_Name'Unrestricted_Access);
               if Bundle_Map.Has_Element (Pos) then
                  Bundle.Finalize;
                  Bundle.Impl := Bundle_Map.Element (Pos).Impl;
                  Bundle.Impl.Count := Bundle.Impl.Count + 1;
                  Found := True;
                  exit;
               end if;
            end;
            if Last_Pos > Loc_Name'First then
               Last_Pos := Fixed.Index (Loc_Name, "_", Last_Pos - 1, Backward);
            else
               Last_Pos := Last_Pos - 1;
            end if;
         end loop;
      exception
         when others =>
            Factory.Lock.Release_Read;
            raise;
      end;
      Factory.Lock.Release_Read;
   end Find_Bundle;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Found   : out Boolean) is
      use Ada.Directories;
      use Ada.Strings;
      use Util.Strings;
      use Ada.Containers;
      use Util.Strings.String_Set;
      use Bundle_Map;

      Path    : constant String := To_String (Factory.Path);
      Filter  : constant Filter_Type := (Ordinary_File => True, others => False);
      Pattern : constant String := Name & "*.properties";
      Ent     : Directory_Entry_Type;
      Names   : Util.Strings.String_Set.Set;
      Search  : Search_Type;
   begin
      Log.Info ("Reading bundle {1} in directory {0}", Path, Name);

      Found := False;
      Start_Search (Search, Directory => Path,
                    Pattern => Pattern, Filter => Filter);

      Factory.Lock.Write;

      begin
         --  Scan the directory and load all the property files.
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Simple      : constant String := Simple_Name (Ent);
               File_Path   : constant String := Full_Name (Ent);
               Bundle      : constant Bundle_Manager_Access := new Manager;
               Bundle_Name : constant Name_Access
                 := new String '(Simple (Simple'First .. Simple'Last - 11));
            begin
               Log.Debug ("Loading file {0}", File_Path);

               Interface_P.Manager'Class (Bundle.Impl.all).Load_Properties (File_Path);
               Factory.Bundles.Include (Key => Bundle_Name, New_Item => Bundle);
               Found := True;
               Names.Insert (Bundle_Name);
            end;
         end loop;

         --  Link the property files to implement the localization default rules.
         while Names.Length > 0 loop
            declare
               Name_Pos    : String_Set.Cursor := Names.First;
               Bundle_Name : constant Name_Access := String_Set.Element (Name_Pos);
               Idx         : Natural := Fixed.Index (Bundle_Name.all, "_", Backward);
               Bundle_Pos  : constant Bundle_Map.Cursor := Factory.Bundles.Find (Bundle_Name);
               Bundle      : constant Bundle_Manager_Access := Element (Bundle_Pos);
            begin
               Names.Delete (Name_Pos);

               --  Associate the property bundle to the first existing parent
               --  Ex:  message_fr_CA -> message_fr
               --       message_fr_CA -> message
               while Idx > 0 loop
                  declare
                     Name : aliased constant String
                       := Bundle_Name (Bundle_Name'First .. Idx - 1);
                     Pos : constant Bundle_Map.Cursor
                       := Factory.Bundles.Find (Name'Unchecked_Access);
                  begin
                     if Bundle_Map.Has_Element (Pos) then
                        Bundle.Add_Bundle (Bundle_Map.Element (Pos).all'Access);
                        Idx := 0;
                     else
                        Idx := Fixed.Index (Bundle_Name.all, "_", Idx - 1, Backward);
                     end if;
                  end;
               end loop;
            end;
         end loop;

      exception
         when others =>
            Factory.Lock.Release_Write;
            raise;
      end;
      Factory.Lock.Release_Write;

   exception
      when Name_Error =>
         Log.Error ("Cannot read directory: {0}", Path);

   end Load_Bundle;

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package body Interface_P is
      use PropertyList;

      --  ------------------------------
      --  Returns TRUE if the property exists.
      --  ------------------------------
      function Exists (Self : in Manager; Name : in Value)
                      return Boolean is
         Iter : Cursor := Self.List.First;
      begin
         if Self.Props.Exists (Name) then
            return True;
         end if;
         while Has_Element (Iter) loop
            if Element (Iter).Exists (Name) then
               return True;
            end if;
            Iter := Next (Iter);
         end loop;
         return False;
      end Exists;

      --  ------------------------------
      --  Returns the property value.  Raises an exception if not found.
      --  ------------------------------
      function Get (Self : in Manager; Name : in Value)
                   return Value is
      begin
         return Self.Props.Get (Name);

      exception
         when NO_PROPERTY =>
            declare
               Iter : Cursor := Self.List.First;
            begin
               while Has_Element (Iter) loop
                  begin
                     return Element (Iter).all.Get (Name);
                  exception
                     when NO_PROPERTY =>
                        Iter := Next (Iter);
                  end;
               end loop;
            end;
            raise;
      end Get;

      procedure Load_Properties (Self : in out Manager;
                                 File : in String) is
      begin
         Self.Props.Load_Properties (File);
      end Load_Properties;

      procedure Insert (Self : in out Manager;
                        Name : in Value;
                        Item : in Value) is
         pragma Unreferenced (Self);
         pragma Unreferenced (Name);
         pragma Unreferenced (Item);
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Insert;

      --  ------------------------------
      --  Set the value of the property.  The property is created if it
      --  does not exists.
      --  ------------------------------
      procedure Set (Self : in out Manager;
                     Name : in Value;
                     Item : in Value) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Set;

      --  ------------------------------
      --  Remove the property given its name.
      --  ------------------------------
      procedure Remove (Self : in out Manager; Name : in Value) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Remove;

      --  ------------------------------
      --  Deep copy of properties stored in 'From' to 'To'.
      --  ------------------------------
      function Create_Copy (Self : in Manager)
                            return Util.Properties.Interface_P.Manager_Access is
         pragma Unreferenced (Self);
      begin
         return null;
      end Create_Copy;

      procedure Delete (Self : in Manager;
                        Obj : in out Util.Properties.Interface_P.Manager_Access) is
         pragma Unreferenced (Self);
         Item : Manager_Object_Access := Manager (Obj.all)'Access;
      begin
         Free (Item);
      end Delete;

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array is
         Result : Name_Array (1 .. 2);
         Iter : Cursor := Self.List.First;
      begin
         while Has_Element (Iter) loop
            declare
	       M : constant Util.Properties.Manager_Access := Element (Iter);
               N : constant Name_Array := M.Get_Names (Prefix);
            begin
               return N;
            end;
            Iter := Next (Iter);
         end loop;
         return Result;
      end Get_Names;

      procedure Add_Bundle (Self  : in out Manager;
                            Props : in Util.Properties.Manager_Access) is
      begin
         Self.List.Append (Props);
      end Add_Bundle;

   end Interface_P;

   --  ------------------------------
   --  Clear the bundle cache
   --  ------------------------------
   procedure Clear_Cache (Factory : in out Loader) is
      use Util.Strings;
      use Bundle_Map;

      function To_String_Access is
        new Ada.Unchecked_Conversion (Source => Util.Strings.Name_Access,
                                      Target => Util.Strings.String_Access);

   begin
      Log.Info ("Clearing bundle cache");

      Factory.Lock.Write;
      loop
         declare
            Pos  : Bundle_Map.Cursor := Factory.Bundles.First;
            Name : Util.Strings.String_Access;
            Node : Bundle_Manager_Access;
         begin
            exit when not Has_Element (Pos);
            Node := Element (Pos);
            Name := To_String_Access (Key (Pos));
            Factory.Bundles.Delete (Pos);
            Free (Node);
            Free (Name);
         end;
      end loop;
      Factory.Lock.Release_Write;
   end Clear_Cache;

   --  ------------------------------
   --  Finalize the bundle loader and clear the cache
   --  ------------------------------
   procedure Finalize (Factory : in out Loader) is
   begin
      Clear_Cache (Factory);
   end Finalize;

end Util.Properties.Bundles;

Fix compilation with gcc 4.4.1

Fix compilation with gcc 4.4.1


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                           A 4 G . D D A _ A U X                          --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--                            $Revision: 14154 $
--                                                                          --
--           Copyright (C) 1999-2001 Ada Core Technologies, Inc.            --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains auxiliary routines used to support the data
--  decomposition annex. At the level of this package, types and components
--  are represented by their normal Entity_Id values. The corresponding
--  entities have the necessary representation information stored in them.

--  DDA_Aux acts as an interface between the main ASIS routines and all
--  representation issues.

with Asis.Data_Decomposition;

with Repinfo; use Repinfo;
with Types;   use Types;
with Uintp;   use Uintp;

package A4G.DDA_Aux is

   --------------------------------
   -- Portable_Data Declarations --
   --------------------------------

   --  Asis.Data_Decomposition.Portable_Value;

   --    Portable values are simply bytes, i.e. defined as mod 256. This is
   --    fine for all the byte addressable architectures that GNAT runs on
   --    now, and we will worry later about exotic cases (which may well
   --    never arise).

   --  Portable_Positive is Asis.Data_Decomposition.Portable_Positive;

   --    This is simply a synonym for Asis.ASIS_Positive

   --  Asis.Data_Decomposition.Portable_Data;

   --    This is array (Portable_Positive range <>) of Portable_Data. Thus
   --    it is simply an array of bytes. The representation of data in this
   --    format is as follows:
   --
   --      For non-scalar values, the data value is stored at the start of
   --      the value, occupying as many bits as needed. If there are padding
   --      bits (on the right), they are stored as zero bits when a value is
   --      retrieved, and ignored when a value is stored.
   --
   --      For scalar values, the data value is of length 1, 2, 4, or 8 bytes
   --      in proper little-endian or big-endian format with sign or zero
   --      bits filling the unused high order bits. For enumeration values,
   --      this is the Enum_Rep value, i.e. the actual stored value, not the
   --      Pos value. For biased types, the value is unsigned and biased.

   ---------------------------------
   -- Basic Interface Definiitons --
   ---------------------------------

   Variable_Rep_Info : exception;
   --  This exception is raised if an attempt is made to access representation
   --  information that depends on the value of a variable other than a
   --  discriminant for the current record. For example, if the length of
   --  a component of subtype String (1 .. N) is requested, and N is not a
   --  discriminant or a static constant.

   Invalid_Data : exception;
   --  Exception raised if an invalid data value is detected. There is no
   --  systematic checking for invalid values, but there are some situations
   --  in which bad values are detected, and this exception is raised.

   No_Component : exception;
   --  Exception raised if a request is made to access a component in a
   --  variant part of a record when the component does not exist for the
   --  particular set of discriminant values present. Also raised if a
   --  request is made to access an out of bounds subscript value for an
   --  array element.

   Null_Discrims : Repinfo.Discrim_List (1 .. 0) := (others => Uint_0);
   --  Used as default if no discriminants given

   ----------------------
   -- Utility Routines --
   ----------------------

   function Build_Discrim_List
     (Rec  : Entity_Id;
      Data : Asis.Data_Decomposition.Portable_Data)
      return Repinfo.Discrim_List;
   --  Given a record entity, and a value of this record type, builds a
   --  list of discriminants from the given value and returns it. The
   --  portable data value must include at least all the discriminants
   --  if the type is for a discriminated record. If Rec is other than
   --  a discriminated record type, then Data is ignored and Null_Discrims
   --  is returned.

   function Eval_Scalar_Node
     (N     : Node_Id;
      Discs : Repinfo.Discrim_List := Null_Discrims)
      return  Uint;
   --  This function is used to get the value of a node representing a value
   --  of a scalar type. Evaluation is possible for static expressions and
   --  for discriminant values (in the latter case, Discs must be provided
   --  and must contain the appropriate list of discriminants). Note that
   --  in the case of enumeration values, the result is the Pos value, not
   --  the Enum_Rep value for the given enumeration literal.
   --
   --    Raises Variable_Rep_Info is raised if the expression is other than
   --    a discriminant or a static expression, or if it is a discriminant
   --    and no discriminant list is provided.
   --
   --  Note that this functionality is related to that provided by
   --  Sem_Eval.Expr_Value, but this unit is not available in ASIS.

   function Linear_Index
     (Typ   : Entity_Id;
      Subs  : Asis.Data_Decomposition.Dimension_Indexes;
      Discs : Repinfo.Discrim_List := Null_Discrims)
      return  Asis.ASIS_Natural;
   --  Given Typ, the entity for a definite array type or subtype, and Subs,
   --  a list of 1's origin subscripts (that is, as usual Dimension_Indexes
   --  has subscripts that are 1's origin with respect to the declared lower
   --  bound), this routine computes the corresponding zero-origin linear
   --  index from the start of the array data. The case of Fortran convention
   --  (with row major order) is properly handled.
   --
   --  Raises No_Component if any of the subscripts is out of range (i.e.
   --  exceeds the length of the corresponding subscript position).

   function UI_From_Aint (A : Asis.ASIS_Integer) return Uint;
   --  Converts ASIS_Integer value to Uint

   function UI_Is_In_Aint_Range (U : Uint) return Boolean;
   --  Determine if a universal integer value U is in range of ASIS_Integer.
   --  Returns True iff in range (meaning that UI_To_Aint can be safely used).

   function UI_To_Aint (U : Uint) return Asis.ASIS_Integer;
   --  Converts Uint value to ASIS_Integer, the result must be in range
   --  of ASIS_Integer, or otherwise the exception Invalid_Data is raised.

   --------------------------------
   -- Universal Integer Encoding --
   --------------------------------

   --  These routines deal with decoding and encoding scalar values from
   --  Uint to portable data format.

   function Encode_Scalar_Value
     (Typ  : Entity_Id;
      Val  : Uint)
      return Asis.Data_Decomposition.Portable_Data;
   --  Given Typ, the entity for a scalar type or subtype, this function
   --  constructs a portable data valuethat represents a value of this
   --  type given by Val. The value of the Uint may not exceed the largest
   --  scalar value supported by the implementation. The result will be 1,
   --  2, 4 or 8 bytes long depending on the value of the input, positioned
   --  to be intepreted as an integer, and sign or zero extended as needed.
   --  For enumeration types, the value is the Enum_Rep value, not the Pos
   --  value. For biased types, the bias is NOT present in the Uint value
   --  (part of the job of Encode_Scalar_Value is to introduce the bias).
   --
   --    Raises Invalid_Data if value is out of range of the base type of Typ

   function Encode_Scalar_Value
     (Typ  : Entity_Id;
      Val  : Asis.ASIS_Integer)
      return Asis.Data_Decomposition.Portable_Data;
   --  Similar to above function except input is ASIS_Integer instead of Uint

   function Decode_Scalar_Value
     (Typ  : Entity_Id;
      Data : Asis.Data_Decomposition.Portable_Data)
      return Uint;
   --  Given Typ, the entity for a scalar type or subtype, this function
   --  takes the portable data value Data, that represents a value of
   --  this type, and returns the equivalent Uint value. For enumeration
   --  types the value is the Enum_Rep value, not the Pos value. For biased
   --  types, the result is unbiased (part of the job of Decode_Scalar_Value
   --  is to remove the bias).

   --------------------------------
   -- Record Discriminant Access --
   --------------------------------

   function Extract_Discriminant
     (Data : Asis.Data_Decomposition.Portable_Data;
      Disc : Entity_Id)
      return Uint;
   --  This function can be used to extract a discriminant value from a
   --  record. Data is the portable data value representing the record
   --  value, and Disc is the E_Discriminant entity for the discriminant.

   function Set_Discriminant
     (Data : Asis.Data_Decomposition.Portable_Data;
      Disc : Entity_Id;
      Val  : Uint)
      return Asis.Data_Decomposition.Portable_Data;
   --  Given Data, a portable data value representing the prefix of a record
   --  value which may already have some other discriminant values set, this
   --  function creates a new Portable_Data value, increased in length
   --  if necessary, in which the discriminant represented by E_Discriminant
   --  entity Disc is set to the given value.
   --
   --    Raises Invalid_Data if the value does not fit in the field

   procedure Set_Discriminant
     (Data : in out Asis.Data_Decomposition.Portable_Data;
      Disc : Entity_Id;
      Val  : Uint);
   --  Similar to the function above, except that the modification is done
   --  in place on the given portable data value. In this case, the Data
   --  value must be long enough to contain the given discriminant field.

   function Set_Discriminant
     (Data : Asis.Data_Decomposition.Portable_Data;
      Disc : Entity_Id;
      Val  : Asis.ASIS_Integer)
      return Asis.Data_Decomposition.Portable_Data;
   --  Similar to function above, but takes argument in ASIS_Integer form

   procedure Set_Discriminant
     (Data : in out Asis.Data_Decomposition.Portable_Data;
      Disc : Entity_Id;
      Val  : Asis.ASIS_Integer);
   --  Similar to function above, but takes argument in ASIS_Integer form

   -----------------------------
   -- Record Component Access --
   -----------------------------

   function Component_Present
     (Comp  : Entity_Id;
      Discs : Repinfo.Discrim_List)
      return  Boolean;
   --  Determines if the given component is present or not. For the case
   --  where the component is part of a variant of a discriminated record,
   --  Discs must contain the full list of discriminants for the record,
   --  and the result is True or False depending on whether the variant
   --  containing the field is present or not for the given discriminant
   --  values. If the component is not part of a variant, including the
   --  case where the record is non-discriminated, then Discs is ignored
   --  and the result is always True.

   function Extract_Record_Component
     (Data  : Asis.Data_Decomposition.Portable_Data;
      Comp  : Entity_Id;
      Discs : Repinfo.Discrim_List := Null_Discrims)
      return  Asis.Data_Decomposition.Portable_Data;
   --  Given Data, a portable data value representing a record value, this
   --  routine extracts the component value corresponding to E_Component
   --  entity Comp, and returns a new portable data value corresponding to
   --  this component. The Discs parameter supplies the discriminants and
   --  must be present in the discriminated record case if the component
   --  may depend on discriminants. For scalar types, the result value
   --  is 1,2,4, or 8 bytes, properly positioned to be interpreted as an
   --  integer, and sign/zero extended as required. For all other types,
   --  the value is extended if necessary to be an integral number of
   --  bytes by adding zero bits.
   --
   --    Raises No_Component if an attempt is made to set a component in a
   --    non-existent variant.
   --
   --    Raises No_Component if the specified component is part of a variant
   --    that does not exist for the given discriminant values
   --
   --    Raises Variable_Rep_Info if the size or position of the component
   --    depends on a variable other than a discriminant

   function Set_Record_Component
     (Data  : Asis.Data_Decomposition.Portable_Data;
      Comp  : Entity_Id;
      Val   : Asis.Data_Decomposition.Portable_Data;
      Discs : Repinfo.Discrim_List := Null_Discrims)
      return  Asis.Data_Decomposition.Portable_Data;
   --  Given Data, a portable data value that represents a record value,
   --  or a prefix of such a record, sets the component represented by the
   --  E_Component entity Comp is set to the value represented by the portable
   --  data value Val, and the result is returned as a portable data value,
   --  extended in length if necessary to accomodate the newly added entry.
   --  The Discs parameter supplies the discriminants and must be present
   --  in the discriminated record case if the component may depend on
   --  the values of discriminants.
   --
   --    Raises No_Component if an attempt is made to set a component in a
   --    non-existent variant.
   --
   --    Raises No_Component if the specified component is part of a variant
   --    that does not exist for the given discriminant values
   --
   --    Raises Variable_Rep_Info if the size or position of the component
   --    depends on a variable other than a discriminant
   --
   --    Raises Invalid_Data if the data value is too large to fit.

   procedure Set_Record_Component
     (Data  : in out Asis.Data_Decomposition.Portable_Data;
      Comp  : Entity_Id;
      Val   : Asis.Data_Decomposition.Portable_Data;
      Discs : Repinfo.Discrim_List := Null_Discrims);
   --   Same as the above, but operates in place on the given data value,
   --   which must in this case be long enough to contain the component.

   ----------------------------
   -- Array Component Access --
   ----------------------------

   function Extract_Array_Component
     (Typ   : Entity_Id;
      Data  : Asis.Data_Decomposition.Portable_Data;
      Subs  : Asis.Data_Decomposition.Dimension_Indexes;
      Discs : Repinfo.Discrim_List := Null_Discrims)
      return  Asis.Data_Decomposition.Portable_Data;
   --  Given Typ, the entity for an array type, and Data, a portable data
   --  value representing a value of this array type, this function extracts
   --  the array element corresponding to the given list of subscript values.
   --  The parameter Discs must be given if any of the bounds of the array
   --  may depend on discriminant values, and supplies the corresponding
   --  discriminants. For scalar component types, the value is 1,2,4, or 8,
   --  properly positioned to be interpreted as an integer, and sign/zero
   --  extended as required. For all other types, the value is extended if
   --  necessary to be an integral number of bytes by adding zero bits.
   --
   --    Raises No_Component if any of the subscripts is out of bounds
   --    (that is, exceeds the length of the corresponding index).
   --
   --    Raises Variable_Rep_Info if length of any index depends on a
   --    variable other than a discriminant.
   --
   function Set_Array_Component
     (Typ   : Entity_Id;
      Data  : Asis.Data_Decomposition.Portable_Data;
      Subs  : Asis.Data_Decomposition.Dimension_Indexes;
      Val   : Asis.Data_Decomposition.Portable_Data;
      Discs : Repinfo.Discrim_List := Null_Discrims)
      return  Asis.Data_Decomposition.Portable_Data;
   --  Given a portable data value representing either a value of the array
   --  type Typ, or a prefix of such a value, sets the element referenced by
   --  the given subscript values in Subs, to the given value Val. The
   --  parameter Discs must be given if any of the bounds of the array
   --  may depend on discriminant values, and supplies the corresponding
   --  discriminants. The returned result is the original portable data
   --  value, extended if necessary to include the new element, with the
   --  new element value in place.
   --
   --    Raises No_Component if any of the subscripts is out of bounds
   --    (that is, exceeds the length of the corresponding index).
   --
   --    Raises Variable_Rep_Info if length of any index depends on a
   --    variable other than a discriminant.
   --
   --    Raises Invalid_Data if the data value is too large to fit.

   procedure Set_Array_Component
     (Typ   : Entity_Id;
      Data  : in out Asis.Data_Decomposition.Portable_Data;
      Subs  : Asis.Data_Decomposition.Dimension_Indexes;
      Val   : Asis.Data_Decomposition.Portable_Data;
      Discs : Repinfo.Discrim_List := Null_Discrims);
   --  Same as above, but operates in place on the given stream. The stream
   --  must be long enough to contain the given element in this case.

   -------------------------------
   -- Representation Parameters --
   -------------------------------

   --  These routines give direct access to the values of the
   --  representation fields stored in the tree, including the
   --  proper interpretation of variable values that depend on
   --  the values of discriminants.

   function Get_Esize
     (Comp  : Entity_Id;
      Discs : Repinfo.Discrim_List := Null_Discrims)
      return  Uint;
   --  Obtains the size (actually the object size, Esize) of any subtype
   --  or record component or discriminant. The function can be used for
   --  components of discriminanted or non-discriminated records. In the
   --  case of components of a discriminated record where the value depends
   --  on discriminants, Discs provides the necessary discriminant values.
   --  In all other cases, Discs is ignored and can be defaulted.
   --
   --    Raises Variable_Rep_Info if the size depends on a variable other
   --    than a discriminant.
   --
   --    Raises No_Component if the component is in a variant that does not
   --    exist for the given set of discriminant values.

   function Get_Component_Bit_Offset
     (Comp  : Entity_Id;
      Discs : Repinfo.Discrim_List := Null_Discrims)
      return  Uint;
   --  Obtains the component first bit value for the specified component or
   --  discriminant. This function can be used for discriminanted or non-
   --  discriminanted records. In the case of components of a discriminated
   --  record where the value depends on discriminants, Discs provides the
   --  necessary discriminant values. Otherwise (and in particular in the case
   --  of discriminants themselves), Discs is ignored and can be defaulted.
   --
   --    Raises Variable_Rep_Info if the size depends on a variable other
   --    than a discriminant.
   --
   --    Raises No_Component if the component is in a variant that does not
   --    exist for the given set of discriminant values.

   function Get_Component_Size
      (Typ  : Entity_Id)
       return Uint;
   --  Given an array type or subtype, returns the component size value

   function Get_Length
     (Typ   : Entity_Id;
      Sub   : Asis.ASIS_Positive;
      Discs : Repinfo.Discrim_List := Null_Discrims)
      return  Asis.ASIS_Natural;
   --  Given Typ, the entity for a definite array type or subtype, returns
   --  the Length of the subscript designated by Sub (1 = first subscript
   --  as in Length attribute). If the bounds of the array may depend on
   --  discriminants, then Discs contains the list of discriminant values
   --  (e.g. if we have an array field A.B, then the discriminants of A
   --  may be needed).
   --
   --    Raises Variable_Rep_Info if the size depends on a variable other
   --    than a discriminant.

   -------------------------------
   -- Computation of Attributes --
   -------------------------------

   --  The DDA_Aux package simply provides access to the representation
   --  information stored in the tree, as described in Einfo, as refined
   --  by the description in Repinfo with regard to the case where some
   --  of the values depend on discriminants.

   --  The ASIS spec requires that ASIS be able to compute the values of
   --  the attributes Position, First_Bit, and Last_Bit.

   --  This is done as follows. First compute the Size (with Get_Esize)
   --  and the Component_Bit_Offset (with Get_Component_Bit_Offset). In the
   --  case of a nested reference, e.g.

   --     A.B.C

   --       You need to extract the value A.B, and then ask for the
   --       size of its component C, and also the component first bit
   --       value of this component C.

   --       This value gets added to the Component_Bit_Offset value for
   --       the B field in A.

   --  For arrays, the equivalent of Component_Bit_Offset is computed simply
   --  as the zero origin linearized subscript multiplied by the value of
   --  Component_Size for the array. As another example, consider:

   --     A.B(15)

   --  In this case you get the component first bit of the field B in A,
   --  using the discriminants of A if there are any. Then you get the
   --  component first bit of the 15th element of B, using the discriminants
   --  of A (since the bounds of B may depend on them). You then add these
   --  two component first bit values.

   --  Once you have the aggregated value of the first bit offset (i.e. the
   --  sum of the Component_Bit_Offset values and corresponding array offsets
   --  for all levels of the access), then the formula is simply:

   --     X'Position = First_Bit_Offset / Storage_Unit_Size

   --     X'First    = First_Bit_Offset mod Storage_Unit_Size

   --     X'Last     = X'First + component_size - 1

end A4G.DDA_Aux;

Add the ASIS file $i

Add the ASIS file $i


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

with Util.Test_Caller;
with Util.Beans.Objects;

with ASF.Tests;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Applications.Main;
with ASF.Applications.Main.Configs;
with ASF.Applications.Tests;
package body ASF.Navigations.Tests is

   use Util.Beans.Objects;
   use ASF.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test navigation exact match (view, outcome, action)",
                       Test_Exact_Navigation'Access);

      Caller.Add_Test (Suite, "Test navigation partial match (view, outcome)",
                       Test_Partial_Navigation'Access);

      Caller.Add_Test (Suite, "Test navigation exception match (view, outcome)",
                       Test_Exception_Navigation'Access);

   end Add_Tests;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);

      use type ASF.Applications.Main.Application_Access;
      Fact     : ASF.Applications.Main.Application_Factory;
   begin
      if ASF.Tests.Get_Application = null then
         ASF.Tests.Initialize (Util.Tests.Get_Properties, Factory => Fact);
      end if;
   end Set_Up;

   --  ------------------------------
   --  Check the navigation for an URI and expect the result to match the regular expression.
   --  ------------------------------
   procedure Check_Navigation (T     : in out Test;
                               Name  : in String;
                               Match : in String;
                               Raise_Flag : in Boolean := False) is
      Request  : ASF.Requests.Mockup.Request;
      Reply    : ASF.Responses.Mockup.Response;
      Form     : aliased ASF.Applications.Tests.Form_Bean;
      File     : constant String := Util.Tests.Get_Path ("regtests/config/test-navigations.xml");
   begin
      Form.Perm_Error := Raise_Flag;
      ASF.Applications.Main.Configs.Read_Configuration (ASF.Tests.Get_Application.all, File);
      Request.Set_Attribute ("form", To_Object (Value   => Form'Unchecked_Access,
                                                Storage => STATIC));
      Do_Get (Request, Reply, "/tests/" & Name & ".html", Name & ".txt");

      Request.Set_Parameter ("formText", "1");
      Request.Set_Parameter ("name", "John");
      Request.Set_Parameter ("password", "12345");
      Request.Set_Parameter ("email", "john@gmail.com");
      Request.Set_Parameter ("ok", "1");
      Do_Post (Request, Reply, "/tests/" & Name & ".html", Name & "form-navigation-exact.txt");
      Assert_Matches (T, Match,
                      Reply, "Wrong generated content");
   end Check_Navigation;

   --  ------------------------------
   --  Test a form navigation with an exact match (view, outcome, action).
   --  ------------------------------
   procedure Test_Exact_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav", ".*success.*");
   end Test_Exact_Navigation;

   --  ------------------------------
   --  Test a form navigation with a partial match (view, outcome).
   --  ------------------------------
   procedure Test_Partial_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav-partial", ".*success partial.*");
   end Test_Partial_Navigation;

   --  ------------------------------
   --  Test a form navigation with a exception match (view, outcome).
   --  ------------------------------
   procedure Test_Exception_Navigation (T : in out Test) is
   begin
      T.Check_Navigation ("form-nav-exception", ".*success exception.*", True);
   end Test_Exception_Navigation;

end ASF.Navigations.Tests;

Add navigation rule unit test

Add navigation rule unit test


-----------------------------------------------------------------------
--  wiki-parsers-google -- Google Code parser operations
--  Copyright (C) 2011 - 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 Wiki.Parsers.Common;
private package Wiki.Parsers.Google is

   pragma Preelaborate;

   Wiki_Table : aliased constant Parser_Table
     := (
         16#0A# => Parse_End_Line'Access,
         16#0D# => Parse_End_Line'Access,
         Character'Pos (' ') => Parse_Space'Access,
         Character'Pos ('=') => Common.Parse_Header'Access,
         Character'Pos ('*') => Common.Parse_Single_Bold'Access,
         Character'Pos ('_') => Common.Parse_Single_Italic'Access,
         Character'Pos ('`') => Common.Parse_Single_Code'Access,
         Character'Pos ('^') => Common.Parse_Single_Superscript'Access,
         Character'Pos ('~') => Common.Parse_Double_Strikeout'Access,
         Character'Pos (',') => Common.Parse_Double_Subscript'Access,
         Character'Pos ('[') => Common.Parse_Link'Access,
         Character'Pos ('\') => Common.Parse_Line_Break'Access,
         Character'Pos ('#') => Common.Parse_List'Access,
         Character'Pos ('{') => Common.Parse_Preformatted'Access,
         Character'Pos ('}') => Common.Parse_Preformatted'Access,
         Character'Pos ('<') => Parse_Maybe_Html'Access,
         others => Parse_Text'Access
        );

end Wiki.Parsers.Google;

Refactor: move the Google code wiki parser definition in a separate child package


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                           A 4 G . A _ A L L O C                          --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--                              Version : 1.00                              --
--                                                                          --
--            Copyright (c) 1995-1999, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

package A4G.A_Alloc is

--  This package contains definitions for initial sizes and growth increments
--  for the various dynamic arrays used for principle ASIS Context
--  Model data strcutures. The indicated initial size is allocated for the
--  start of each file, and the increment factor is a percentage used
--  to increase the table size when it needs expanding
--  (e.g. a value of 100 = 100% increase = double)

--  This package is the ASIS implementation's analog of the GNAT Alloc package

   Alloc_ASIS_Units_Initial : constant := 1_000;
   --  Initial allocation for unit tables

   Alloc_ASIS_Units_Increment : constant := 150;
   --  Incremental allocation factor for unit tables

   Alloc_Contexts_Initial : constant := 20;
   --  Initial allocation for Context table (A4G.Contt)

   Alloc_Contexts_Increment : constant := 150;
   --  Incremental allocation factor for Context table (Contt)

   Alloc_ASIS_Trees_Initial : constant := 1_000;
   --  Initial allocation for tree tables

   Alloc_ASIS_Trees_Increment : constant := 150;
   --  Incremental allocation factor for tree tables

end A4G.A_Alloc;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  ado-cache-discrete -- Simple cache management for discrete types
--  Copyright (C) 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.
-----------------------------------------------------------------------

package body ADO.Caches.Discrete is

   --  ------------------------------
   --  Expand the name into a target parameter value to be used in the SQL query.
   --  The Expander can return a T_NULL when a value is not found or
   --  it may also raise some exception.
   --  ------------------------------
   overriding
   function Expand (Instance : in out Cache_Type;
                    Name     : in String) return ADO.Parameters.Parameter is
      Value : Element_Type;
   begin
      Value := Instance.Find (Name);
      return ADO.Parameters.Parameter '(T => ADO.Parameters.T_LONG_INTEGER,
                                        Len => 0, Value_Len => 0, Position => 0,
                                        Name => "",
                                        Long_Num => Element_Type'Pos (Value));
   end Expand;

   --  ------------------------------
   --  Find the value associated with the given name.
   --  Raises the No_Value exception if no such mapping exist.
   --  ------------------------------
   function Find (Cache : in out Cache_Type;
                  Name  : in String) return Element_Type is
   begin
      return Cache.Controller.Find (Name);
   end Find;

   --  ------------------------------
   --  Insert the value associated with the given name in the cache.
   --  When <tt>Override</tt> is set, override existing values otherwise raise an exception.
   --  ------------------------------
   procedure Insert (Cache    : in out Cache_Type;
                     Name     : in String;
                     Value    : in Element_Type;
                     Override : in Boolean := False) is
   begin
      Cache.Controller.Insert (Name, Value, Override);
   end Insert;

   --  ------------------------------
   --  Delete the value associated with the given name in the cache.
   --  Raise the No_Value exception if the value is not found and <tt>Ignore</tt> is not set.
   --  ------------------------------
   procedure Delete (Cache  : in out Cache_Type;
                     Name   : in String;
                     Ignore : in Boolean := False) is
   begin
      Cache.Controller.Delete (Name, Ignore);
   end Delete;

   --  ------------------------------
   --  Initialize the entity cache by reading the database entity table.
   --  ------------------------------
   procedure Initialize (Cache   : in out Cache_Type;
                         Session : in out ADO.Sessions.Session'Class) is
   begin
      null;
   end Initialize;

   protected body Cache_Controller is

      --  ------------------------------
      --  Find the value associated with the given name.
      --  Raises the No_Value exception if no such mapping exist.
      --  ------------------------------
      function Find (Name  : in String) return Element_Type is
         Pos : constant Cache_Map.Cursor := Values.Find (Name);
      begin
         if Cache_Map.Has_Element (Pos) then
            return Cache_Map.Element (Pos);
         else
            Log.Info ("Unknown cached value {0}", Name);
            raise No_Value with "Value '" & Name & "' not found";
         end if;
      end Find;

      --  ------------------------------
      --  Insert the value associated with the given name in the cache.
      --  When <tt>Override</tt> is set, override existing values otherwise raise an exception.
      --  ------------------------------
      procedure Insert (Name     : in String;
                        Value    : in Element_Type;
                        Override : in Boolean := False) is
         Pos : constant Cache_Map.Cursor := Values.Find (Name);
      begin
         if Cache_Map.Has_Element (Pos) then
            if not Override then
               raise No_Value;
            end if;
            Values.Replace_Element (Pos, Value);
         else
            Values.Insert (Name, Value);
         end if;
      end Insert;

      --  ------------------------------
      --  Delete the value associated with the given name in the cache.
      --  Raise the No_Value exception if the value is not found and <tt>Ignore</tt> is not set.
      --  ------------------------------
      procedure Delete (Name   : in String;
                        Ignore : in Boolean := False) is
         Pos : Cache_Map.Cursor := Values.Find (Name);
      begin
         if Cache_Map.Has_Element (Pos) then
            Values.Delete (Pos);
         elsif not Ignore then
            raise No_Value;
         end if;
      end Delete;

   end Cache_Controller;

end ADO.Caches.Discrete;

Implement cache for discrete types

Implement cache for discrete types


--  This spec has been automatically generated from STM32F105xx.svd

pragma Restrictions (No_Elaboration_Code);
pragma Ada_2012;

with System;

package STM32.NVIC is
   pragma Preelaborate;

   ---------------
   -- Registers --
   ---------------

   -------------------
   -- ICTR_Register --
   -------------------

   subtype ICTR_INTLINESNUM_Field is STM32.UInt4;

   --  Interrupt Controller Type Register
   type ICTR_Register is record
      --  Read-only. Total number of interrupt lines in groups
      INTLINESNUM   : ICTR_INTLINESNUM_Field;
      --  unspecified
      Reserved_4_31 : STM32.UInt28;
   end record
     with Volatile_Full_Access, Size => 32,
          Bit_Order => System.Low_Order_First;

   for ICTR_Register use record
      INTLINESNUM   at 0 range 0 .. 3;
      Reserved_4_31 at 0 range 4 .. 31;
   end record;

   ------------------
   -- IPR_Register --
   ------------------

   --  IPR0_IPR_N array element
   subtype IPR0_IPR_N_Element is STM32.Byte;

   --  IPR0_IPR_N array
   type IPR0_IPR_N_Field_Array is array (0 .. 3) of IPR0_IPR_N_Element
     with Component_Size => 8, Size => 32;

   --  Interrupt Priority Register
   type IPR_Register
     (As_Array : Boolean := False)
   is record
      case As_Array is
         when False =>
            --  IPR_N as a value
            Val : STM32.Word;
         when True =>
            --  IPR_N as an array
            Arr : IPR0_IPR_N_Field_Array;
      end case;
   end record
     with Unchecked_Union, Size => 32, Volatile_Full_Access,
          Bit_Order => System.Low_Order_First;

   for IPR_Register use record
      Val at 0 range 0 .. 31;
      Arr at 0 range 0 .. 31;
   end record;

   -------------------
   -- STIR_Register --
   -------------------

   subtype STIR_INTID_Field is STM32.UInt9;

   --  Software Triggered Interrupt Register
   type STIR_Register is record
      --  Write-only. interrupt to be triggered
      INTID         : STIR_INTID_Field := 16#0#;
      --  unspecified
      Reserved_9_31 : STM32.UInt23 := 16#0#;
   end record
     with Volatile_Full_Access, Size => 32,
          Bit_Order => System.Low_Order_First;

   for STIR_Register use record
      INTID         at 0 range 0 .. 8;
      Reserved_9_31 at 0 range 9 .. 31;
   end record;

   -----------------
   -- Peripherals --
   -----------------

   --  Nested Vectored Interrupt Controller
   type NVIC_Peripheral is record
      --  Interrupt Controller Type Register
      ICTR  : ICTR_Register;
      --  Interrupt Set-Enable Register
      ISER0 : STM32.Word;
      --  Interrupt Set-Enable Register
      ISER1 : STM32.Word;
      --  Interrupt Set-Enable Register
      ISER2 : STM32.Word;
      --  Interrupt Clear-Enable Register
      ICER0 : STM32.Word;
      --  Interrupt Clear-Enable Register
      ICER1 : STM32.Word;
      --  Interrupt Clear-Enable Register
      ICER2 : STM32.Word;
      --  Interrupt Set-Pending Register
      ISPR0 : STM32.Word;
      --  Interrupt Set-Pending Register
      ISPR1 : STM32.Word;
      --  Interrupt Set-Pending Register
      ISPR2 : STM32.Word;
      --  Interrupt Clear-Pending Register
      ICPR0 : STM32.Word;
      --  Interrupt Clear-Pending Register
      ICPR1 : STM32.Word;
      --  Interrupt Clear-Pending Register
      ICPR2 : STM32.Word;
      --  Interrupt Active Bit Register
      IABR0 : STM32.Word;
      --  Interrupt Active Bit Register
      IABR1 : STM32.Word;
      --  Interrupt Active Bit Register
      IABR2 : STM32.Word;
      --  Interrupt Priority Register
      IPR0  : IPR_Register;
      --  Interrupt Priority Register
      IPR1  : IPR_Register;
      --  Interrupt Priority Register
      IPR2  : IPR_Register;
      --  Interrupt Priority Register
      IPR3  : IPR_Register;
      --  Interrupt Priority Register
      IPR4  : IPR_Register;
      --  Interrupt Priority Register
      IPR5  : IPR_Register;
      --  Interrupt Priority Register
      IPR6  : IPR_Register;
      --  Interrupt Priority Register
      IPR7  : IPR_Register;
      --  Interrupt Priority Register
      IPR8  : IPR_Register;
      --  Interrupt Priority Register
      IPR9  : IPR_Register;
      --  Interrupt Priority Register
      IPR10 : IPR_Register;
      --  Interrupt Priority Register
      IPR11 : IPR_Register;
      --  Interrupt Priority Register
      IPR12 : IPR_Register;
      --  Interrupt Priority Register
      IPR13 : IPR_Register;
      --  Interrupt Priority Register
      IPR14 : IPR_Register;
      --  Interrupt Priority Register
      IPR15 : IPR_Register;
      --  Interrupt Priority Register
      IPR16 : IPR_Register;
      --  Software Triggered Interrupt Register
      STIR  : STIR_Register;
   end record
     with Volatile;

   for NVIC_Peripheral use record
      ICTR  at 4 range 0 .. 31;
      ISER0 at 256 range 0 .. 31;
      ISER1 at 260 range 0 .. 31;
      ISER2 at 264 range 0 .. 31;
      ICER0 at 384 range 0 .. 31;
      ICER1 at 388 range 0 .. 31;
      ICER2 at 392 range 0 .. 31;
      ISPR0 at 512 range 0 .. 31;
      ISPR1 at 516 range 0 .. 31;
      ISPR2 at 520 range 0 .. 31;
      ICPR0 at 640 range 0 .. 31;
      ICPR1 at 644 range 0 .. 31;
      ICPR2 at 648 range 0 .. 31;
      IABR0 at 768 range 0 .. 31;
      IABR1 at 772 range 0 .. 31;
      IABR2 at 776 range 0 .. 31;
      IPR0  at 1024 range 0 .. 31;
      IPR1  at 1028 range 0 .. 31;
      IPR2  at 1032 range 0 .. 31;
      IPR3  at 1036 range 0 .. 31;
      IPR4  at 1040 range 0 .. 31;
      IPR5  at 1044 range 0 .. 31;
      IPR6  at 1048 range 0 .. 31;
      IPR7  at 1052 range 0 .. 31;
      IPR8  at 1056 range 0 .. 31;
      IPR9  at 1060 range 0 .. 31;
      IPR10 at 1064 range 0 .. 31;
      IPR11 at 1068 range 0 .. 31;
      IPR12 at 1072 range 0 .. 31;
      IPR13 at 1076 range 0 .. 31;
      IPR14 at 1080 range 0 .. 31;
      IPR15 at 1084 range 0 .. 31;
      IPR16 at 1088 range 0 .. 31;
      STIR  at 3840 range 0 .. 31;
   end record;

   --  Nested Vectored Interrupt Controller
   NVIC_Periph : aliased NVIC_Peripheral
     with Import, Address => NVIC_Base;

end STM32.NVIC;

Add a missing file for the EVB1000 BSP example