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

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Ada.Strings.Unbounded.Unbounded_String;

   function "+" (S : String) return Value renames To_Unbounded_String;

   function "-" (S : Value) return String renames To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled with private;
   type Manager_Access is access Manager'Class;

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

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

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

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

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

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

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Insert the specified property in the list.
   procedure Insert (Self : in out Manager'Class;
                     Name : in String;
                     Item : in String);

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

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

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

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value);

   type Name_Array is array (Natural range <>) of Value;

   --  Return the name of the properties defined in the manager.
   function Get_Names (Self : in Manager) return Name_Array;

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.
   procedure Load_Properties (Self : in out Manager'Class;
                              File : in Ada.Text_IO.File_Type);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self : in out Manager'Class;
                              Path : in String);

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "");

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract tagged limited record
         Count : Natural := 0;
      end record;
      type Manager_Access is access all Manager'Class;

      type Manager_Factory is access function return Manager_Access;

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

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

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

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

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

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

      procedure Delete (Self : in Manager; Obj : in out Manager_Access)
        is abstract;

      function Get_Names (Self : in Manager) return Name_Array is abstract;

   end Interface_P;

   procedure Set_Property_Implementation (Self : in out Manager;
                                          Impl : in Interface_P.Manager_Access);

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   procedure Adjust   (Object : in out Manager);
   procedure Finalize (Object : in out Manager);

end Util.Properties;

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

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Ada.Strings.Unbounded.Unbounded_String;

   function "+" (S : String) return Value renames To_Unbounded_String;

   function "-" (S : Value) return String renames To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled with private;
   type Manager_Access is access all Manager'Class;

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

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

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

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

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

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

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Insert the specified property in the list.
   procedure Insert (Self : in out Manager'Class;
                     Name : in String;
                     Item : in String);

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

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

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

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value);

   type Name_Array is array (Natural range <>) of Value;

   --  Return the name of the properties defined in the manager.
   function Get_Names (Self : in Manager) return Name_Array;

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.
   procedure Load_Properties (Self : in out Manager'Class;
                              File : in Ada.Text_IO.File_Type);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self : in out Manager'Class;
                              Path : in String);

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "");

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract tagged limited record
         Count : Natural := 0;
      end record;
      type Manager_Access is access all Manager'Class;

      type Manager_Factory is access function return Manager_Access;

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

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

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

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

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

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

      procedure Delete (Self : in Manager; Obj : in out Manager_Access)
        is abstract;

      function Get_Names (Self : in Manager) return Name_Array is abstract;

   end Interface_P;

   procedure Set_Property_Implementation (Self : in out Manager;
                                          Impl : in Interface_P.Manager_Access);

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   procedure Adjust   (Object : in out Manager);
   procedure Finalize (Object : in out Manager);

end Util.Properties;

Update the Manager_Access to be class-wide access type


