------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                                                                          --
--                            A 4 G . A _ O P T                             --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2012, 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,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, 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 AdaCore                     --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

with Asis.Errors;  use Asis.Errors;

with A4G.A_Types;  use A4G.A_Types;
with A4G.A_Osint;  use A4G.A_Osint;
with A4G.A_Output; use A4G.A_Output;
with A4G.A_Debug;  use A4G.A_Debug;
with A4G.Vcheck;   use A4G.Vcheck;

with GNAT.OS_Lib;  use GNAT.OS_Lib;

package body A4G.A_Opt is

   -------------------------------------
   -- Process_Finalization_Parameters --
   -------------------------------------

   procedure Process_Finalization_Parameters (Parameters : String) is
      Final_Parameters : Argument_List_Access;

      procedure Process_One_Parameter (Param : String);
      --  incapsulates processing of a separate parameter

      ---------------------------
      -- Process_One_Parameter --
      ---------------------------

      procedure Process_One_Parameter (Param : String) is
         Parameter : constant String (1 .. Param'Length) := Param;
      begin
         ASIS_Warning
            (Message => "Asis.Implementation.Finalize: "
                      & "unknown parameter - "
                      & Parameter,
             Error   => Parameter_Error);
      end Process_One_Parameter;

   begin  -- Process_Finalization_Parameters
      Final_Parameters := Parameter_String_To_List (Parameters);

      for I in Final_Parameters'Range loop
         Process_One_Parameter (Final_Parameters (I).all);
      end loop;

      Free_Argument_List (Final_Parameters);
   end Process_Finalization_Parameters;

   ---------------------------------------
   -- Process_Initialization_Parameters --
   ---------------------------------------

   procedure Process_Initialization_Parameters (Parameters : String) is
      Init_Parameters : Argument_List_Access;

      procedure Process_One_Parameter (Param : String);
      --  incapsulates processing of a separate parameter

      ---------------------------
      -- Process_One_Parameter --
      ---------------------------

      procedure Process_One_Parameter (Param : String) is
         Parameter : constant String (1 .. Param'Length) := Param;
         Unknown_Parameter : Boolean := False;
         subtype Dig is Character range '1' .. '9';
         subtype Let is Character range 'a' .. 'z';

         procedure Process_Parameter;
         procedure Process_Option;
         --  Process_Option works if Param starts from '-', and
         --  Process_Parameter works otherwise

         procedure Process_Parameter is
         begin
            --  no parameter is currently available as an ASIS initialization
            --  parameter
            Raise_ASIS_Failed
               (Diagnosis    => "Asis.Implementation.Initialize: "
                              & "unknown parameter - "
                              & Parameter,
                Stat         => Parameter_Error,
                Internal_Bug => False);
         end Process_Parameter;

         procedure Process_Option is
         begin

            case Parameter (2) is

               when 'a' =>

                  if Parameter = "-asis05"
                    or else
                     Parameter = "-asis12"
                    or else
                     Parameter = "-asis95"
                  then
                     --  We have to accept these parameters because of
                     --  compatibility reasons
                     null;
                  else
                     Unknown_Parameter := True;
                  end if;

               when 'd' =>

                  if   Parameter'Length = 3
                     and then
                      (Parameter (3) in Dig or else
                       Parameter (3) in Let)
                  then
                     Set_Debug_Flag (Parameter (3));
                  elsif Parameter = "-dall" then
                     A4G.A_Debug.Set_On;
                  else
                     Unknown_Parameter := True;
                  end if;

               when 'k' =>

                  if Parameter = "-k" then
                     Keep_Going := True;
                  else
                     Unknown_Parameter := True;
                  end if;

               when 'n' =>

                  if Parameter = "-nbb" then
                     Generate_Bug_Box := False;
                     Keep_Going       := True;
                  else
                     Unknown_Parameter := True;
                  end if;

               when 's' =>

                  if Parameter = "-sv" then
                     Strong_Version_Check := True;
                  else
                     Unknown_Parameter := True;
                  end if;

               when 'w' =>

                  if Parameter = "-ws" then
                     ASIS_Warning_Mode := Suppress;
                  elsif Parameter = "-we" then
                     ASIS_Warning_Mode := Treat_As_Error;
                  elsif Parameter = "-wv" then
                     Strong_Version_Check := False;
                  else
                     Unknown_Parameter := True;
                  end if;

               when others =>
                  Unknown_Parameter := True;
            end case;

            if Unknown_Parameter then
               Raise_ASIS_Failed
                  (Diagnosis    => "Asis.Implementation.Initialize: "
                                 & "unknown option - "
                                 & Parameter,
                   Stat         => Parameter_Error,
                   Internal_Bug => False);
            end if;

         end Process_Option;

      begin --  Process_One_Parameter
         if Parameter (1) = '-' then
            if Parameter'Length >= 2 then
               Process_Option;
            else
               Raise_ASIS_Failed
                  (Diagnosis => "Asis.Implementation.Initialize: "
                              & "Option is missing after ""-""",
                   Stat      => Parameter_Error,
                Internal_Bug => False);
            end if;
         else
            Process_Parameter;
         end if;
      end Process_One_Parameter;

   begin  -- Process_Initialization_Parameters
      Init_Parameters := Parameter_String_To_List (Parameters);

      for I in Init_Parameters'Range loop
         Process_One_Parameter (Init_Parameters (I).all);
      end loop;

      Free_Argument_List (Init_Parameters);
   end Process_Initialization_Parameters;

   -------------
   -- Set_Off --
   -------------

   procedure Set_Off is
   begin
      Is_Initialized       := False;
      ASIS_Warning_Mode    := Normal;
      Strong_Version_Check := True;
      Generate_Bug_Box     := True;
      Keep_Going           := False;
   end Set_Off;

end A4G.A_Opt;

Add the ASIS file $i

Add the ASIS file $i


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

with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with Ada.Directories;
with Ada.Containers.Vectors;
with Ada.Strings.Fixed;
with Util.Log.Loggers;
with Util.Files;
with Util.Strings.Maps;
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);

   --  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);

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : 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 : Integer := 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 + 1 >= Loc_Name'First loop
            declare
               Bundle_Name : aliased constant String
                 := Name & Loc_Name (Loc_Name'First .. Last_Pos);
            begin
               Log.Debug ("Searching for {0}", Bundle_Name);
               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) - 1;
            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;

      procedure Process_File (Name      : in String;
                              File_Path : in String);

      Path    : constant String := To_String (Factory.Path);
      Pattern : constant String := Name & "*.properties";
      Names   : Util.Strings.String_Set.Set;
      Files   : Util.Strings.Maps.Map;
      Iter    : Util.Strings.Maps.Cursor;

      procedure Process_File (Name      : in String;
                              File_Path : in String) is
         Bundle      : constant Bundle_Manager_Access := new Manager;
         Bundle_Name : constant Name_Access
           := new String '(Name (Name'First .. Name'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 Process_File;

   begin
      Log.Info ("Reading bundle {1} in directory {0}", Path, Name);

      Found := False;
      Util.Files.Find_Files_Path (Pattern => Pattern,
                                  Path    => Path,
                                  Into    => Files);

      Factory.Lock.Write;

      begin
         Iter := Files.First;
         while Util.Strings.Maps.Has_Element (Iter) loop
            Util.Strings.Maps.Query_Element (Iter, Process_File'Access);
            Util.Strings.Maps.Next (Iter);
         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;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value)) is
      begin
         raise Program_Error with "Iterate is not implemented on Bundle";
      end Iterate;

      --  ------------------------------
      --  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   : constant 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;
         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 => Ada.Strings.Unbounded.String_Access);

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

      Factory.Lock.Write;
      loop
         declare
            Pos  : Bundle_Map.Cursor := Factory.Bundles.First;
            Name : Ada.Strings.Unbounded.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, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with Ada.Directories;