-----------------------------------------------------------------------
--  Util.Files -- Various File Utility Packages
--  Copyright (C) 2001, 2002, 2003, 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.Directories;
with Ada.Strings.Fixed;
with Ada.Streams;
with Ada.Streams.Stream_IO;
with Ada.Text_IO;
package body Util.Files is

   --  ------------------------------
   --  Read a complete file into a string.
   --  The Max_Size parameter indicates the maximum size that is read.
   --  ------------------------------
   procedure Read_File (Path     : in String;
                        Into     : out Unbounded_String;
                        Max_Size : in Natural := 0) is
      use Ada.Streams;
      use Ada.Streams.Stream_IO;

      F      : File_Type;
      Buffer : Stream_Element_Array (1 .. 10_000);
      Pos    : Positive_Count := 1;
      Last   : Stream_Element_Offset;
      Space  : Natural;
   begin
      if Max_Size = 0 then
         Space := Natural'Last;
      else
         Space := Max_Size;
      end if;
      Open (Name => Path, File => F, Mode => In_File);
      loop
         Read (File => F, Item => Buffer, From => Pos, Last => Last);
         if Natural (Last) > Space then
            Last := Stream_Element_Offset (Space);
         end if;
         for I in 1 .. Last loop
            Append (Into, Character'Val (Buffer (I)));
         end loop;
         exit when Last < Buffer'Length;
         Pos := Pos + Positive_Count (Last);
      end loop;
      Close (F);

   exception
      when others =>
         if Is_Open (F) then
            Close (F);
         end if;
         raise;
   end Read_File;

   --  ------------------------------
   --  Read the file with the given path, one line at a time and execute the Process
   --  procedure with each line as argument.
   --  ------------------------------
   procedure Read_File (Path     : in String;
                        Process  : not null access procedure (Line : in String)) is
      File : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Open (File => File,
                        Mode => Ada.Text_IO.In_File,
                        Name => Path);
      while not Ada.Text_IO.End_Of_File (File) loop
         Process (Ada.Text_IO.Get_Line (File));
      end loop;
      Ada.Text_IO.Close (File);
   end Read_File;

   --  ------------------------------
   --  Save the string into a file creating the file if necessary
   --  ------------------------------
   procedure Write_File (Path    : in String;
                         Content : in String) is
      use Ada.Streams;
      use Ada.Streams.Stream_IO;
      use Ada.Directories;

      F : File_Type;
      Buffer : Stream_Element_Array (Stream_Element_Offset (Content'First)
                                     .. Stream_Element_Offset (Content'Last));

      Dir : constant String := Containing_Directory (Path);
   begin
      if not Exists (Dir) then
         Create_Path (Dir);
      end if;
      Create (File => F, Name => Path);
      for I in Content'Range loop
         Buffer (Stream_Element_Offset (I))
           := Stream_Element (Character'Pos (Content (I)));
      end loop;
      Write (F, Buffer);
      Close (F);

   exception
      when others =>
         if Is_Open (F) then
            Close (F);
         end if;
         raise;
   end Write_File;

   --  ------------------------------
   --  Save the string into a file creating the file if necessary
   --  ------------------------------
   procedure Write_File (Path    : in String;
                         Content : in Unbounded_String) is
   begin
      Write_File (Path, Ada.Strings.Unbounded.To_String (Content));
   end Write_File;

   --  ------------------------------
   --  Iterate over the search directories defined in Paths and execute
   --  Process with each directory until it returns True in Done
   --  or the last search directory is found.  Each search directory
   --  is separated by ';' (yes, even on Unix).  When Going is set to Backward, the
   --  directories are searched in reverse order.
   --  ------------------------------
   procedure Iterate_Path (Path     : in String;
                           Process  : not null access procedure (Dir  : in String;
                                                                 Done : out Boolean);
                           Going    : in Direction := Ada.Strings.Forward) is
      use Ada.Directories;
      use Ada.Strings;
      use Ada.Strings.Fixed;

      Sep_Pos : Natural;
      Pos     : Natural;
      Last    : constant Natural := Path'Last;
   begin
      case Going is
         when Forward =>
            Pos := Path'First;
            while Pos <= Last loop
               Sep_Pos := Index (Path, ";", Pos);
               if Sep_Pos = 0 then
                  Sep_Pos := Last;
               else
                  Sep_Pos := Sep_Pos - 1;
               end if;
               declare
                  Dir  : constant String := Path (Pos .. Sep_Pos);
                  Done : Boolean;
               begin
                  Process (Dir => Dir, Done => Done);
                  exit when Done;
               end;
               Pos := Sep_Pos + 2;
            end loop;

         when Backward =>
            Pos := Path'Last;
            while Pos >= Path'First loop
               Sep_Pos := Index (Path, ";", Pos, Backward);
               if Sep_Pos = 0 then
                  Sep_Pos := Path'First;
               else
                  Sep_Pos := Sep_Pos + 1;
               end if;
               declare
                  Dir  : constant String := Path (Sep_Pos .. Pos);
                  Done : Boolean;
               begin
                  Process (Dir => Dir, Done => Done);
                  exit when Done or Sep_Pos = Path'First;
               end;
               Pos := Sep_Pos - 2;
            end loop;

      end case;
   end Iterate_Path;

   --  ------------------------------
   --  Find the file in one of the search directories.  Each search directory
   --  is separated by ';' (yes, even on Unix).
   --  Returns the path to be used for reading the file.
   --  ------------------------------
   function Find_File_Path (Name  : String;
                            Paths : String) return String is
      use Ada.Directories;
      use Ada.Strings.Fixed;

      Sep_Pos : Natural;
      Pos     : Positive := Paths'First;
      Last    : constant Natural := Paths'Last;

   begin
      while Pos <= Last loop
         Sep_Pos := Index (Paths, ";", Pos);
         if Sep_Pos = 0 then
            Sep_Pos := Last;
         else
            Sep_Pos := Sep_Pos - 1;
         end if;
         declare
            Path : constant String := Util.Files.Compose (Paths (Pos .. Sep_Pos), Name);
         begin
            if Exists (Path) and then Kind (Path) = Ordinary_File then
               return Path;
            end if;
         exception
            when Name_Error =>
               null;
         end;
         Pos := Sep_Pos + 2;
      end loop;
      return Name;
   end Find_File_Path;

   --  ------------------------------
   --  Iterate over the search directories defined in Path and search
   --  for files matching the pattern defined by Pattern.  For each file,
   --  execute Process with the file basename and the full file path.
   --  Stop iterating when the Process procedure returns True.
   --  Each search directory is separated by ';'.  When Going is set to Backward, the
   --  directories are searched in reverse order.
   --  ------------------------------
   procedure Iterate_Files_Path (Pattern  : in String;
                                 Path     : in String;
                                 Process  : not null access procedure (Name : in String;
                                                                       File : in String;
                                                                       Done : out Boolean);
                                 Going    : in Direction := Ada.Strings.Forward) is

      procedure Find_Files (Dir  : in String;
                            Done : out Boolean);

      --  ------------------------------
      --  Find the files matching the pattern in Dir.
      --  ------------------------------
      procedure Find_Files (Dir  : in String;
                            Done : out Boolean) is
         use Ada.Directories;

         Filter  : constant Filter_Type := (Ordinary_File => True, others => False);
         Ent     : Directory_Entry_Type;
         Search  : Search_Type;
      begin
         Done := False;
         Start_Search (Search, Directory => Dir,
                       Pattern => Pattern, Filter => Filter);
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Name      : constant String := Simple_Name (Ent);
               File_Path : constant String := Full_Name (Ent);
            begin
               Process (Name, File_Path, Done);
               exit when Done;
            end;
         end loop;
      end Find_Files;

   begin
      Iterate_Path (Path => Path, Process => Find_Files'Access, Going => Going);
   end Iterate_Files_Path;

   --  ------------------------------
   --  Find the files which match the pattern in the directories specified in the
   --  search path Path.  Each search directory is separated by ';'.
   --  File names are added to the string set in Into.
   --  ------------------------------
   procedure Find_Files_Path (Pattern : in String;
                              Path    : in String;
                              Into    : in out Util.Strings.Maps.Map) is

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

      --  ------------------------------
      --  Find the files matching the pattern in Dir.
      --  ------------------------------
      procedure Add_File (Name : in String;
                          File_Path : in String;
                          Done      : out Boolean) is
      begin
         if not Into.Contains (Name) then
            Into.Insert (Name, File_Path);
         end if;
         Done := False;
      end Add_File;

   begin
      Iterate_Files_Path (Pattern => Pattern, Path => Path, Process => Add_File'Access);
   end Find_Files_Path;

   --  ------------------------------
   --  Compose an existing path by adding the specified name to each path component
   --  and return a new paths having only existing directories.  Each directory is
   --  separated by ';'.
   --  If the composed path exists, it is added to the result path.
   --  Example:
   --    paths = 'web;regtests'  name = 'info'
   --    result = 'web/info;regtests/info'
   --  Returns the composed path.
   --  ------------------------------
   function Compose_Path (Paths : in String;
                          Name  : in String) return String is

      procedure Compose (Dir : in String;
                         Done : out Boolean);

      Result  : Unbounded_String;

      --  ------------------------------
      --  Build the new path by checking if Name exists in Dir
      --  and appending the new path in the Result.
      --  ------------------------------
      procedure Compose (Dir : in String;
                         Done : out Boolean) is
         use Ada.Directories;
         use Ada.Strings.Fixed;

         Path : constant String := Util.Files.Compose (Dir, Name);
      begin
         Done := False;
         if Exists (Path) and then Kind (Path) = Directory then
            if Length (Result) > 0 then
               Append (Result, ';');
            end if;
            Append (Result, Path);
         end if;
      exception
         when Name_Error =>
            null;
      end Compose;

   begin
      Iterate_Path (Path => Paths, Process => Compose'Access);
      return To_String (Result);
   end Compose_Path;

   --  ------------------------------
   --  Returns the name of the external file with the specified directory
   --  and the name.  Unlike the Ada.Directories.Compose, the name can represent
   --  a relative path and thus include directory separators.
   --  ------------------------------
   function Compose (Directory : in String;
                     Name      : in String) return String is
   begin
      if Name'Length = 0 then
         return Directory;
      elsif Directory'Length = 0 or Directory = "." or Directory = "./" then
         return Name;
      elsif Directory (Directory'Last) = '/' and Name (Name'First) = '/' then
         return Directory & Name (Name'First + 1 .. Name'Last);
      elsif Directory (Directory'Last) = '/' or Name (Name'First) = '/' then
         return Directory & Name;
      else
         return Directory & "/" & Name;
      end if;
   end Compose;

   --  ------------------------------
   --  Returns a relative path whose origin is defined by From and which refers
   --  to the absolute path referenced by To.  Both From and To are
   --  assumed to be absolute pathes.  Returns the absolute path To if the relative
   --  path could not be found.  Both paths must have at least one root component in common.
   --  ------------------------------
   function Get_Relative_Path (From : in String;
                               To   : in String) return String is
      Result : Unbounded_String;
      Last   : Natural := 0;
   begin
      for I in From'Range loop
         if I > To'Last or else From (I) /= To (I) then
            --  Nothing in common, return the absolute path To.
            if Last <= From'First + 1 then
               return To;
            end if;

            for J in Last .. From'Last - 1 loop
               if From (J) = '/' or From (J) = '\' then
                  Append (Result, "../");
               end if;
            end loop;
            if Last <= To'Last and From (I) /= '/' and From (I) /= '\' then
               Append (Result, "../");
               Append (Result, To (Last .. To'Last));
            end if;
            return To_String (Result);

         elsif I < From'Last and then (From (I) = '/' or From (I) = '\') then
            Last := I + 1;

         end if;
      end loop;
      if To'Last = From'Last or (To'Last = From'Last + 1
                                 and (To (To'Last) = '/' or To (To'Last) = '\')) then
         return ".";
      elsif Last = 0 then
         return To;
      elsif To (From'Last + 1) = '/' or To (From'Last + 1) = '\' then
         return To (From'Last + 2 .. To'Last);
      else
         return To (Last .. To'Last);
      end if;
   end Get_Relative_Path;

end Util.Files;

-----------------------------------------------------------------------
--  Util.Files -- Various File Utility Packages
--  Copyright (C) 2001, 2002, 2003, 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.Directories;
with Ada.Strings.Fixed;
with Ada.Streams;
with Ada.Streams.Stream_IO;
with Ada.Text_IO;
with Util.Strings.Tokenizers;
package body Util.Files is

   --  ------------------------------
   --  Read a complete file into a string.
   --  The Max_Size parameter indicates the maximum size that is read.
   --  ------------------------------
   procedure Read_File (Path     : in String;
                        Into     : out Unbounded_String;
                        Max_Size : in Natural := 0) is
      use Ada.Streams;
      use Ada.Streams.Stream_IO;

      F      : File_Type;
      Buffer : Stream_Element_Array (1 .. 10_000);
      Pos    : Positive_Count := 1;
      Last   : Stream_Element_Offset;
      Space  : Natural;
   begin
      if Max_Size = 0 then
         Space := Natural'Last;
      else
         Space := Max_Size;
      end if;
      Open (Name => Path, File => F, Mode => In_File);
      loop
         Read (File => F, Item => Buffer, From => Pos, Last => Last);
         if Natural (Last) > Space then
            Last := Stream_Element_Offset (Space);
         end if;
         for I in 1 .. Last loop
            Append (Into, Character'Val (Buffer (I)));
         end loop;
         exit when Last < Buffer'Length;
         Pos := Pos + Positive_Count (Last);
      end loop;
      Close (F);

   exception
      when others =>
         if Is_Open (F) then
            Close (F);
         end if;
         raise;
   end Read_File;

   --  ------------------------------
   --  Read the file with the given path, one line at a time and execute the Process
   --  procedure with each line as argument.
   --  ------------------------------
   procedure Read_File (Path     : in String;
                        Process  : not null access procedure (Line : in String)) is
      File : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Open (File => File,
                        Mode => Ada.Text_IO.In_File,
                        Name => Path);
      while not Ada.Text_IO.End_Of_File (File) loop
         Process (Ada.Text_IO.Get_Line (File));
      end loop;
      Ada.Text_IO.Close (File);
   end Read_File;

   --  ------------------------------
   --  Save the string into a file creating the file if necessary
   --  ------------------------------
   procedure Write_File (Path    : in String;
                         Content : in String) is
      use Ada.Streams;
      use Ada.Streams.Stream_IO;
      use Ada.Directories;

      F : File_Type;
      Buffer : Stream_Element_Array (Stream_Element_Offset (Content'First)
                                     .. Stream_Element_Offset (Content'Last));

      Dir : constant String := Containing_Directory (Path);
   begin
      if not Exists (Dir) then
         Create_Path (Dir);
      end if;
      Create (File => F, Name => Path);
      for I in Content'Range loop
         Buffer (Stream_Element_Offset (I))
           := Stream_Element (Character'Pos (Content (I)));
      end loop;
      Write (F, Buffer);
      Close (F);

   exception
      when others =>
         if Is_Open (F) then
            Close (F);
         end if;
         raise;
   end Write_File;

   --  ------------------------------
   --  Save the string into a file creating the file if necessary
   --  ------------------------------
   procedure Write_File (Path    : in String;
                         Content : in Unbounded_String) is
   begin
      Write_File (Path, Ada.Strings.Unbounded.To_String (Content));
   end Write_File;

   --  ------------------------------
   --  Iterate over the search directories defined in Paths and execute
   --  Process with each directory until it returns True in Done
   --  or the last search directory is found.  Each search directory
   --  is separated by ';' (yes, even on Unix).  When Going is set to Backward, the
   --  directories are searched in reverse order.
   --  ------------------------------
   procedure Iterate_Path (Path     : in String;
                           Process  : not null access procedure (Dir  : in String;
                                                                 Done : out Boolean);
                           Going    : in Direction := Ada.Strings.Forward) is
   begin
      Util.Strings.Tokenizers.Iterate_Tokens (Content => Path,
                                              Pattern => ";",
                                              Process => Process,
                                              Going   => Going);
   end Iterate_Path;

   --  ------------------------------
   --  Find the file in one of the search directories.  Each search directory
   --  is separated by ';' (yes, even on Unix).
   --  Returns the path to be used for reading the file.
   --  ------------------------------
   function Find_File_Path (Name  : String;
                            Paths : String) return String is
      use Ada.Directories;
      use Ada.Strings.Fixed;

      Sep_Pos : Natural;
      Pos     : Positive := Paths'First;
      Last    : constant Natural := Paths'Last;

   begin
      while Pos <= Last loop
         Sep_Pos := Index (Paths, ";", Pos);
         if Sep_Pos = 0 then
            Sep_Pos := Last;
         else
            Sep_Pos := Sep_Pos - 1;
         end if;
         declare
            Path : constant String := Util.Files.Compose (Paths (Pos .. Sep_Pos), Name);
         begin
            if Exists (Path) and then Kind (Path) = Ordinary_File then
               return Path;
            end if;
         exception
            when Name_Error =>
               null;
         end;
         Pos := Sep_Pos + 2;
      end loop;
      return Name;
   end Find_File_Path;

   --  ------------------------------
   --  Iterate over the search directories defined in Path and search
   --  for files matching the pattern defined by Pattern.  For each file,
   --  execute Process with the file basename and the full file path.
   --  Stop iterating when the Process procedure returns True.
   --  Each search directory is separated by ';'.  When Going is set to Backward, the
   --  directories are searched in reverse order.
   --  ------------------------------
   procedure Iterate_Files_Path (Pattern  : in String;
                                 Path     : in String;
                                 Process  : not null access procedure (Name : in String;
                                                                       File : in String;
                                                                       Done : out Boolean);
                                 Going    : in Direction := Ada.Strings.Forward) is

      procedure Find_Files (Dir  : in String;
                            Done : out Boolean);

      --  ------------------------------
      --  Find the files matching the pattern in Dir.
      --  ------------------------------
      procedure Find_Files (Dir  : in String;
                            Done : out Boolean) is
         use Ada.Directories;

         Filter  : constant Filter_Type := (Ordinary_File => True, others => False);
         Ent     : Directory_Entry_Type;
         Search  : Search_Type;
      begin
         Done := False;
         Start_Search (Search, Directory => Dir,
                       Pattern => Pattern, Filter => Filter);
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Name      : constant String := Simple_Name (Ent);
               File_Path : constant String := Full_Name (Ent);
            begin
               Process (Name, File_Path, Done);
               exit when Done;
            end;
         end loop;
      end Find_Files;

   begin
      Iterate_Path (Path => Path, Process => Find_Files'Access, Going => Going);
   end Iterate_Files_Path;

   --  ------------------------------
   --  Find the files which match the pattern in the directories specified in the
   --  search path Path.  Each search directory is separated by ';'.
   --  File names are added to the string set in Into.
   --  ------------------------------
   procedure Find_Files_Path (Pattern : in String;
                              Path    : in String;
                              Into    : in out Util.Strings.Maps.Map) is

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

      --  ------------------------------
      --  Find the files matching the pattern in Dir.
      --  ------------------------------
      procedure Add_File (Name : in String;
                          File_Path : in String;
                          Done      : out Boolean) is
      begin
         if not Into.Contains (Name) then
            Into.Insert (Name, File_Path);
         end if;
         Done := False;
      end Add_File;

   begin
      Iterate_Files_Path (Pattern => Pattern, Path => Path, Process => Add_File'Access);
   end Find_Files_Path;

   --  ------------------------------
   --  Compose an existing path by adding the specified name to each path component
   --  and return a new paths having only existing directories.  Each directory is
   --  separated by ';'.
   --  If the composed path exists, it is added to the result path.
   --  Example:
   --    paths = 'web;regtests'  name = 'info'
   --    result = 'web/info;regtests/info'
   --  Returns the composed path.
   --  ------------------------------
   function Compose_Path (Paths : in String;
                          Name  : in String) return String is

      procedure Compose (Dir : in String;
                         Done : out Boolean);

      Result  : Unbounded_String;

      --  ------------------------------
      --  Build the new path by checking if Name exists in Dir
      --  and appending the new path in the Result.
      --  ------------------------------
      procedure Compose (Dir : in String;
                         Done : out Boolean) is
         use Ada.Directories;
         use Ada.Strings.Fixed;

         Path : constant String := Util.Files.Compose (Dir, Name);
      begin
         Done := False;
         if Exists (Path) and then Kind (Path) = Directory then
            if Length (Result) > 0 then
               Append (Result, ';');
            end if;
            Append (Result, Path);
         end if;
      exception
         when Name_Error =>
            null;
      end Compose;

   begin
      Iterate_Path (Path => Paths, Process => Compose'Access);
      return To_String (Result);
   end Compose_Path;

   --  ------------------------------
   --  Returns the name of the external file with the specified directory
   --  and the name.  Unlike the Ada.Directories.Compose, the name can represent
   --  a relative path and thus include directory separators.
   --  ------------------------------
   function Compose (Directory : in String;
                     Name      : in String) return String is
   begin
      if Name'Length = 0 then
         return Directory;
      elsif Directory'Length = 0 or Directory = "." or Directory = "./" then
         return Name;
      elsif Directory (Directory'Last) = '/' and Name (Name'First) = '/' then
         return Directory & Name (Name'First + 1 .. Name'Last);
      elsif Directory (Directory'Last) = '/' or Name (Name'First) = '/' then
         return Directory & Name;
      else
         return Directory & "/" & Name;
      end if;
   end Compose;

   --  ------------------------------
   --  Returns a relative path whose origin is defined by From and which refers
   --  to the absolute path referenced by To.  Both From and To are
   --  assumed to be absolute pathes.  Returns the absolute path To if the relative
   --  path could not be found.  Both paths must have at least one root component in common.
   --  ------------------------------
   function Get_Relative_Path (From : in String;
                               To   : in String) return String is
      Result : Unbounded_String;
      Last   : Natural := 0;
   begin
      for I in From'Range loop
         if I > To'Last or else From (I) /= To (I) then
            --  Nothing in common, return the absolute path To.
            if Last <= From'First + 1 then
               return To;
            end if;

            for J in Last .. From'Last - 1 loop
               if From (J) = '/' or From (J) = '\' then
                  Append (Result, "../");
               end if;
            end loop;
            if Last <= To'Last and From (I) /= '/' and From (I) /= '\' then
               Append (Result, "../");
               Append (Result, To (Last .. To'Last));
            end if;
            return To_String (Result);

         elsif I < From'Last and then (From (I) = '/' or From (I) = '\') then
            Last := I + 1;

         end if;
      end loop;
      if To'Last = From'Last or (To'Last = From'Last + 1
                                 and (To (To'Last) = '/' or To (To'Last) = '\')) then
         return ".";
      elsif Last = 0 then
         return To;
      elsif To (From'Last + 1) = '/' or To (From'Last + 1) = '\' then
         return To (From'Last + 2 .. To'Last);
      else
         return To (Last .. To'Last);
      end if;
   end Get_Relative_Path;

end Util.Files;

Use the string tokenizer to iterate over the search paths


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                            A 4 G . A _ D E B U G                         --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            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,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

package A4G.A_Debug is

--  This package contains global flags used to control the inclusion
--  of debugging code in various phases of the ASIS-for-GNAT. It is
--  an almost complete analog of the GNAT Debug package

   -------------------------
   -- Dynamic Debug Flags --
   -------------------------

   --  Thirty six flags that can be used to activate various specialized
   --  debugging output information. The flags are preset to False, which
   --  corresponds to the given output being suppressed. The individual
   --  flags can be turned on using the undocumented switch /dxxx where
   --  xxx is a string of letters for flags to be turned on. Documentation
   --  on the current usage of these flags is contained in the body of Debug
   --  rather than the spec, so that we don't have to recompile the world
   --  when a new debug flag is added

   Debug_Flag_A : Boolean := False;
   Debug_Flag_B : Boolean := False;
   Debug_Flag_C : Boolean := False;
   Debug_Flag_D : Boolean := False;
   Debug_Flag_E : Boolean := False;
   Debug_Flag_F : Boolean := False;
   Debug_Flag_G : Boolean := False;
   Debug_Flag_H : Boolean := False;
   Debug_Flag_I : Boolean := False;
   Debug_Flag_J : Boolean := False;
   Debug_Flag_K : Boolean := False;
   Debug_Flag_L : Boolean := False;
   Debug_Flag_M : Boolean := False;
   Debug_Flag_N : Boolean := False;
   Debug_Flag_O : Boolean := False;
   Debug_Flag_P : Boolean := False;
   Debug_Flag_Q : Boolean := False;
   Debug_Flag_R : Boolean := False;
   Debug_Flag_S : Boolean := False;
   Debug_Flag_T : Boolean := False;
   Debug_Flag_U : Boolean := False;
   Debug_Flag_V : Boolean := False;
   Debug_Flag_W : Boolean := False;
   Debug_Flag_X : Boolean := False;
   Debug_Flag_Y : Boolean := False;
   Debug_Flag_Z : Boolean := False;

   Debug_Flag_1 : Boolean := False;
   Debug_Flag_2 : Boolean := False;
   Debug_Flag_3 : Boolean := False;
   Debug_Flag_4 : Boolean := False;
   Debug_Flag_5 : Boolean := False;
   Debug_Flag_6 : Boolean := False;
   Debug_Flag_7 : Boolean := False;
   Debug_Flag_8 : Boolean := False;
   Debug_Flag_9 : Boolean := False;

   procedure Set_Debug_Flag (C : Character; Val : Boolean := True);
   --  Where C is 0-9 or a-z, sets the corresponding debug flag to the
   --  given value. In the checks off version of debug, the call to
   --  Set_Debug_Flag is always a null operation.

   procedure Set_Off;
   --  Sets all the debug flags OFF (except Debug_Lib_Model for now),
   --  is to be called by Asis_Environment.Finalize

   procedure Set_On;  -- TEMPORARY SOLUTION!!!
   --  Sets all the debug flags ON.

   ------------------------
   -- TEMPORARY SOLUTION --
   ------------------------

   Debug_Mode      : Boolean := False;
   --  Flag indicating if the debugging information should be output by the
   --  routines from the A4G.A_Output package

   Debug_Lib_Model : Boolean := False;
   --  Flag forcing the debug output of the tables implementing the ASIS
   --  Context Model to be performed when finalizing the ASIS Environment.
   --  Currently should be set by hand. The debug output is produced only if
   --  Debug_Mode is set ON.

end A4G.A_Debug;

Add the ASIS file $i

Add the ASIS file $i


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

package body MAT.Formats is

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      return Hex;
   end Addr;

end MAT.Formats;

Implement the Addr function

Implement the Addr function


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

with Util.Log.Loggers;
with Security.OAuth.JWT;
package body Security.Auth.OAuth.Googleplus is

   use Util.Log;

   Log : constant Loggers.Logger := Util.Log.Loggers.Create ("Security.Auth.OAuth.Googleplus");

   --  ------------------------------
   --  Verify the OAuth access token and retrieve information about the user.
   --  ------------------------------
   overriding
   procedure Verify_Access_Token (Realm   : in Manager;
                                  Assoc   : in Association;
                                  Request : in Parameters'Class;
                                  Token   : in Security.OAuth.Clients.Access_Token_Access;
                                  Result  : in out Authentication) is
      pragma Unreferenced (Assoc, Request);
   begin
      --  The token returned by Google+ must contain an id_token.
      if not (Token.all in Security.OAuth.Clients.OpenID_Token'Class) then
         Log.Warn ("Invalid token instance created: missing the id_token");
         Set_Result (Result, INVALID_SIGNATURE, "invalid access token returned");
         return;
      end if;

      --  The id_token is a JWT token that must be decoded and verified.
      --  See https://developers.google.com/accounts/docs/OAuth2Login#validatingtoken
      --  It contains information to identify the user.
      declare
         T : constant Security.OAuth.Clients.OpenID_Token_Access :=
           Security.OAuth.Clients.OpenID_Token'Class (Token.all)'Access;
         Info : constant Security.OAuth.JWT.Token := Security.OAuth.JWT.Decode (T.Get_Id_Token);
      begin
         --  Verify that the JWT token concerns our application.
         if Security.OAuth.JWT.Get_Audience (Info) /= Realm.App.Get_Application_Identifier then
            Set_Result (Result, INVALID_SIGNATURE,
                        "the access token was granted for another application");
            return;

            --  Verify that the issuer is Google+
         elsif Security.OAuth.JWT.Get_Issuer (Info) /= Realm.Issuer then
            Set_Result (Result, INVALID_SIGNATURE,
                        "the access token was not generated by the expected authority");
            return;

         end if;
         Result.Identity := To_Unbounded_String ("https://accounts.google.com/");
         Append (Result.Identity, Security.OAuth.JWT.Get_Subject (Info));
         Result.Claimed_Id := Result.Identity;

         --  The email is optional and depends on the scope.
         Result.Email := To_Unbounded_String (Security.OAuth.JWT.Get_Claim (Info, "email", ""));
         Set_Result (Result, AUTHENTICATED, "authenticated");
      end;
   end Verify_Access_Token;

end Security.Auth.OAuth.Googleplus;

Implement the support for Google+

Implement the support for Google+


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . G N A T _ I N 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 Ada.Exceptions;
with Ada.Strings.Fixed;         use Ada.Strings.Fixed;
with Ada.Text_IO;               use Ada.Text_IO;

with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Asis.Errors;
with Asis.Exceptions;           use Asis.Exceptions;
with Asis.Extensions;           use Asis.Extensions;

with A4G.A_Debug;               use A4G.A_Debug;
with A4G.A_Opt;                 use A4G.A_Opt;
with A4G.A_Output;              use A4G.A_Output;
with A4G.Contt;                 use A4G.Contt;
with A4G.Vcheck;                use A4G.Vcheck;

with Aspects;
with Atree;
with Csets;
with Elists;
with Fname;
with Gnatvsn;
with Lib;
with Namet;
with Nlists;
with Opt;                       use Opt;
with Repinfo;
with Sem_Aux;
with Sinput;
with Stand;
with Stringt;
with Uintp;
with Urealp;
with Tree_IO;

package body A4G.GNAT_Int is

   LT           : String renames ASIS_Line_Terminator;
   Standard_GCC : constant String_Access :=
     GNAT.OS_Lib.Locate_Exec_On_Path ("gcc");

   -----------------
   -- Create_Tree --
   -----------------

   procedure Create_Tree (Source_File   :     String_Access;
                          Context       :     Context_Id;
                          Is_Predefined :     Boolean;
                          Success       : out Boolean)
   is
   begin
      if Is_Predefined then
         Compile (Source_File => Source_File,
                  Args        => (1 => GNAT_Flag),
                  Success     => Success,
                  GCC         => Gcc_To_Call (Context));
      else
         Compile (Source_File => Source_File,
                  Args        => I_Options (Context),
                  Success     => Success,
                  GCC         => Gcc_To_Call (Context));
      end if;
   exception
      when others =>
         Raise_ASIS_Failed ("A4G.GNAT_Int.Create_Tree:" & LT &
                         "  check the path and environment settings for gcc!");
   end Create_Tree;

   -------------
   -- Execute --
   -------------

   function Execute
     (Program      : String_Access;
      Args         : Argument_List;
      Compiler_Out : String := "";
      Display_Call : Boolean := A4G.A_Debug.Debug_Mode)
      return         Boolean
   is
      Success     : Boolean;
      Return_Code : Integer;

      Execute : String_Access := Program;
   begin

      if Execute = null then
         Execute := Standard_GCC;
      end if;

      if Display_Call then
         Put (Standard_Error, Execute.all);

         for J in Args'Range loop
            Put (Standard_Error, " ");
            Put (Standard_Error, Args (J).all);
         end loop;

         New_Line (Standard_Error);
      end if;

      if Execute = null then
         Ada.Exceptions.Raise_Exception
           (Program_Error'Identity,
            "A4G.GNAT_Int.Execute: Can not locate program to execute");
      end if;

      if Compiler_Out /= "" then
         GNAT.OS_Lib.Spawn
           (Execute.all,
            Args,
            Compiler_Out,
            Success,
            Return_Code);

         Success := Return_Code = 0;
      else
         GNAT.OS_Lib.Spawn (Execute.all, Args, Success);
      end if;

      return Success;
   end Execute;

   ----------------------------------------------
   -- General Interfaces between GNAT and ASIS --
   ----------------------------------------------

   function A_Time (T : Time_Stamp_Type) return Time is
      Year      : Year_Number;
      Month     : Month_Number;
      Day       : Day_Number;
      Hours     : Integer range 0 .. 23;
      Minutes   : Integer range 0 .. 59;
      Seconds   : Integer range 0 .. 59;
      Day_Time  : Day_Duration;
   begin
      Split_Time_Stamp
        (TS      => T,
         Year    => Nat (Year),
         Month   => Nat (Month),
         Day     => Nat (Day),
         Hour    => Nat (Hours),
         Minutes => Nat (Minutes),
         Seconds => Nat (Seconds));

      Day_Time := Duration (Seconds + 60 * Minutes + 3600 * Hours);

      return Time_Of (Year, Month, Day, Day_Time);
   end A_Time;

   --------------------------------
   -- Tree_In_With_Version_Check --
   --------------------------------

   procedure Tree_In_With_Version_Check
     (Desc    : File_Descriptor;
      Cont    : Context_Id;
      Success : out Boolean)
   is
      Cont_Mode   : constant Context_Mode := Context_Processing_Mode (Cont);
      File_Closed :          Boolean      := False;
      ASIS_GNAT_V : constant String       := Gnatvsn.Gnat_Version_String;
      First_A_Idx :          Natural      := ASIS_GNAT_V'First;
      Last_A_Idx  :          Natural;
      First_T_Idx :          Natural;
      Last_T_Idx  :          Natural;
   begin
      Success := False;

      Tree_IO.Tree_Read_Initialize (Desc);

      Opt.Tree_Read;

      --  GNAT/ASIS version check first

      if Tree_ASIS_Version_Number /= Tree_IO.ASIS_Version_Number then
         Close (Desc, File_Closed);
         Ada.Exceptions.Raise_Exception
           (Program_Error'Identity, "Inconsistent versions of GNAT and ASIS");
      end if;

      --  Check that ASIS Pro uses the tree created by GNAT Pro

      First_T_Idx := Tree_Version_String'First;

      if ASIS_GNAT_V (First_A_Idx  .. First_A_Idx + 2) = "Pro"
         and then Tree_Version_String (First_T_Idx  .. First_T_Idx + 2) /=
                  "Pro"
      then
         Close (Desc, File_Closed);
         Ada.Exceptions.Raise_Exception
           (Program_Error'Identity, "ASIS Pro can be used with GNAT Pro only");
      end if;

      if Strong_Version_Check then
         --  We check only the dates here!
         First_A_Idx :=
           Index (Source  => ASIS_GNAT_V,
                  Pattern => "(") + 1;

         First_T_Idx :=
           Index (Source  => Tree_Version_String.all,
                  Pattern => "(") + 1;

         Last_A_Idx := Index (Source  => ASIS_GNAT_V,
                     Pattern => ")") - 1;

         if Index (Source  => ASIS_GNAT_V, Pattern => "-") /= 0 then
            Last_A_Idx := Index (Source  => ASIS_GNAT_V,
                                 Pattern => "-") - 1;
         end if;

         Last_T_Idx := Index (Source  => Tree_Version_String.all,
                              Pattern => ")") - 1;

         if Index (Source  => Tree_Version_String.all, Pattern => "-") /=
            0
         then
            Last_T_Idx :=
              Index (Source  => Tree_Version_String.all,
                     Pattern => "-") - 1;
         end if;

         if ASIS_GNAT_V (First_A_Idx .. Last_A_Idx) /=
            Tree_Version_String (First_T_Idx .. Last_T_Idx)
         then
            Close (Desc, File_Closed);
            Ada.Exceptions.Raise_Exception
              (Program_Error'Identity,
               "Inconsistent versions of GNAT [" & Tree_Version_String.all &
               "] and ASIS [" & ASIS_GNAT_V & ']');
         end if;

      end if;

      --  Check if we are in Ada 2012 mode and need aspects...

--      if Opt.Ada_Version_Config = Ada_2012 then
--         --  For now, reading aspects is protected by the debug '.A' flag
--         Debug.Debug_Flag_Dot_AA := True;
--      end if;

      if Operating_Mode /= Check_Semantics then

         if Cont_Mode  = One_Tree then
            --  If in one-tree mode we can not read the only tree we have,
            --  there is no reason to continue, so raising an exception
            --  is the only choice:

            Close (Desc, File_Closed);

            --  We did not check File_Closed here, because the fact that the
            --  tree is not compile-only seems to be more important for ASIS

            Set_Error_Status
              (Status    => Asis.Errors.Use_Error,
               Diagnosis => "Asis.Ada_Environments.Open:"
               &  ASIS_Line_Terminator
               & "tree file "
               & Base_Name (A_Name_Buffer (1 .. A_Name_Len))
               & " is not compile-only");

            raise ASIS_Failed;

         elsif Cont_Mode = N_Trees
           or else
               Cont_Mode = All_Trees
         then

            --  no need to read the rest of this tree file, but
            --  we can continue even if we can not read some trees...

            ASIS_Warning
              (Message => "Asis.Ada_Environments.Open: "
               &  ASIS_Line_Terminator
               & "tree file "
               & Base_Name (A_Name_Buffer (1 .. A_Name_Len))
               & " is not compile-only, ignored",
               Error   => Asis.Errors.Use_Error);
         end if;

         --  debug stuff...

         if (Debug_Flag_O    or else
             Debug_Lib_Model or else
             Debug_Mode)
            and then
             Cont_Mode /= One_Tree and then
             Cont_Mode /= N_Trees
         then
            Put (Standard_Error, "The tree file ");
            Put (Standard_Error, Base_Name (A_Name_Buffer (1 .. A_Name_Len)));
            Put (Standard_Error, " is not compile-only");
            New_Line (Standard_Error);
         end if;
      else
         Atree.Tree_Read;
         Elists.Tree_Read;
         Fname.Tree_Read;
         Lib.Tree_Read;
         Namet.Tree_Read;
         Nlists.Tree_Read;
         Sem_Aux.Tree_Read;
         Sinput.Tree_Read;
         Stand.Tree_Read;
         Stringt.Tree_Read;
         Uintp.Tree_Read;
         Urealp.Tree_Read;
         Repinfo.Tree_Read;
         Aspects.Tree_Read;

         Csets.Initialize;

         --  debug stuff...
         if Debug_Flag_O    or else
            Debug_Lib_Model or else
            Debug_Mode
         then
            Put (Standard_Error, "The tree file ");
            Put (Standard_Error, Base_Name (A_Name_Buffer (1 .. A_Name_Len)));
            Put (Standard_Error, " is OK");
            New_Line (Standard_Error);
         end if;

         Success := True;
      end if;

      Close (Desc, File_Closed);

      if not File_Closed then
         Raise_ASIS_Failed
           (Diagnosis => "Asis.Ada_Environments.Open: "               &
                         "Can not close tree file: "                  &
                          Base_Name (A_Name_Buffer (1 .. A_Name_Len)) &
                          ASIS_Line_Terminator                        &
                          "disk is full or file may be used by other program",
            Stat      => Asis.Errors.Data_Error);
      end if;

   exception
      when Tree_IO.Tree_Format_Error =>
         Close (Desc, File_Closed);

         Ada.Exceptions.Raise_Exception
           (Program_Error'Identity, "Inconsistent versions of GNAT and ASIS");

   end Tree_In_With_Version_Check;

end A4G.GNAT_Int;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                         A 4 G . C O N T T . S D                          --
--                                                                          --
--                                 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 Ada.Exceptions;

with GNAT.Directory_Operations; use GNAT.Directory_Operations;

with Asis.Errors;               use Asis.Errors;
with Asis.Exceptions;           use Asis.Exceptions;

with A4G.A_Debug;               use A4G.A_Debug;
with A4G.GNAT_Int;
with A4G.A_Output;              use A4G.A_Output;
with A4G.Contt.TT;              use A4G.Contt.TT;
with A4G.Contt.UT;              use A4G.Contt.UT;
with A4G.CU_Info2;              use A4G.CU_Info2;
with A4G.Defaults;              use A4G.Defaults;
with A4G.Vcheck;                use A4G.Vcheck;

with Atree;
with Lib;
with Output;                    use Output;
with Sinfo;                     use Sinfo;

package body A4G.Contt.SD is

   ------------------------------------
   -- Local Subprograms  (new stuff) --
   ------------------------------------

   --  Do we need some of these local subprograms as the interface
   --  subprograms of this package?

   --  Is this package the right location for these subprograms?

   procedure Scan_Search_Path (C : Context_Id);
   --  Scans the tree search path and stores the names of the tree file
   --  candidates in the context tree table.

   procedure Scan_Tree_List (C : Context_Id);
   --  This procedure is supposed to be called for One_tree and N_Trees
   --  Context processing modes, therefore the Parameters string associated
   --  with C should contain at least one tree name. It scans the list of tree
   --  file names which have been extracted from the Parameters string when
   --  making the association for C. For each tree file name checks if the
   --  file exists and stores existing files in the context tree table. In case
   --  if this check fails, raises ASIS_Failed if C was defined as "-C1"
   --  ("one tree") context, or generates Asis Warning for "-CN" Context.
   --  This procedure does not reset a context.

   procedure Read_and_Check_New
     (C       : Context_Id;
      Tree    : Tree_Id;
      Success : out Boolean);
   --  Tries to read in Tree and to check if this tree is compile-only.
   --  if both of these attempts are successful, sets Success ON and
   --  sets Current_Tree as Tree. If either of these actions fails, then
   --  depending on the Context operation mode, either raises ASIS_Failed
   --  and forms the Diagnosis string on behalf on Asis.Ada_Environments.Open,
   --  or only sets Success OFF, in both cases Current_Context and Current_Tree
   --  are set to nil values.

   procedure Process_Unit_New (U : Unit_Number_Type);
   --  Does the general unit processing in one-pass Context opening. If this
   --  unit is "new", it creates the new entry in the unit table and checks,
   --  if the unit in the tree is consistent with the unit source (if needed).
   --  If U corresponds to a "known" unit, it makes the consistency check.
   --  If this procedure raises ASIS_Failed, it forms the Diagnosis string
   --  on behalf on Asis.Ada_Environments.Open
   --  ????????

   procedure Investigate_Unit_New
     (C   : Context_Id;
      U   : Unit_Id;
      U_N : Unit_Number_Type);
   --  Computes the basic unit attributes for U_N and stores them for the
   --  ASIS unit U in the ASIS Context C.

   procedure Store_Tree (Path : String);
   --  Stores the full name of the tree file in the Context Tree table for
   --  the current Context. It supposes, that when it is called,
   --  Namet.Name_Table contains the name of the tree file to be stored,
   --  but without any directory information, and Path contains the path to
   --  the tree search directory (followed by directory separator) where this
   --  file was found.

   ---------------------------
   -- Investigate_Trees_New --
   ---------------------------

   procedure Investigate_Trees_New (C : Context_Id) is
      Success : Boolean := False;
      --  flag indicating if the next tree file has been successfully read in
      Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
   begin
      --  here we have all the names of tree files stored in the tree table
      --  for C
      for T in First_Tree_Id .. Last_Tree (C) loop
         Read_and_Check_New (C, T, Success);

         if Success then
            Get_Name_String (C, T);
            Change_Dir (Dir_Name (A_Name_Buffer (1 .. A_Name_Len)));

            Register_Units;
            Scan_Units_New;

            Change_Dir (Current_Dir);
         end if;

      end loop;
   end Investigate_Trees_New;

   --------------------------
   -- Investigate_Unit_New --
   --------------------------

   procedure Investigate_Unit_New
     (C   : Context_Id;
      U   : Unit_Id;
      U_N : Unit_Number_Type)
   is
      Top : constant Node_Id := Lib.Cunit (U_N);
      --  pointer to the N_Compilation_Unit node for U in the currently
      --  accessed tree
   begin

      Set_S_F_Name_and_Origin (C, U, Top);
      Check_Source_Consistency (C, U);

      Set_Kind_and_Class      (C, U, Top);
      Get_Ada_Name            (Top);
      Set_Ada_Name            (U);
      Set_Is_Main_Unit        (C, U, Is_Main (Top, Kind (C, U)));
      Set_Is_Body_Required    (C, U, Sinfo.Body_Required (Top));

      Set_Dependencies        (C, U, Top);

   end Investigate_Unit_New;

   ----------------------
   -- Process_Unit_New --
   ----------------------

   procedure Process_Unit_New (U : Unit_Number_Type) is
      Cont         : constant Context_Id := Get_Current_Cont;
      Include_Unit : Boolean             := False;
      Current_Unit : Unit_Id;
   begin
      Namet.Get_Decoded_Name_String (Lib.Unit_Name (U));
      Set_Norm_Ada_Name_String_With_Check (U, Include_Unit);

      if not Include_Unit then
         return;
      end if;

      Current_Unit := Name_Find (Cont);
      --  all the units in the current tree are already registered, therefore
      --  Current_Unit should not be Nil_Unit

      if Already_Processed (Cont, Current_Unit) then
         Check_Consistency   (Cont, Current_Unit, U);
         --  Append_Tree_To_Unit (Cont, Current_Unit);
      else
         Investigate_Unit_New (Cont, Current_Unit, U);
      end if;
   end Process_Unit_New;

   ------------------------
   -- Read_and_Check_New --
   ------------------------

   procedure Read_and_Check_New
     (C       : Context_Id;
      Tree    : Tree_Id;
      Success : out Boolean)
   is
      Tree_File_D : File_Descriptor;

   begin
      --  Special processing for GNSA mode:
      if Tree_Processing_Mode (C) = GNSA then

         if Context_Processing_Mode (C) = One_Tree then
            Set_Current_Cont (C);
            Set_Current_Tree (Tree);
            Success := True;
            return;
         else
            --  Other possibilites are not implemented now, so
            pragma Assert (False);
            null;
         end if;

      end if;

      Get_Name_String (C, Tree);
      A_Name_Buffer (A_Name_Len + 1) := ASCII.NUL;
      Tree_File_D := Open_Read (A_Name_Buffer'Address, Binary);

      A4G.GNAT_Int.Tree_In_With_Version_Check (Tree_File_D, C, Success);

      Set_Current_Cont (C);
      Set_Current_Tree (Tree);

   exception
      when Program_Error |
           ASIS_Failed   =>

         Set_Current_Cont (Nil_Context_Id);
         Set_Current_Tree (Nil_Tree);

         raise;
      when Ex : others =>

         --  If we are here, we are definitely having a serious problem:
         --  we have a tree file which is version-compartible with ASIS,
         --  and we can not read it because of some unknown reason.

         Set_Current_Cont (Nil_Context_Id);
         Set_Current_Tree (Nil_Tree);

         --  debug stuff...
         if Debug_Flag_O    or else
            Debug_Lib_Model or else
            Debug_Mode
         then
            Write_Str ("The tree file ");
            Write_Str (A_Name_Buffer (1 .. A_Name_Len));
            Write_Str (" was not read in and checked successfully");
            Write_Eol;
            Write_Str (Ada.Exceptions.Exception_Name (Ex));
            Write_Str (" was raised");
            Write_Eol;
            Write_Str ("Exception message: ");
            Write_Str (Ada.Exceptions.Exception_Message (Ex));
            Write_Eol;
         end if;

         Report_ASIS_Bug
           (Query_Name  => "A4G.Contt.SD.Read_and_Check_New" &
                           " (tree file " &
                           A_Name_Buffer (1 .. A_Name_Len) & ")",
            Ex          => Ex);
   end Read_and_Check_New;

   --------------------
   -- Scan_Tree_List --
   --------------------

   procedure Scan_Tree_List (C : Context_Id) is
      Cont_Mode   : constant Context_Mode := Context_Processing_Mode (C);
      Tree_List   : Tree_File_List_Ptr renames
        Contexts.Table (C).Context_Tree_Files;

      GNSA_Tree_Name : constant String := "GNSA-created tree";
      --  Can be used for -C1 COntext only.

--      Success : Boolean;
   begin
      --  Special processing for GNSA mode:

      if Tree_Processing_Mode (C) = GNSA then

         if Context_Processing_Mode (C) = One_Tree then
            Name_Len := GNSA_Tree_Name'Length;
            Name_Buffer (1 .. Name_Len) := GNSA_Tree_Name;
            Store_Tree ("");

            return;
         else
            --  Other possibilites are not implemented now, so
            pragma Assert (False);
            null;
         end if;

      end if;

      for I in Tree_List'Range loop

         exit when Tree_List (I) = null;

         if not Is_Regular_File (Tree_List (I).all) then

--            --  A loop needed to deal with possible raise conditions

--            Success := False;

--            for J in 1 .. 100 loop
--               if Is_Regular_File (Tree_List (I).all) then
--                  Success := True;
--                  exit;
--               end if;

--               delay 0.05;
--            end loop;

--            if not Success then

            if Cont_Mode  = One_Tree then
               Set_Error_Status
                 (Status    => Asis.Errors.Use_Error,
                  Diagnosis => "Asis.Ada_Environments.Open:"
                             &  ASIS_Line_Terminator
                             & "tree file "
                             & Tree_List (I).all
                             & " does not exist");
               raise ASIS_Failed;
            elsif Cont_Mode = N_Trees then
               ASIS_Warning
                  (Message => "Asis.Ada_Environments.Open: "
                             &  ASIS_Line_Terminator
                             & "tree file "
                             & Tree_List (I).all
                             & " does not exist",
                   Error   => Use_Error);
            end if;
--            end if;

         else
            Name_Len := Tree_List (I)'Length;
            Name_Buffer (1 .. Name_Len) := Tree_List (I).all;
            Store_Tree ("");
         end if;

      end loop;

   end Scan_Tree_List;

   ----------------------
   -- Scan_Search_Path --
   ----------------------

   procedure Scan_Search_Path (C : Context_Id) is
      Curr_Dir    : GNAT.Directory_Operations.Dir_Type;
      Search_Path : constant Directory_List_Ptr :=
        Contexts.Table (C).Tree_Path;

      procedure Scan_Dir (Path : String);
      --  scans tree files in Curr_Dir. Puts in the Name Table all
      --  the files having names of the form *.at?, which have not been
      --  scanned before. Sets the global variable Last_Tree_File equal to
      --  the Name_Id of the last scanned tree file. The names of the tree
      --  files stores in the Name Table are also stored in the ASIS tree
      --  table with the directory information passed as the actual for Path
      --  parameter

      procedure Read_Tree_File
        (Dir  : in out GNAT.Directory_Operations.Dir_Type;
         Str  : out String;
         Last : out Natural);
      --  This procedure is the modification of GNAT.Directory_Operations.Read
      --  which reads only tree file entries from the directory. A Tree file
      --  is any file having the extension '.[aA][dD][tT]' (We are
      --  considering upper case letters because of "semi-case-sensitiveness"
      --  of Windows 95/98/NT.)

      procedure Read_Tree_File
        (Dir  : in out GNAT.Directory_Operations.Dir_Type;
         Str  : out String;
         Last : out Natural)
      is
         function Is_Tree_File return Boolean;
         --  Checks if the file name stored in Str is the name of some tree
         --  file. This function assumes that Str'First is 1, and that
         --  Last > 0

         function Is_Tree_File return Boolean is
            Result : Boolean := False;
         begin

            if Last >= 5                     and then
               Str (Last - 3) = '.'          and then

               (Str (Last) = 't' or else
                Str (Last) = 'T')            and then

               (Str (Last - 1) = 'd' or else
                Str (Last - 1) = 'D')        and then

               (Str (Last - 2) = 'a' or else
                Str (Last - 2) = 'A')
            then
               Result := True;
            end if;

            return Result;

         end Is_Tree_File;

      begin
         GNAT.Directory_Operations.Read (Dir, Str, Last);
         while Last > 0 loop
            exit when Is_Tree_File;
            GNAT.Directory_Operations.Read (Dir, Str, Last);
         end loop;

      end Read_Tree_File;

      procedure Scan_Dir (Path : String) is
         T_File        : Name_Id;
         Is_First_Tree : Boolean := True;
      begin
         --  looking for the first tree file in this directory

         Read_Tree_File
           (Dir  => Curr_Dir,
            Str  => Namet.Name_Buffer,
            Last => Namet.Name_Len);

         while Namet.Name_Len > 0 loop
            T_File := Name_Find;

            if Is_First_Tree then
               Is_First_Tree := False;
               First_Tree_File := T_File;
            end if;

            if T_File > Last_Tree_File then
               Last_Tree_File := T_File;
               Store_Tree (Path);
            end if;

            Read_Tree_File
              (Dir  => Curr_Dir,
               Str  => Namet.Name_Buffer,
               Last => Namet.Name_Len);

         end loop;

      end Scan_Dir;

   begin  --  Scan_Search_Path
      if Search_Path = null then
         GNAT.Directory_Operations.Open (Curr_Dir, "." & Directory_Separator);
         Scan_Dir ("");
         GNAT.Directory_Operations.Close (Curr_Dir);
      else

         for I in 1 .. Search_Path'Last loop
            GNAT.Directory_Operations.Open (Curr_Dir, Search_Path (I).all);
            Scan_Dir (Search_Path (I).all);
            GNAT.Directory_Operations.Close (Curr_Dir);
         end loop;

      end if;

      if Use_Default_Trees (C) then

         for J in First_Dir_Id .. ASIS_Tree_Search_Directories.Last loop

            GNAT.Directory_Operations.Open
              (Curr_Dir,
               ASIS_Tree_Search_Directories.Table (J).all);

            Scan_Dir (ASIS_Tree_Search_Directories.Table (J).all);
            GNAT.Directory_Operations.Close (Curr_Dir);

         end loop;

      end if;

   end Scan_Search_Path;

   -------------------------
   -- Scan_Tree_Files_New --
   -------------------------

   procedure Scan_Tree_Files_New (C : Context_Id) is
      C_Mode : constant Context_Mode := Context_Processing_Mode (C);

      GNSA_Tree_Name : constant String := "GNSA-created tree";
      --  Can be used for -C1 Context only
   begin
      --  Special processing for GNSA mode:

      if Tree_Processing_Mode (C) = GNSA then

         if Context_Processing_Mode (C) = One_Tree then
            Name_Len := GNSA_Tree_Name'Length;
            Name_Buffer (1 .. Name_Len) := GNSA_Tree_Name;
            Store_Tree ("");

            return;
            --  to avoid GNAT Name Table corruption
         else
            --  Other possibilites are not implemented now, so
            pragma Assert (False);
            null;
         end if;

      end if;

      --  first, initialization which is (may be?) common for all context
      --  modes:
      First_Tree_File := First_Name_Id;
      Last_Tree_File  := First_Name_Id - 1;
      Namet.Initialize;

      --  now for different context modes we call individual scan procedures.
      --  all of them first put names of tree files into the GNAT Name table
      --  and then transfer them into Context tree table, but we cannot
      --  factor this out because of the differences in processing a search
      --  path (if any) and forming the full names of the tree files

      case C_Mode is
         when All_Trees =>
            Scan_Search_Path (C);
         when One_Tree | N_Trees =>
            Scan_Tree_List (C);
            --  all the tree file names have already been stored in the
            --  context tree table when association parameters were processed
            null;
         when Partition =>
            Not_Implemented_Yet ("Scan_Tree_Files_New (Partition)");
      end case;

      --  debug output:...
      if Debug_Flag_O    or else
         Debug_Lib_Model or else
         Debug_Mode
      then
         Write_Str ("Scanning tree files for Context ");
         Write_Int (Int (C));
         Write_Eol;
         if Context_Processing_Mode (C) = All_Trees then

            if Last_Tree_File < First_Tree_File then
               Write_Str ("   no tree file has been found");
               Write_Eol;
            else
               Write_Str ("   the content of the Name Table is:");
               Write_Eol;

               for I in First_Tree_File .. Last_Tree_File loop
                  Get_Name_String (I);
                  Write_Str ("      ");
                  Write_Str (Name_Buffer (1 .. Name_Len));
                  Write_Eol;
               end loop;

            end if;

         else
            Write_Str ("Trees already stored in the tree table:");
            Write_Eol;

            for Tr in First_Tree_Id .. Last_Tree (C) loop
               Get_Name_String (C, Tr);
               Write_Str ("   " & A_Name_Buffer (1 ..  A_Name_Len));
               Write_Eol;
            end loop;

         end if;
      end if;

   end Scan_Tree_Files_New;

   --------------------
   -- Scan_Units_New --
   --------------------

   procedure Scan_Units_New is
      Main_Unit_Id : Unit_Id;
      Next_Unit_Id : Unit_Id;
      Include_Unit : Boolean := False;
   begin

      for N_Unit in Main_Unit .. Lib.Last_Unit loop

         if Atree.Present (Lib.Cunit (N_Unit)) then
            Process_Unit_New (N_Unit);
         end if;

      end loop;

      --  And here we collect compilation dependencies for the main unit in
      --  the tree:

      Namet.Get_Decoded_Name_String (Lib.Unit_Name (Main_Unit));
      Set_Norm_Ada_Name_String_With_Check (Main_Unit, Include_Unit);

      if not Include_Unit then
         return;
      end if;

      Main_Unit_Id := Name_Find (Current_Context);

      for N_Unit in Main_Unit .. Lib.Last_Unit loop

         if Atree.Present (Lib.Cunit (N_Unit)) then

            Namet.Get_Decoded_Name_String (Lib.Unit_Name (N_Unit));
            Set_Norm_Ada_Name_String_With_Check (N_Unit, Include_Unit);

            if Include_Unit then
               Next_Unit_Id := Name_Find (Current_Context);

               Add_To_Elmt_List
                 (Unit => Next_Unit_Id,
                  List =>
                     Unit_Table.Table (Main_Unit_Id).Compilation_Dependencies);
            end if;

         end if;

      end loop;

      Unit_Table.Table (Main_Unit_Id).Main_Tree := Current_Tree;
      Set_Main_Unit_Id (Main_Unit_Id);

   end Scan_Units_New;

   ----------------
   -- Store_Tree --
   ----------------

   procedure Store_Tree (Path : String) is
      New_Tree : Tree_Id;
      --  we do not need it, but Allocate_Tree_Entry is a function...
      pragma Warnings (Off, New_Tree);
   begin
      if Path = "" then
         Set_Name_String (Normalize_Pathname (Name_Buffer (1 .. Name_Len)));
      else
         Set_Name_String
           (Normalize_Pathname
              (Path & Directory_Separator & Name_Buffer (1 .. Name_Len)));
      end if;

      New_Tree := Allocate_Tree_Entry;
   end Store_Tree;

end A4G.Contt.SD;

Add the ASIS file $i

Add the ASIS file $i