with Ada.Containers.Vectors;
with Ada.Strings.Fixed;
with Util.Log.Loggers;
with Util.Files;
with Util.Strings.Maps;
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);

   --  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);

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : 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 : Integer := 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 + 1 >= Loc_Name'First loop
            declare
               Bundle_Name : aliased constant String
                 := Name & Loc_Name (Loc_Name'First .. Last_Pos);
            begin
               Log.Debug ("Searching for {0}", Bundle_Name);
               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) - 1;
            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;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean);

      Path    : constant String := To_String (Factory.Path);
      Pattern : constant String := Name & "*.properties";
      Names   : Util.Strings.String_Set.Set;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean) is
         subtype Cursor is Bundle_Map.Cursor;

         Base_Name   : aliased constant String := Name (Name'First .. Name'Last - 11);
         Pos         : constant Cursor := Factory.Bundles.Find (Base_Name'Unchecked_Access);
         Bundle_Name : Name_Access;
         Bundle      : Bundle_Manager_Access;
      begin
         Log.Debug ("Loading file {0}", File_Path);

         if Bundle_Map.Has_Element (Pos) then
            Bundle := Bundle_Map.Element (Pos);
         else
            Bundle := new Manager;
            Bundle_Name := new String '(Base_Name);
            Factory.Bundles.Include (Key => Bundle_Name, New_Item => Bundle);
            Names.Insert (Bundle_Name);
         end if;
         Interface_P.Manager'Class (Bundle.Impl.all).Load_Properties (File_Path);
         Found := True;
         Done := False;
      end Process_File;

   begin
      Log.Info ("Reading bundle {1} in directory {0}", Path, Name);

      Found := False;
      Factory.Lock.Write;

      begin
         Util.Files.Iterate_Files_Path (Pattern => Pattern,
                                        Path    => Path,
                                        Process => Process_File'Access,
                                        Going   => Ada.Strings.Backward);

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

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value)) is
      begin
         raise Program_Error with "Iterate is not implemented on Bundle";
      end Iterate;

      --  ------------------------------
      --  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   : constant 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;
         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 => Ada.Strings.Unbounded.String_Access);

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

      Factory.Lock.Write;
      loop
         declare
            Pos  : Bundle_Map.Cursor := Factory.Bundles.First;
            Name : Ada.Strings.Unbounded.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;

Add support for resource bundle overloading - load the property files in the reverse order for the search path this allows to have in a directory a set of bundle files that override some but not all of the messages defined in the bundle files


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

--  == EL TLS Context ==
--  The <tt>TLS_Context</tt> type defines an expression context that associates itself to
--  a per-thread context information.  By declaring a variable with this type, the expression
--  context is associated with the current thread and it can be retrieved at any time by using the
--  <tt>Current</tt> function.  As soon as the variable is finalized, the current thread context
--  is updated.
--
--  The expression context may be declared as follows:
--
--     Context : EL.Contexts.TLS.TLS_Context;
--
--  And at any time, a function or procedure that needs to evaluate an expression can use it:
--
--    Expr : EL.Expressions.Expression;
--    ...
--    Value : Util.Beans.Objects.Object := Expr.Get_Value (EL.Contexts.TLS.Current.all);
--
package EL.Contexts.TLS is

   --  ------------------------------
   --  TLS Context
   --  ------------------------------
   --  Context information for expression evaluation.
   type TLS_Context is new EL.Contexts.Default.Default_Context with private;

   --  Get the current EL context associated with the current thread.
   function Current return EL.Contexts.ELContext_Access;

private

   type TLS_Context is new EL.Contexts.Default.Default_Context with record
      Previous    : EL.Contexts.ELContext_Access;
   end record;

   --  Initialize and setup a new per-thread EL context.
   overriding
   procedure Initialize (Obj : in out TLS_Context);

   --  Restore the previouse per-thread EL context.
   overriding
   procedure Finalize (Obj : in out TLS_Context);

end EL.Contexts.TLS;

Declare the TLS package for thread local context support


with Ada.Text_IO;
with Util.Serialize.IO.XML;
with Util.Streams.Texts;
procedure Serialize_Xml is
   Output : aliased Util.Streams.Texts.Print_Stream;
   Stream : Util.Serialize.IO.XML.Output_Stream;
begin
   Output.Initialize (Size => 10000);
   Stream.Initialize (Output => Output'Unchecked_Access);
   --  Stream.Start_Document;
   Stream.Start_Entity ("person");
   Stream.Write_Entity ("name", "Harry Potter");
   Stream.Write_Entity ("gender", "male");
   Stream.Write_Entity ("age", 17);
   Stream.End_Entity ("person");
   --  Stream.End_Document;
   Ada.Text_IO.Put_Line (Util.Streams.Texts.To_String (Output));
end Serialize_Xml;

Add example for XML serialization

Add example for XML serialization


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                         A 4 G . A _ S I N P U T                          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2010, 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,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, 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 AdaCore                     --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling; use Ada.Characters.Handling;
with System.WCh_Con;          use System.WCh_Con;

with Asis.Set_Get;            use Asis.Set_Get;

with Atree;                   use Atree;
with Opt;                     use Opt;
with Sinfo;                   use Sinfo;
with Sinput;                  use Sinput;
with Widechar;                use Widechar;

package body A4G.A_Sinput is

   use ASCII;
   --  Make control characters visible

   -----------------------
   -- Local subprograms --
   -----------------------

   procedure Skip_Comment (P : in out Source_Ptr);
   --  When P is set on the first '-' of a comment, this procedure resets
   --  the value of P to the first character of the group of control
   --  characters signifying the end of line containing the comment
   --  initially indicated by P.
   --
   --  This procedure should not be used for the last comment in the
   --  group of comments following a compilation unit in a compilation.

   procedure Skip_String (P : in out Source_Ptr);
   --  When P set on the first quoter of a string literal (it may be '"' or
   --  '%', this procedure resets the value of P to the first character
   --  after the literal.

   -------------------------
   -- A_Get_Column_Number --
   -------------------------

   function A_Get_Column_Number (P : Source_Ptr) return Source_Ptr is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
      S      : Source_Ptr;
      Result : Source_Ptr := 0;
   begin
      S := Line_Start (P);

      while S <= P loop

         if Is_Start_Of_Wide_Char_For_ASIS (Src, S) then
            Skip_Wide_For_ASIS (Src, S);
         else
            S := S + 1;
         end if;

         Result := Result + 1;
      end loop;

      return Result;
   end A_Get_Column_Number;

   -----------------------
   -- Comment_Beginning --
   -----------------------

   function Comment_Beginning (Line_Image : Text_Buffer) return Source_Ptr is
      Line_Image_Start : constant Source_Ptr := Line_Image'First;
      Line_Image_End   : constant Source_Ptr := Line_Image'Last;
      Scanner_Pos      : Source_Ptr;
      String_Delimiter : Standard.Character;
   begin
      Scanner_Pos := Line_Image_Start - 1;

      Scan_The_Line : while Scanner_Pos < Line_Image_End loop

         Scanner_Pos := Scanner_Pos + 1;

         case Line_Image (Scanner_Pos) is

            when '"' | '%' =>

               if not ((Scanner_Pos - 1) >= Line_Image_Start and then
                       Line_Image (Scanner_Pos - 1) = '''
                     and then
                       (Scanner_Pos + 1) <= Line_Image_End and then
                       Line_Image (Scanner_Pos + 1) = ''')
               then
                  --  We have to awoid considering character literals '"'
                  --  '%' as string brackets

                  String_Delimiter := Line_Image (Scanner_Pos);

                  Skip_String_Literal : loop
                     Scanner_Pos := Scanner_Pos + 1;

                     if Line_Image (Scanner_Pos) = String_Delimiter then

                        --  we are in a legal Ada source, therefore:
                        if Scanner_Pos < Line_Image'Last and then
                           Line_Image (Scanner_Pos + 1) = String_Delimiter
                        then
                           --  Delimiter as character inside the literal.
                           Scanner_Pos := Scanner_Pos + 1;
                        else
                           --  End of the literal.
                           exit Skip_String_Literal;
                        end if;

                     end if;

                  end loop Skip_String_Literal;

               end if;

            when '-' =>

               if    (Scanner_Pos < Line_Image'Last) and then
                     (Line_Image (Scanner_Pos + 1) = '-')
               then
                  return Scanner_Pos;
               end if;

            when others =>
               null;

         end case;

      end loop Scan_The_Line;

      --  There wasn't any comment if we reach this point.
      return No_Location;
   end Comment_Beginning;

   --------------------
   -- Exp_Name_Image --
   --------------------

   function Exp_Name_Image (Name : Node_Id) return String is
      Prefix_Node   : Node_Id;
      Selector_Node : Node_Id;
   begin
      if Nkind (Name) = N_Identifier or else
         Nkind (Name) = N_Defining_Identifier
      then
         --  ????? See E729-A04!
         return Identifier_Image (Name);
      end if;

      if Nkind (Name) = N_Defining_Program_Unit_Name then
         Prefix_Node   := Sinfo.Name (Name);
         Selector_Node := Defining_Identifier (Name);
      else
         --  Nkind (Name) = N_Expanded_Name
         Prefix_Node   := Prefix (Name);
         Selector_Node := Selector_Name (Name);
      end if;

      return   Exp_Name_Image (Prefix_Node)
             & '.'
             & Identifier_Image (Selector_Node);  --  ???
   end Exp_Name_Image;

   -------------------
   -- Get_Character --
   -------------------

   function Get_Character (P : Source_Ptr) return Character is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
   begin
      return Src (P);
   end Get_Character;

   ------------------
   -- Get_Location --
   ------------------

   function Get_Location (E : Asis.Element) return Source_Ptr is
   begin
      return Sloc (Node (E));
   end Get_Location;

   -------------------------
   -- Get_Num_Literal_End --
   -------------------------

   function Get_Num_Literal_End (P : Source_Ptr) return Source_Ptr is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
      S      : Source_Ptr;
      B_Char : Character;
   begin
      --  Src (P) is the leading digit of a numeric literal
      S := P + 1;
      loop
         if Is_Hexadecimal_Digit (Src (S)) or else Src (S) = '_' then
            S := S + 1;
         elsif Src (S) = '#' or else Src (S) = ':' then
            --  based literal: 16#E#E1 or 016#offf#
            --  J.2 (3): "The number sign characters (#) of a based_literal
            --  can be replaced by colons (:) provided that the replacement
            --  is done for both occurrences. But in case of a colon, we
            --  have to make sure that we indeed have a based literal, but not
            --  a decimal literal immediatelly followed by an assignment sign,
            --  see G119-012:
            --
            --      SPLIT_INDEX:INTEGER RANGE 1..80:=1;

            if Src (S) = ':' and then Src (S + 1) = '=' then
               S := S - 1;
               exit;
            end if;

            B_Char := Src (S);
            --  and now - looking for trailing '#' or ':':
            S := S + 1;

            while Src (S) /= B_Char loop
               S := S + 1;
            end loop;

            if Src (S + 1) = 'E' or else
               Src (S + 1) = 'e'
            then
               --  this means something like 5#1234.1234#E2
               S := S + 2;
            else
               exit;
            end if;

         elsif Src (S) = '+'
           or else
             Src (S) = '-'
         then   -- 12E+34 or 12+34?

            if Src (S - 1) = 'E'
              or else
                Src (S - 1) = 'e'
            then
               --  it is the sign of the exponent
               S := S + 1;
            else
               S := S - 1; -- to go back in the literal
               exit;
            end if;

         elsif  Src (S) = '.' then        -- 3.14 or 3..14?

            if Is_Hexadecimal_Digit (Src (S + 1)) then
               S := S + 1;
            else
               S := S - 1; -- to go back in the literal
               exit;
            end if;

         else -- for sure, we already are outside the literal
            S := S - 1; -- to go back in the literal
            exit;
         end if;
      end loop;

      return S;
   end Get_Num_Literal_End;

   --------------------
   -- Get_String_End --
   --------------------

   function Get_String_End (P : Source_Ptr) return Source_Ptr is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
      S      : Source_Ptr;
      Quote  : Character;
   begin
      --  Src (P) is the leading quotation of the non-nul string constant
      --  which can be either '"' OR '%' (J.2 (2)).
      Quote := Src (P);
      S := P + 1;
      loop

         if Src (S) = Quote and then Src (S + 1) = Quote then
            S := S + 2;
         elsif Src (S) /= Quote then

            if Is_Start_Of_Wide_Char_For_ASIS (Src, S) then
               Skip_Wide_For_ASIS (Src, S);
            else
               S := S + 1;
            end if;

         else
            --  S points to the trailing quotation of the constant
            exit;
         end if;

      end loop;

      return S;
   end Get_String_End;

   -------------------
   -- Get_Wide_Word --
   -------------------

   function Get_Wide_Word
     (P_Start : Source_Ptr;
      P_End   : Source_Ptr)
      return Wide_String
   is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P_Start);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);

      Result   : Wide_String (1 .. Positive (P_End - P_Start + 1));
      Last_Idx : Natural := 0;
      Next_Ch  : Char_Code;
      S        : Source_Ptr;
      Success  : Boolean;
      pragma Unreferenced (Success);
   begin

      S := P_Start;

      while S <= P_End loop

         Last_Idx := Last_Idx + 1;

         if Is_Start_Of_Wide_Char_For_ASIS (Src, S) then
            Scan_Wide (Src, S, Next_Ch, Success);
            Result (Last_Idx) := Wide_Character'Val (Next_Ch);

         else
            Result (Last_Idx) := To_Wide_Character (Src (S));
            S := S + 1;
         end if;

      end loop;

      return Result (1 .. Last_Idx);
   end Get_Wide_Word;

   -----------------
   -- Get_Wide_Ch --
   -----------------

   function Get_Wide_Ch (S : Source_Ptr) return Wide_Character is
      Sindex  : constant Source_File_Index := Get_Source_File_Index (S);
      Src     : constant Source_Buffer_Ptr := Source_Text (Sindex);
      S1      : Source_Ptr                  := S;
      Ch      : Char_Code;
      Result  : Wide_Character;
      Success : Boolean;
      pragma Unreferenced (Success);
   begin

      if Is_Start_Of_Wide_Char_For_ASIS (Src, S1) then
         Scan_Wide (Src, S1, Ch, Success);

         Result := Wide_Character'Val (Ch);

      else
         Result := To_Wide_Character (Src (S1));
      end if;

      return Result;

   end Get_Wide_Ch;

   ------------------
   -- Get_Word_End --
   ------------------

   function Get_Word_End
     (P       : Source_Ptr;
      In_Word : In_Word_Condition)
      return Source_Ptr
   is
      S      : Source_Ptr;
   begin
      S := P;
      while In_Word (S + 1) loop
         S := S + 1;
      end loop;
      return S;
   end Get_Word_End;

   ----------------------
   -- Identifier_Image --
   ----------------------

   function Identifier_Image (Ident : Node_Id) return String is
      Image_Start : Source_Ptr;
      Image_End   : Source_Ptr;
   begin
      Image_Start := Sloc (Ident);
      Image_End   := Get_Word_End (P       => Image_Start,
                                    In_Word => In_Identifier'Access);
      --  See E729-A04!!!
      return To_String (Get_Wide_Word (Image_Start, Image_End));
   end Identifier_Image;

   -------------------
   -- In_Identifier --
   -------------------

   function In_Identifier (P : Source_Ptr) return Boolean is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
      Char   : Character;
      Result : Boolean := True;
   begin
      Char := Src (P);

      if Char = ' '      or else
         Char = '&'      or else
         Char = '''      or else
         Char = '('      or else
         Char = ')'      or else
         Char = '*'      or else
         Char = '+'      or else
         Char = ','      or else
         Char = '-'      or else
         Char = '.'      or else
         Char = '/'      or else
         Char = ':'      or else
         Char = ';'      or else
         Char = '<'      or else
         Char = '='      or else
         Char = '>'      or else
         Char = '|'      or else
         Char = '!'      or else
         Char = ASCII.LF or else
         Char = ASCII.FF or else
         Char = ASCII.HT or else
         Char = ASCII.VT or else
         Char = ASCII.CR
      then
         Result := False;
      end if;

      return Result;

   end In_Identifier;

   -----------------
   -- Is_EOL_Char --
   -----------------

   function Is_EOL_Char (Ch : Character) return Boolean is
      Result : Boolean := False;
   begin

      Result :=
        Ch = ASCII.CR
       or else
        Ch = ASCII.LF
       or else
        Ch = ASCII.FF
       or else
        Ch = ASCII.VT;

      return Result;
   end Is_EOL_Char;

   ------------------------------------
   -- Is_Start_Of_Wide_Char_For_ASIS --
   ------------------------------------

   function Is_Start_Of_Wide_Char_For_ASIS
     (S    : Source_Buffer_Ptr;
      P    : Source_Ptr;
      C    : Source_Ptr := No_Location)
      return Boolean
   is
      Result : Boolean := False;
   begin

      if C /= No_Location and then P > C then

         --  We are in comment, so we can not have bracket encoding
         if Wide_Character_Encoding_Method /= WCEM_Brackets then
            Result := Is_Start_Of_Wide_Char (S, P);
         end if;

      else
         Result := Is_Start_Of_Wide_Char (S, P);

         if not Result then
            Result := P <= S'Last - 2
                 and then S (P) = '['
                 and then S (P + 1) = '"'
                 and then (S (P + 2) in '0' .. '9'
                               or else
                              S (P + 2) in 'a' .. 'f'
                               or else
                              S (P + 2) in 'A' .. 'F');
         end if;

      end if;

      return Result;
   end Is_Start_Of_Wide_Char_For_ASIS;

   ---------------------
   -- Next_Identifier --
   ---------------------

   function Next_Identifier (P : Source_Ptr) return Source_Ptr is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
      S      : Source_Ptr;
   begin
      S := P + 1;
      while not Is_Letter (Src (S)) loop

         if Src (S) = '-' and then Src (S + 1) = '-' then
            Skip_Comment (S);
         else
            S := S + 1;
         end if;

      end loop;

      return S;
   end Next_Identifier;

   ---------------------
   -- Number_Of_Lines --
   ---------------------

   function Number_Of_Lines (E : Asis.Element) return Integer is
      SFI : constant Source_File_Index :=
        Get_Source_File_Index (Get_Location (E));
   begin
--      return Integer (Num_Source_Lines (SFI) + Line_Offset (SFI));
      return Integer (Num_Source_Lines (SFI));
   end Number_Of_Lines;

   --------------------
   -- Operator_Image --
   --------------------

   function Operator_Image (Node : Node_Id) return String is
      S_Start : constant Source_Ptr := Sloc (Node);
      --  S_Start points to the leading character of a given operator symbol.
      Sindex  : constant Source_File_Index :=
                   Get_Source_File_Index (S_Start);
      Src     : constant Source_Buffer_Ptr := Source_Text (Sindex);
      S_End   : Source_Ptr := S_Start;
      --  should be set as pointing to the last character of a given
      --  operator symbol.
      Ch      : Character;
   begin
      Ch := Src (S_Start);

      if        Ch = 'A' or else Ch = 'a'    -- "abs" or "and"
        or else Ch = 'M' or else Ch = 'm'    -- "mod"
        or else Ch = 'N' or else Ch = 'n'    -- "not"
        or else Ch = 'R' or else Ch = 'r'    -- "rem"
        or else Ch = 'X' or else Ch = 'x'    -- "xor"
      then
         S_End := S_Start + 2;

      elsif Ch = 'O' or else Ch = 'o' then -- "or"
         S_End := S_Start + 1;

      elsif        Ch = '='             -- "="
           or else Ch = '+'             -- "+"
           or else Ch = '-'             -- "-"
           or else Ch = '&'             -- "&"
      then
         S_End := S_Start;

      elsif        Ch = '/'  -- "/=" or "/"?
           or else Ch = '<'  -- "<=" or "<"?
           or else Ch = '>'  -- ">=" or ">"?
           or else Ch = '*' -- "**" or "*"?
      then
         Ch := Src (S_Start + 1);
         if Ch = '=' or else     -- "/=", "<=" or ">="
             Ch = '*'            -- "**"
         then
            S_End := S_Start + 1;
         else
            S_End := S_Start;
            --  "<", ">", "*" or "/"
         end if;
      end if;

      return (1 => '"') & String (Src (S_Start .. S_End)) & (1 => '"');
   end Operator_Image;

   -------------------------
   -- Rightmost_Non_Blank --
   -------------------------

   function Rightmost_Non_Blank (P : Source_Ptr) return Source_Ptr is
      S : Source_Ptr := P;
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
   begin
      loop
         if Src (S) = '-' and then Src (S + 1) = '-' then
            Skip_Comment (S);
         elsif Is_Graphic (Src (S)) and then Src (S) /= ' ' then
            exit;
         else
            S := S + 1;
         end if;
      end loop;
      return S;
   end Rightmost_Non_Blank;

   ------------------------------
   -- Search_Beginning_Of_Word --
   ------------------------------

   function Search_Beginning_Of_Word (S : Source_Ptr) return Source_Ptr is
      SFI : constant Source_File_Index := Get_Source_File_Index (S);
      Src : constant Source_Buffer_Ptr := Source_Text (SFI);
      S_P : Source_Ptr;

   begin
      S_P := S;
      while S_P >= Source_First (SFI)
        and then (Src (S_P) in 'A' .. 'Z' or else
                  Src (S_P) in 'a' .. 'z' or else
                  Src (S_P) in '0' .. '9' or else
                  Src (S_P) = '_')
      loop
         S_P := S_P - 1;
      end loop;

      return S_P + 1;
   end Search_Beginning_Of_Word;

   ------------------------
   -- Search_End_Of_Word --
   ------------------------

   function Search_End_Of_Word (S : Source_Ptr) return Source_Ptr is
      S_P  : Source_Ptr                 := S;
      SFI  : constant Source_File_Index := Get_Source_File_Index (S);
      Src  : constant Source_Buffer_Ptr := Source_Text (SFI);
      Char : Character;
   begin

      Char := Src (S_P);

      while not (Char = ' '      or else
                 Char = '&'      or else
                 Char = '''      or else
                 Char = '('      or else
                 Char = ')'      or else
                 Char = '*'      or else
                 Char = '+'      or else
                 Char = ','      or else
                 Char = '-'      or else
                 Char = '.'      or else
                 Char = '/'      or else
                 Char = ':'      or else
                 Char = ';'      or else
                 Char = '<'      or else
                 Char = '='      or else
                 Char = '>'      or else
                 Char = '|'      or else
                 Char = '!'      or else
                 Char = ASCII.LF or else
                 Char = ASCII.FF or else
                 Char = ASCII.HT or else
                 Char = ASCII.VT or else
                 Char = ASCII.CR)
      loop
         S_P := S_P + 1;
         Char := Src (S_P);
      end loop;

      S_P := S_P - 1;

      return S_P;

   end Search_End_Of_Word;

   -----------------------------
   -- Search_Left_Parenthesis --
   -----------------------------

   function Search_Left_Parenthesis (S : Source_Ptr) return Source_Ptr is
      S_P : Source_Ptr                 := S - 1;
      SFI : constant Source_File_Index := Get_Source_File_Index (S);
      Src : constant Source_Buffer_Ptr := Source_Text (SFI);
   begin
      loop
         case Src (S_P) is
            when  '(' =>
               return  S_P;
            when  CR | LF   =>
               declare
                  TempS : Source_Ptr := Line_Start (S_P);
               begin
                  while (Src (TempS) /= '-' or else
                          Src (TempS + 1) /= '-')
                     and then
                          TempS < S_P
                  loop
                     TempS := TempS + 1;
                  end loop;
                  S_P := TempS - 1;
               end;

            when others =>
               S_P := S_P - 1;
         end case;
      end loop;
   end Search_Left_Parenthesis;

   ----------------------
   -- Search_Next_Word --
   ----------------------

   function Search_Next_Word (S : Source_Ptr) return Source_Ptr is
      S_P : Source_Ptr                 := S + 1;
      SFI : constant Source_File_Index := Get_Source_File_Index (S);
      Src : constant Source_Buffer_Ptr := Source_Text (SFI);
   begin
      loop
         case Src (S_P) is
            when  ' ' | HT | CR | LF =>
               S_P := S_P + 1;
            when  '-' =>
               if Src (S_P + 1) = '-' then
                  Skip_Comment (S_P);
               else
                  return S_P;
               end if;
            when others  =>
               return S_P;
         end case;
      end loop;
   end Search_Next_Word;

   ----------------------
   -- Search_Prev_Word --
   ----------------------

   function Search_Prev_Word (S : Source_Ptr) return Source_Ptr is
      S_P : Source_Ptr                 := S - 1;
      SFI : constant Source_File_Index := Get_Source_File_Index (S);
      Src : constant Source_Buffer_Ptr := Source_Text (SFI);
   begin
      loop
         case Src (S_P) is
            when  ' ' | HT  =>
               S_P := S_P - 1;
            when  CR | LF   =>
               declare
                  TempS : Source_Ptr := Line_Start (S_P);
               begin
                  while (Src (TempS) /= '-' or else
                          Src (TempS + 1) /= '-')
                       and then
                          TempS < S_P
                  loop
                     TempS := TempS + 1;
                  end loop;
                  S_P := TempS - 1;
               end;
            when others  =>
               return S_P;
         end case;
      end loop;
   end Search_Prev_Word;

   ----------------------------
   -- Search_Prev_Word_Start --
   ----------------------------

   function Search_Prev_Word_Start (S : Source_Ptr) return Source_Ptr is
   begin
      return Search_Beginning_Of_Word (Search_Prev_Word (S));
   end Search_Prev_Word_Start;

   -----------------------------
   -- Search_Rightmost_Symbol --
   -----------------------------

   function Search_Rightmost_Symbol
     (P    : Source_Ptr;
      Char : Character := ';')
      return Source_Ptr
   is
      S      : Source_Ptr := P;
      --  the location to be returned, the search is started from P
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
   begin
      while Src (S) /= Char loop

         if Src (S) = '-' and then Src (S + 1) = '-' then
            Skip_Comment (S);

         elsif (Src (S) = '"' or else Src (S) = '%')
             and then
               not (Src (S - 1) = ''' and then Src (S + 1) = ''')
         then
            Skip_String (S);

         else
            S := S + 1;
         end if;

      end loop;

      return S;
   end Search_Rightmost_Symbol;

   -----------------
   -- Skip_String --
   -----------------

   procedure Skip_String (P : in out Source_Ptr)  is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
      Quoter : constant Character         := Src (P);
   begin
      --  we are in the beginning of a legal string literal in a legal
      --  Ada program. So we do not have to be careful with all
      --  the checks:
      while not (Src (P) = Quoter and then Src (P + 1) /= Quoter) loop
         P := P + 1;
      end loop;
      P := P + 1;
   end Skip_String;

   ------------------
   -- Skip_Comment --
   ------------------

   procedure Skip_Comment (P : in out Source_Ptr) is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
   begin
      if Src (P) = '-' and then Src (P + 1) = '-' then
         P := P + 2;
         while not (Src (P) = VT or else
                    Src (P) = CR or else
                    Src (P) = LF or else
                    Src (P) = FF)
         loop
            P := P + 1;
         end loop;
      end if;
   end Skip_Comment;

   ------------------------
   -- Skip_Wide_For_ASIS --
   ------------------------

   procedure Skip_Wide_For_ASIS
     (S : Source_Buffer_Ptr;
      P : in out Source_Ptr)
   is
      Old_P                              : constant Source_Ptr := P;
      Old_Wide_Character_Encoding_Method : WC_Encoding_Method;
   begin
      Skip_Wide (S, P);

      if P = Old_P + 1 then
         --  We have a bracket encoding, but the encoding method is different
         --  from WCEM_Brackets
         P := P - 1;
         Old_Wide_Character_Encoding_Method := Wide_Character_Encoding_Method;
         Wide_Character_Encoding_Method := WCEM_Brackets;
         Skip_Wide (S, P);
         Wide_Character_Encoding_Method := Old_Wide_Character_Encoding_Method;

      end if;

   end Skip_Wide_For_ASIS;

   ------------------------------
   -- Source_Locations_To_Span --
   ------------------------------

   function Source_Locations_To_Span
     (Span_Beg : Source_Ptr;
      Span_End : Source_Ptr)
      return Span
   is
      Sp : Span;
   begin
      Sp.First_Line   := Line_Number (Get_Physical_Line_Number   (Span_Beg));
      Sp.First_Column := Character_Position (A_Get_Column_Number (Span_Beg));
      Sp.Last_Line    := Line_Number (Get_Physical_Line_Number   (Span_End));
      Sp.Last_Column  := Character_Position (A_Get_Column_Number (Span_End));

      return Sp;
   end Source_Locations_To_Span;

   -----------------------
   -- Wide_String_Image --
   -----------------------

   function Wide_String_Image (Node : Node_Id) return Wide_String is
      S_Start : constant Source_Ptr := Sloc (Node);
      --  S_Start points to the leading quote of a given string literal.
      Sindex  : constant Source_File_Index :=
                   Get_Source_File_Index (S_Start);
      Src     : constant Source_Buffer_Ptr := Source_Text (Sindex);
      S_End   : Source_Ptr := S_Start + 1;
      --  should be set as pointing to the last character of a
      --  string literal; empty and  non-empty literals are processed
      --  in the same way - we simply take a literal as it is from the
      --  Source Buffer
      Quote  : constant Character := Src (S_Start);
      --  Quoter may be '"' or '%'!
   begin
      loop
         if Src (S_End)     = Quote and then
            Src (S_End + 1) = Quote
         then
            --  doubled string quote as an element of a given string
            S_End := S_End + 2;
         elsif Src (S_End)  /= Quote then
            --  "usial" string element
            S_End := S_End + 1;
         else
            --  S_End points to the trailing quote of a given string
            exit;
         end if;
      end loop;

      declare
         Result   : Wide_String (1 .. Positive (S_End - S_Start + 1));
         Last_Idx : Natural := 0;
         Next_Ch  : Char_Code;
         S        : Source_Ptr;
         Success  : Boolean;
         pragma Unreferenced (Success);
      begin
         S := S_Start;

         while S <= S_End loop

            Last_Idx := Last_Idx + 1;

            if Is_Start_Of_Wide_Char_For_ASIS (Src, S) then
               Scan_Wide (Src, S, Next_Ch, Success);
               Result (Last_Idx) := Wide_Character'Val (Next_Ch);

            else
               Result (Last_Idx) := To_Wide_Character (Src (S));
               S := S + 1;
            end if;

         end loop;

         return Result (1 .. Last_Idx);
      end;

   end Wide_String_Image;

end A4G.A_Sinput;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--       A S I S . D A T A _ D E C O M P O S I T I O N . S E T _ G E T      --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2009, 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,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, 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  AdaCore                   --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

with System; use System;

with Asis.Declarations;              use Asis.Declarations;
with Asis.Definitions;               use Asis.Definitions;
with Asis.Elements;                  use Asis.Elements;
with Asis.Extensions;                use Asis.Extensions;
with Asis.Iterator;                  use Asis.Iterator;

with Asis.Set_Get;                   use Asis.Set_Get;

with Asis.Data_Decomposition.Aux;    use Asis.Data_Decomposition.Aux;

with A4G.Contt;                      use A4G.Contt;

with Atree;                          use Atree;
with Sinfo;                          use Sinfo;
with Einfo;                          use Einfo;
with Nlists;                         use Nlists;
with Uintp;                          use Uintp;

package body Asis.Data_Decomposition.Set_Get is

   -----------------------
   -- Local subprograms --
   -----------------------

   procedure Set_Derived_Type_Components (E : Asis.Element);
   --  Provided that E is a derived type definition, this procedure sets in
   --  Asis_Element_Table the defining identifiers of the components of the
   --  corresponding type. (For inherited components it sets the corresponding
   --  implicit names)

   --------------------
   -- Component_Name --
   --------------------

   function Component_Name (Comp : RC) return Asis.Defining_Name is
   begin
      return Comp.Component_Name;
   end Component_Name;

   ---------------
   -- Dimension --
   ---------------

   function Dimension (Comp : AC) return ASIS_Natural
   is
   begin
      return Comp.Dimension;
   end  Dimension;

   ---------------------------
   -- Get_Array_Type_Entity --
   ---------------------------

   function Get_Array_Type_Entity (Comp : AC) return  Entity_Id is
      Result : Entity_Id;
      pragma Warnings (Off, Result);
   begin
      --  ???!!! This is a trick needed to reset the right tree!
      --  ???!!! Should be replaced by a proper tree handling for
      --  ???!!! array components

      Result := Node (Comp.Parent_Array_Type);

      Result := Comp.Array_Type_Entity;

      return Result;
   end Get_Array_Type_Entity;

   ---------------------
   -- Get_Comp_Entity --
   ---------------------

   function Get_Comp_Entity (Comp : RC) return Entity_Id is
   begin
      return R_Node (Component_Name (Comp));
   end Get_Comp_Entity;

   -----------------------
   -- Get_Record_Entity --
   -----------------------

   function Get_Record_Entity (Comp : RC) return Entity_Id is
      Result : Entity_Id;
   begin
      Result := R_Node (Parent_Record_Type (Comp));

      while Nkind (Result) /= N_Full_Type_Declaration loop
         Result := Parent (Result);
      end loop;

      Result := Defining_Identifier (Result);

      return Result;

   end Get_Record_Entity;

   ---------------------
   -- Get_Type_Entity --
   ---------------------

   function Get_Type_Entity    (Comp : RC) return Node_Id is
      Result : Node_Id;
   begin
      Result := Etype (R_Node (Component_Name (Comp)));

      if Ekind (Result) = E_Private_Type then
         Result := Full_View (Result);
      end if;

      return Result;
   end Get_Type_Entity;

   -------------------
   -- Is_Array_Comp --
   -------------------

   function Is_Array_Comp (Comp : AC) return Boolean is
   begin
      return Comp.Is_Array_Comp;
   end Is_Array_Comp;

   function Is_Array_Comp (Comp : RC) return Boolean is
   begin
      return Comp.Is_Array_Comp;
   end Is_Array_Comp;

   --------------------
   -- Is_Record_Comp --
   --------------------

   function Is_Record_Comp (Comp : AC) return Boolean is
   begin
      return Comp.Is_Record_Comp;
   end Is_Record_Comp;

   function Is_Record_Comp (Comp : RC) return Boolean is
   begin
      return Comp.Is_Record_Comp;
   end Is_Record_Comp;

   -----------------------
   -- Parent_Array_Type --
   -----------------------

   function Parent_Array_Type (Comp : AC) return Asis.Declaration is
   begin
      return Comp.Parent_Array_Type;
   end Parent_Array_Type;

   ---------------------
   -- Parent_Discrims --
   ---------------------

   function Parent_Discrims (Comp : AC) return Discrim_List is
   begin
      if Comp.Parent_Discrims = null then
         return Null_Discrims;
      else
         return Comp.Parent_Discrims.all;
      end if;
   end Parent_Discrims;

   function Parent_Discrims (Comp : RC) return Discrim_List is
   begin
      if Comp.Parent_Discrims = null then
         return Null_Discrims;
      else
         return Comp.Parent_Discrims.all;
      end if;
   end Parent_Discrims;

   ------------------------
   -- Parent_Record_Type --
   ------------------------

   function Parent_Record_Type (Comp : RC) return Asis.Declaration is
   begin
      return Comp.Parent_Record_Type;
   end Parent_Record_Type;

   -------------------------
   -- Set_Array_Componnet --
   -------------------------

   function Set_Array_Componnet
     (Array_Type_Definition      : Element;
      Enclosing_Record_Component : Record_Component := Nil_Record_Component;
      Parent_Indication          : Element          := Nil_Element;
      Parent_Discriminants       : Discrim_List     := Null_Discrims;
      Parent_First_Bit_Offset    : ASIS_Natural     := 0;
      Dynamic_Array              : Boolean          := False)
      return Array_Component
   is
      Comp_Node        : Node_Id;
      Comp_Type_Entity : Node_Id;
      Result           : Array_Component := Nil_Array_Component;

      Enclosing_Array_Type : Element;
      Array_Entity     : Entity_Id := Empty;
      --  This should be a type entity defining the enclosed
      --  array type. This may be an implicit type created by the compiler,
      --  but the point is that in should contain real ranges for
      --  this component

      Dim       : Asis.ASIS_Positive;
      Tmp_Node  : Node_Id;
      Comp_Size : ASIS_Natural;
   begin
      Result.Parent_Array_Type     := Array_Type_Definition;
      Result.Parent_Component_Name :=
         Component_Name (Enclosing_Record_Component);

      Comp_Node        := Node (Array_Type_Definition);
      Comp_Type_Entity := Defining_Identifier (Parent (Comp_Node));

      if Ekind (Comp_Type_Entity) in Object_Kind then
         --  Array definition as a part of an object definition, here we have
         --  an anonymous array type
         Comp_Type_Entity := Etype (Etype (Comp_Type_Entity));
         Array_Entity     := Comp_Type_Entity;
      end if;

      Comp_Type_Entity := Component_Type (Comp_Type_Entity);

      if Ekind (Comp_Type_Entity) = E_Private_Type then
         Comp_Type_Entity := Full_View (Comp_Type_Entity);
      end if;

      Result.Is_Record_Comp := Is_Record_Type (Comp_Type_Entity);
      Result.Is_Array_Comp  := Is_Array_Type  (Comp_Type_Entity);

      if not Is_Nil (Enclosing_Record_Component) then
         Array_Entity := R_Node (Enclosing_Record_Component.Component_Name);
         Array_Entity := Etype (Array_Entity);

      elsif not Is_Nil (Parent_Indication) then
         Enclosing_Array_Type := Enclosing_Element (Parent_Indication);

         Enclosing_Array_Type := Enclosing_Element (Enclosing_Array_Type);
         Enclosing_Array_Type := Enclosing_Element (Enclosing_Array_Type);

         Array_Entity := Defining_Identifier (R_Node (Enclosing_Array_Type));
         Array_Entity := Component_Type (Array_Entity);

      elsif No (Array_Entity) then
         Enclosing_Array_Type := Enclosing_Element (Array_Type_Definition);
         Array_Entity := Defining_Identifier (R_Node (Enclosing_Array_Type));
      end if;

      if Ekind (Array_Entity) = E_Private_Type then
         Array_Entity := Full_View (Array_Entity);
      end if;

      Result.Array_Type_Entity := Array_Entity;

      --  Computing dimentions and lengths:

      Tmp_Node := First_Index (Array_Entity);

      Dim := ASIS_Positive (List_Length (List_Containing (Tmp_Node)));

      Result.Dimension := Dim;

      Result.Length := (others => 0);

      for I in 1 .. Dim loop

         if Dynamic_Array then
            Result.Length (I) := 0;
         else
            Result.Length (I) := Get_Length (Typ   => Array_Entity,
                                             Sub   => I,
                                             Discs => Parent_Discriminants);
         end if;

      end loop;

      Comp_Size := ASIS_Natural (UI_To_Int (
         Get_Component_Size (Array_Entity)));

      Result.Position := Parent_First_Bit_Offset / Storage_Unit;

      Result.First_Bit := Parent_First_Bit_Offset mod Storage_Unit;

      Result.Last_Bit  := Result.First_Bit + Comp_Size - 1;

      Result.Size      := Comp_Size;

      Set_Parent_Discrims (Result, Parent_Discriminants);

      Result.Parent_Context := Get_Current_Cont;
      Result.Obtained       := A_OS_Time;

      return Result;

   end Set_Array_Componnet;

   ------------------------------
   -- Set_All_Named_Components --
   ------------------------------

   procedure Set_All_Named_Components (E : Element) is
      Discr_Part  : Element;
   begin
      if Asis.Elements.Type_Kind (E) = A_Derived_Type_Definition then
         Set_Derived_Type_Components (E);
      else
         Discr_Part := Discriminant_Part (Enclosing_Element (E));
         Set_Named_Components (Discr_Part, New_List);
         Set_Named_Components (E, Append);
      end if;

   end Set_All_Named_Components;

   ---------------------------------
   -- Set_Derived_Type_Components --
   ---------------------------------

   procedure Set_Derived_Type_Components (E : Asis.Element) is
      Discr_Part : constant Asis.Element :=
                     Discriminant_Part (Enclosing_Element (E));
      Impl_Comps : constant Asis.Element_List :=
                     Implicit_Inherited_Declarations (E);
   begin

      Set_Named_Components (Discr_Part, New_List);

      for J in Impl_Comps'Range loop
         Asis_Element_Table.Append (Names (Impl_Comps (J)) (1));
      end loop;

   end Set_Derived_Type_Components;

   --------------------------
   -- Set_Named_Components --
   --------------------------

   procedure Set_Named_Components (E : Element; List_Kind : List_Kinds) is

      Control  : Traverse_Control := Continue;
      State    : No_State := Not_Used;

      procedure Set_Def_Name
        (Element : Asis.Element;
         Control : in out Traverse_Control;
         State   : in out No_State);
      --  If Element is of A_Defining_Identifier kind, this procedure stores
      --  it in the Asis Element Table. Used as Pre-Operation

      procedure Set_Def_Name
        (Element : Asis.Element;
         Control : in out Traverse_Control;
         State   : in out No_State)
      is
      begin
         pragma Unreferenced (Control);
         pragma Unreferenced (State);

         if Int_Kind (Element) /= A_Defining_Identifier then
            return;
         end if;

         Asis_Element_Table.Append (Element);
      end Set_Def_Name;

      procedure Create_Name_List is new Traverse_Element (
         State_Information => No_State,
         Pre_Operation     => Set_Def_Name,
         Post_Operation    => No_Op);

   begin

      if List_Kind = New_List then
         Asis_Element_Table.Init;
      end if;

      if Is_Nil (E) then
         return;
      end if;

      Create_Name_List
        (Element => E,
         Control => Control,
         State   => State);

   end Set_Named_Components;

   -------------------------
   -- Set_Parent_Discrims --
   -------------------------

   procedure Set_Parent_Discrims (Comp : in out AC; Discs : Discrim_List) is
   begin

      if Discs = Null_Discrims then
         Comp.Parent_Discrims := null;
      else
         Comp.Parent_Discrims := new Discrim_List'(Discs);
      end if;

   end Set_Parent_Discrims;

   ----------------------------
   -- Set_Record_Type_Entity --
   ----------------------------

   procedure Set_Record_Type_Entity (AC : Array_Component) is
   begin
      Record_Type_Entity := Get_Array_Type_Entity (AC);
      Record_Type_Entity := Component_Type (Record_Type_Entity);
   end Set_Record_Type_Entity;

   procedure Set_Record_Type_Entity (RC : Record_Component) is
   begin
      Record_Type_Entity := R_Node (Component_Name (RC));
      Record_Type_Entity := Etype (Record_Type_Entity);
   end Set_Record_Type_Entity;

   procedure Set_Record_Type_Entity is
   begin
      Record_Type_Entity :=
         Defining_Identifier (Parent (R_Node (Parent_Type_Definition)));
   end Set_Record_Type_Entity;

   --------------------------------
   -- Set_Parent_Type_Definition --
   --------------------------------

   procedure Set_Parent_Type_Definition (E : Element) is
   begin
      Parent_Type_Definition := E;
   end Set_Parent_Type_Definition;

   --------------------------------------
   -- Set_Record_Components_From_Names --
   --------------------------------------

   procedure Set_Record_Components_From_Names
     (Parent_First_Bit : ASIS_Natural  := 0;
      Data_Stream      : Portable_Data := Nil_Portable_Data;
      Discriminants    : Boolean       := False)
   is
      New_Comp         : Asis.List_Index;
      Component_Name   : Element;
      Comp_Entity      : Node_Id;

      Discs : constant Discrim_List :=
         Build_Discrim_List_If_Data_Presented
           (Rec          => Record_Type_Entity,
            Data         => Data_Stream,
            Ignore_Discs => Discriminants);

      Comp_Type_Entity : Node_Id;

      Comp_First_Bit_Offset : ASIS_Natural;
      Comp_Position         : ASIS_Natural;
      Comp_Size             : ASIS_Natural;
   begin
      Record_Component_Table.Init;

      for I in 1 .. Asis_Element_Table.Last loop
         Component_Name := Def_N_Table (I);
         Comp_Entity    := Node (Component_Name);

         if Discs = Null_Discrims or else
            Component_Present (Comp_Entity, Discs)
         then
            Record_Component_Table.Increment_Last;
            New_Comp       := Record_Component_Table.Last;
            RC_Table (New_Comp).Parent_Record_Type := Parent_Type_Definition;
            RC_Table (New_Comp).Component_Name     := Component_Name;

            Comp_Type_Entity := Etype (Comp_Entity);

            if Ekind (Comp_Type_Entity) = E_Private_Type then
               Comp_Type_Entity := Full_View (Comp_Type_Entity);
            end if;

            RC_Table (New_Comp).Is_Record_Comp :=
               Is_Record_Type (Comp_Type_Entity);

            RC_Table (New_Comp).Is_Array_Comp  :=
               Is_Array_Type  (Comp_Type_Entity);

            if Discs = Null_Discrims then
               RC_Table (New_Comp).Parent_Discrims := null;
            else
               RC_Table (New_Comp).Parent_Discrims  :=
                  new Discrim_List'(Discs);
            end if;

            Comp_First_Bit_Offset := Parent_First_Bit +
               ASIS_Natural (UI_To_Int (
                  Get_Component_Bit_Offset (Comp_Entity, Discs)));

            Comp_Position := Comp_First_Bit_Offset / Storage_Unit;

            Comp_Size := ASIS_Natural (UI_To_Int
                            (Get_Esize (Comp_Entity, Discs)));

            RC_Table (New_Comp).Position := Comp_Position;

            RC_Table (New_Comp).First_Bit :=
               Comp_First_Bit_Offset mod Storage_Unit;

            RC_Table (New_Comp).Last_Bit  :=
               RC_Table (New_Comp).First_Bit + Comp_Size - 1;

            RC_Table (New_Comp).Size      := Comp_Size;

            RC_Table (New_Comp).Parent_Context := Get_Current_Cont;
            RC_Table (New_Comp).Obtained       := A_OS_Time;

         end if;

      end loop;
   end Set_Record_Components_From_Names;

end Asis.Data_Decomposition.Set_Get;

Add the ASIS file $i

Add the ASIS file $i