------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . G E T _ U N I T                         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2011, 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 GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib;               use GNAT.OS_Lib;

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

with Asis.Set_Get;              use  Asis.Set_Get;

with A4G.A_Debug;               use A4G.A_Debug;
with A4G.A_Opt;                 use A4G.A_Opt;
with A4G.U_Conv;                use A4G.U_Conv;
with A4G.Contt.Dp;              use A4G.Contt.Dp;
with A4G.Contt.SD;              use A4G.Contt.SD;
with A4G.Contt.TT;              use A4G.Contt.TT;
with A4G.Contt.UT;              use A4G.Contt.UT; use A4G.Contt;
with A4G.Defaults;              use A4G.Defaults;
with A4G.GNAT_Int;              use A4G.GNAT_Int;
with A4G.Vcheck;                use A4G.Vcheck;

with Output;                    use Output;

package body A4G.Get_Unit is

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

   function Convert_To_String (Wide_Name : Wide_String) return String;
   --  Takes the name (of a compilation unit) and converts it into String
   --  following the GNAT encoding rules as described in Namet.

   -----------------------
   -- Convert_To_String --
   -----------------------

   function Convert_To_String (Wide_Name : Wide_String) return String is
   begin

      if Is_String (Wide_Name) then
         return To_String (Wide_Name);
      else
         Not_Implemented_Yet ("Wide_Character in Unit name");
      end if;

   end Convert_To_String;

   ----------------------------
   -- Fetch_Unit_By_Ada_Name --
   ----------------------------

   function Fetch_Unit_By_Ada_Name
     (Name      : String;
      Norm_Name : String;
      Context   : Context_Id;
      Spec      : Boolean)
      return Unit_Id
   is
      Result_Unit_Id : Unit_Id;
      Result_Tree    : Tree_Id;

      File_Name : String_Access;
      --  We use File_Name to obtain the source file name according to
      --  the GNAT file name rules (including the krunching rules)

      Predefined : Boolean := False;
      Success    : Boolean := False;

      Source_File  : String_Access;
      --  source to compile, contains all the path information
      Tree_File_N  : String_Access;
      --  tree output file to be retrieved (name)
      Tree_File_D  : File_Descriptor;
      --  tree output file to be retrieved (file descriptor)

      Cont_Tree_Mode : constant Tree_Mode := Tree_Processing_Mode (Context);

      procedure Get_Source_File;
      --  This procedure creates the value of Source_File using the values
      --  of Name and Spec. The procedure first tries to get the file
      --  containing the body regardless of the value of the Spec parameter.
      --  The idea is to get for Spec => True the tree file containing both
      --  the spec and the body of the compilation unit. If we get the tree
      --  file for the spec only, then latter on we may get into
      --  the following problem - the attempt to get the body of the
      --  compilation unit will create the tree file for the body, and
      --  this tree file will have the same name. As a result, all the
      --  references into the tree for spec will become erroneous, and
      --  we will have the problem similar to what was reported as 7504-002.
      --
      --  ??? All this "compile-on-the-fly" Context mode becomes a real
      --  mess. May be, we have to get rid of it???

      procedure Get_Source_File is
      begin
         --  The code is really awfull, but probably it would be better to
         --  get rid of the "compila-on-the-fly" mode, then to polish
         --  the code.

         File_Name := Source_From_Unit_Name (Name, False);
         --  if needed, the name is krunched here (??? may be, we can already
         --  forget about systems with the limitations on the file name
         --  length???)
         --  Note also, that ASIS cannot work with files which names override
         --  the standard GNAT file name convention as a result of
         --  Source_File_Name pragma.

         Source_File := Locate_In_Search_Path
                          (C         => Context,
                           File_Name => To_String (File_Name),
                           Dir_Kind  => Source);

         if Source_File = null then
            Source_File := Locate_Default_File
                             (File_Name => File_Name,
                              Dir_Kind  => Source);
         end if;

         if Source_File /= null then
            return;
         elsif Spec then
            File_Name := Source_From_Unit_Name (Name, True);

            Source_File := Locate_In_Search_Path
                             (C         => Context,
                              File_Name => To_String (File_Name),
                              Dir_Kind  => Source);

            if Source_File = null then
               Source_File := Locate_Default_File
                                (File_Name => File_Name,
                                 Dir_Kind  => Source);
            end if;

         end if;

         if Source_File = null and then
            Is_Predefined_File_Name (File_Name)
            --  not GNAT, but ASIS Is_Predefined_File_Name function is called
            --  here!
         then
            --  if File_Name is the name of a predefined unit, we shall try
            --  the default source search path. See also
            --  A4G.Contt.Set_Predefined_Units
            File_Name := Source_From_Unit_Name (Name, False);
            Predefined  := True;
            Source_File := Locate_Default_File (File_Name, Source);

            if Source_File = null then
               File_Name := Source_From_Unit_Name (Name, True);
               Source_File := Locate_Default_File (File_Name, Source);
            end if;

         end if;

      end Get_Source_File;

   begin
      --  we start from looking for a unit in the Unit Name Table
      Set_Name_String (Norm_Name);
      Result_Unit_Id := Name_Find (Context);

      if Result_Unit_Id /= Nil_Unit then
         return Result_Unit_Id;
      elsif Cont_Tree_Mode = Pre_Created then
         if Norm_Name = "standard%s" then
            --  For Standard, we have to search twice - first for possible
            --  redefinition of Standard, then - for predefined Standard
            return Standard_Id;
         else
            return Nil_Unit;
         end if;
      end if;

      if Spec then
         --  The idea is to avoid non-needed recompilations in case if we
         --  already have the (tree for the) corresponding body, see F823-027.
         A_Name_Buffer (A_Name_Len) := 'b';
         Result_Unit_Id := Name_Find (Context);

         if Result_Unit_Id /= Nil_Unit then
            return Nil_Unit;
         end if;

      end if;

      --  We can be here only if Context was associated in On_The_Fly or Mixed
      --  tree processing mode mode, and we have failed to find the required
      --  unit among units which are already known to ASIS. Therefore, we
      --  have to (try to) create the tree by compiling the source:

      Get_Source_File;

      if Source_File = null then
         if Debug_Mode then
            Write_Str ("Fetch_Unit_By_Ada_Name: cannot locate a source file ");
            Write_Str ("for " & Name);
            Write_Eol;
         end if;

         return Nil_Unit;
      end if;

      --  And trying to compile - Source_File contains the reference
      --  to the existing source file which has been already successfully
      --  located in the Context:

      if Debug_Mode then
         Write_Str ("Fetch_Unit_By_Ada_Name: "
                  & "Trying to create a tree on the fly:");
         Write_Eol;
         Write_Str ("Source file is " & To_String (Source_File));
         Write_Eol;
      end if;

      Create_Tree (Source_File   => Source_File,
                   Context       => Context,
                   Is_Predefined => Predefined,
                   Success       => Success);

      if not Success then

         if Debug_Mode then
            Write_Str ("Failure...");
            Write_Eol;
         end if;

         return Nil_Unit;
      end if;

      if Debug_Mode then
         Write_Str ("Success...");
         Write_Eol;
      end if;

      --  here we have a new tree, successfully created just here. We will
      --  read it in, then we will investigate it just in the same way as
      --  during opening a Context and then we look into the unit table for
      --  the needed unit again

      Tree_File_N := Tree_From_Source_Name (File_Name);
      --  ??? IT WOULD BE BETTER TO USE STRIP_DIRECTORY (SOURCE_FILE)
      --  INSTEAD OF FILE_NAME HERE!!!!!

      Tree_File_D := Open_Read (Tree_File_N.all'Address, Binary);

      begin
         if Debug_Mode then
            Write_Str ("Fetch_Unit_By_Ada_Name: trying to read in a tree...");
            Write_Eol;
         end if;

         Tree_In_With_Version_Check (Tree_File_D, Context, Success);

         if Success then

            if Debug_Mode then
               Write_Str ("Fetch_Unit_By_Ada_Name: a tree is read in...");
               Write_Eol;
            end if;

         else
            --  This should never happen!

            Set_Error_Status
              (Status    => Asis.Errors.Use_Error,
               Diagnosis => "A4G.Get_Unit.Fetch_Unit_By_Ada_Name:"
               &  ASIS_Line_Terminator
               & "problems reading tree file "
               & To_String (Tree_File_N));

            raise ASIS_Failed;
         end if;

      exception
         when Program_Error |
              ASIS_Failed   =>

            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 ("A4G.Get_Unit.Fetch_Unit_By_Ada_Name:");
               Write_Eol;
               Write_Str ("Cannot read the tree file ");
               Write_Str (To_String (Tree_File_N));
               Write_Str (" newly created for a source file ");
               Write_Str (To_String (Source_File));
               Write_Eol;
            end if;

            Report_ASIS_Bug
              (Query_Name  => "A4G.Get_Unit.Fetch_Unit_By_Ada_Name" &
                              " (tree file " & To_String (Tree_File_N) & ")",
               Ex          => Ex);
      end;

      Set_Name_String (To_String (Tree_File_N));
      Set_Current_Cont (Context);
      Result_Tree := Allocate_Tree_Entry;
      Set_Current_Tree (Result_Tree);

      --  here we have to investigate the newly created tree:

      if Tree_Processing_Mode (Context) = Incremental then

         begin
            NB_Save;
            Register_Units (Set_First_New_Unit => True);
            Scan_Units_New;

            Set_All_Dependencies (Use_First_New_Unit => True);

            Reorder_Trees (Context);
         exception

            when Inconsistent_Incremental_Context =>
               --  Erase the old Context information
               Increase_ASIS_OS_Time;
               Pre_Initialize (Context);
               A4G.Contt.Initialize (Context);

               --  We still have one good tree
               Result_Tree := Allocate_Tree_Entry;
               NB_Restore;
               Set_Current_Tree (Result_Tree);

               --  And we have to extract the information from this tree
               Register_Units;
               Scan_Units_New;
               Set_All_Dependencies;
         end;

      else
         --  For old "on the fly" and mixed mode no enhansment
         Register_Units;
         Scan_Units_New;
      end if;

      --  and now - the final attempt to get the needed unit. We have to reset
      --  the name buffer - it may be changed by Scan_Units_New:
      Set_Name_String (Norm_Name);
      Result_Unit_Id := Name_Find (Context);

      if Result_Unit_Id = Nil_Unit
        and then
         Norm_Name = "standard%s"
      then
         --  For Standard, we have to search twice - first for possible
         --  redefinition of Standard, then - for predefined Standard
         Result_Unit_Id := Standard_Id;
      end if;

      return Result_Unit_Id;

   end Fetch_Unit_By_Ada_Name;

   -----------------------------------
   -- Get_Main_Unit_Tree_On_The_Fly --
   -----------------------------------

   function Get_Main_Unit_Tree_On_The_Fly
     (Start_Unit : Unit_Id;
      Cont       : Context_Id;
      Spec       : Boolean)
      return       Unit_Id
   is
      Start_CU : constant Asis.Compilation_Unit :=
        Get_Comp_Unit (Start_Unit, Cont);

      Result_Unit_Id : Unit_Id;
      Result_Tree    : Tree_Id;

      File_Name : String_Access;
      --  We use File_Name to obtain the source file name according to
      --  the GNAT file name rules (including the krunching rules)

      Predefined : Boolean := False;
      Success    : Boolean := False;

      S_File_To_Compile : String_Access;
      --  source to compile, contains all the path information

      Tmp_S_File, Tmp_S_File1 : String_Access;

      Tree_File_N  : String_Access;
      --  tree output file to be retrieved (name)
      Tree_File_D  : File_Descriptor;
      --  tree output file to be retrieved (file descriptor)

      procedure Get_Source_File_To_Compile;
      --  This procedure creates the value of Source_File using the values
      --  of Start_Unit and Spec. If Spec is ON, the full source name of
      --  Start_Unit is used. If Spec is OFF, we try to create the source
      --  file name from the unit name by applying the standard GNAT file
      --  naming rules. This is the weak point of the implementation, because
      --  this does not wor for non-standard names

      procedure Get_Source_File_To_Compile is
      begin

         if Spec then
            S_File_To_Compile :=
               new String'(Source_File (Start_CU) & ASCII.NUL);
         else
            --  The first thing to do is to try to locate the file with the
            --  name computed on the base of the standard GNAT name rules

            File_Name := Source_From_Unit_Name (Unit_Name (Start_CU), False);

            S_File_To_Compile := Locate_In_Search_Path
                             (C         => Cont,
                              File_Name => To_String (File_Name),
                              Dir_Kind  => Source);

            if  S_File_To_Compile = null then
               --  Two possibilities:
               --  - Start_Unit is a predefined unit
               --  - Try to convert spec name into unit body name and to
               --    locate it

               Tmp_S_File := new String'(Source_File (Start_CU));

               Tmp_S_File (Tmp_S_File'Last) := 'b';

               Tmp_S_File1 := new String'(Base_Name (Tmp_S_File.all));

               if not Is_Predefined_File_Name (Tmp_S_File1) then

                  S_File_To_Compile := Locate_In_Search_Path
                                   (C         => Cont,
                                    File_Name => Tmp_S_File.all,
                                    Dir_Kind  => Source);
               else
                  Predefined        := True;
                  S_File_To_Compile :=
                     Locate_Default_File (Tmp_S_File, Source);
               end if;

            end if;

         end if;

      end Get_Source_File_To_Compile;

   begin

      Get_Source_File_To_Compile;

      if S_File_To_Compile = null then
         if Debug_Mode then
            Write_Str ("Get_Main_Unit_Tree_On_The_Fly: cannot create a main ");
            Write_Str ("tree for " & Unit_Name (Start_CU));
            Write_Eol;
         end if;

         return Nil_Unit;
      end if;

      --  Now we try to compile - Source_File contains the reference
      --  to the existing source file which has been already successfully
      --  located in the Context:

      if Debug_Mode then
         Write_Str ("Get_Main_Unit_Tree_On_The_Fly: "
                  & "Trying to create a main tree on the fly:");
         Write_Eol;
         Write_Str ("Source file is " & S_File_To_Compile.all);
         Write_Eol;
      end if;

      Create_Tree (Source_File   => S_File_To_Compile,
                   Context       => Cont,
                   Is_Predefined => Predefined,
                   Success       => Success);

      if not Success then

         if Debug_Mode then
            Write_Str ("Failure...");
            Write_Eol;
         end if;

         return Nil_Unit;
      end if;

      if Debug_Mode then
         Write_Str ("Success...");
         Write_Eol;
      end if;

      --  Now we have a new tree, successfully created just here. We have to
      --  add it to the incremental Context

      Tree_File_N := new String'(Base_Name (S_File_To_Compile.all));

      Tree_File_N (Tree_File_N'Last - 1) := 't';
      --  ??? What about non-standart file names????

      Tree_File_D := Open_Read (Tree_File_N.all'Address, Binary);

      begin
         if Debug_Mode then
            Write_Str ("Get_Main_Unit_Tree_On_The_Fly: read in a tree...");
            Write_Eol;
         end if;

         Tree_In_With_Version_Check (Tree_File_D, Cont, Success);

         if Success then

            if Debug_Mode then
               Write_Str ("Get_Main_Unit_Tree_On_The_Fly: done...");
               Write_Eol;
            end if;

         else
            --  This should never happen!

            Set_Error_Status
              (Status    => Asis.Errors.Use_Error,
               Diagnosis => "A4G.Get_Unit.Get_Main_Unit_Tree_On_The_Fly:"
               &  ASIS_Line_Terminator
               & "problems reading tree file "
               & To_String (Tree_File_N));

            raise ASIS_Failed;
         end if;

      exception
         when Program_Error |
              ASIS_Failed   =>

            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 ("A4G.Get_Unit.Get_Main_Unit_Tree_On_The_Fly:");
               Write_Eol;
               Write_Str ("Cannot read the tree file ");
               Write_Str (To_String (Tree_File_N));
               Write_Str (" newly created for a source file ");
               Write_Str (S_File_To_Compile.all);
               Write_Eol;
            end if;

            Report_ASIS_Bug
              (Query_Name  => "A4G.Get_Unit.Get_Main_Unit_Tree_On_The_Fly" &
                              " (tree file " & To_String (Tree_File_N) & ")",
               Ex          => Ex);
      end;

      Set_Name_String (To_String (Tree_File_N));

      Set_Current_Cont (Cont);
      Result_Tree := Allocate_Tree_Entry;
      Set_Current_Tree (Result_Tree);

      --  here we have to investigate the newly created tree:

      begin
         NB_Save;
         Register_Units (Set_First_New_Unit => True);
         Scan_Units_New;

         Set_All_Dependencies (Use_First_New_Unit => True);

         Reorder_Trees (Cont);
      exception

         when Inconsistent_Incremental_Context =>
            --  Erase the old Context information
            Increase_ASIS_OS_Time;
            Pre_Initialize (Cont);
            A4G.Contt.Initialize (Cont);

            --  We still have one good tree
            Result_Tree := Allocate_Tree_Entry;
            NB_Restore;
            Set_Current_Tree (Result_Tree);

            --  And we have to extract the information from this tree
            Register_Units;
            Scan_Units_New;
            Set_All_Dependencies;
      end;

      --  and now - forming the result Unit_Id

      if Spec then
         Result_Unit_Id := Start_Unit;
      else
         Result_Unit_Id :=  Get_Body (Cont, Start_Unit);
      end if;

      return Result_Unit_Id;

   end Get_Main_Unit_Tree_On_The_Fly;

   ------------------
   -- Get_One_Unit --
   ------------------

   function Get_One_Unit
     (Name    : Wide_String;
      Context : Context_Id;
      Spec    : Boolean)
      return Unit_Id
   is
      Unit_Name      : constant String := Convert_To_String (Name);
      Name_Length    : constant Natural                   := Unit_Name'Length;
      Norm_Unit_Name : String (1 .. Name_Length + 2); -- "+ 2" for %(s|b)

      Result_Id      : Unit_Id;

      Is_Unit_Name   : Boolean := False;

   begin

      --  first of all, we have to check if Name can really be
      --  treated as Ada unit name:

      if Name_Length = 0 then
         return Nil_Unit;
      end if;

      Get_Norm_Unit_Name (U_Name           => Unit_Name,
                          N_U_Name         => Norm_Unit_Name,
                          Spec             => Spec,
                          May_Be_Unit_Name => Is_Unit_Name);

      if not Is_Unit_Name then
         return Nil_Unit;
      end if;

      --  Now we are sure that Name has the syntax structure of the Ada
      --  unit name, and we have to check whether ASIS has already got
      --  to know about this unit in its Unit Table, Norm_Unit_Name has
      --  already been prepared for the corresponding search in the
      --  Unit Table. If this check fails, we will
      --  have to try to compile the Unit from its source:
      Result_Id := Fetch_Unit_By_Ada_Name
                        (Name      => Unit_Name,
                         Norm_Name => Norm_Unit_Name,
                         Context   => Context,
                         Spec      => Spec);

      return Result_Id;

   end Get_One_Unit;

end A4G.Get_Unit;

Add the ASIS file $i

Add the ASIS file $i


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

package body Babel.Filters is

   use type Ada.Directories.File_Kind;

   --  ------------------------------
   --  Return True if the file or directory is accepted by the filter.
   --  ------------------------------
   overriding
   function Is_Accepted (Filter : in Exclude_Directory_Filter_Type;
                         Kind   : in Ada.Directories.File_Kind;
                         Path   : in String;
                         Name   : in String) return Boolean is
   begin
      if Kind /= Ada.Directories.Directory then
         return True;
      end if;
      if Filter.Excluded.Contains (Name) then
         return False;
      end if;
      return True;
   end Is_Accepted;

   --  ------------------------------
   --  Add the given path to the list of excluded directories.
   --  ------------------------------
   procedure Add_Exclude (Filter : in out Exclude_Directory_Filter_Type;
                          Path   : in String) is
   begin
      Filter.Excluded.Include (Path);
   end Add_Exclude;

end Babel.Filters;

Backup filter implementation

Backup filter implementation


-----------------------------------------------------------------------
--  util-texts-builders -- Text builder
--  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 Ada.Unchecked_Deallocation;

package body Util.Texts.Builders is

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

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

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

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

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

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

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

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

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

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

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

end Util.Texts.Builders;

Implement the new package

Implement the new package


-----------------------------------------------------------------------
--  security-oauth-jwt -- OAuth Java Web Token
--  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 Ada.Calendar.Conversions;
with Interfaces.C;

with Util.Encoders;
with Util.Strings;
with Util.Properties.JSON;
with Util.Log.Loggers;
package body Security.OAuth.JWT is

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

   function Get_Time (From : in Util.Properties.Manager;
                      Name : in String) return Ada.Calendar.Time;

   --  Decode the part using base64url and parse the JSON content into the property manager.
   procedure Decode_Part (Into : in out Util.Properties.Manager;
                          Name : in String;
                          Data : in String);

   function Get_Time (From : in Util.Properties.Manager;
                      Name : in String) return Ada.Calendar.Time is
      Value : constant String := From.Get (Name);
   begin
      return Ada.Calendar.Conversions.To_Ada_Time (Interfaces.C.long'Value (Value));
   end Get_Time;

   --  ------------------------------
   --  Get the issuer claim from the token (the "iss" claim).
   --  ------------------------------
   function Get_Issuer (From : in Token) return String is
   begin
      return From.Claims.Get ("iss");
   end Get_Issuer;

   --  ------------------------------
   --  Get the subject claim from the token (the "sub" claim).
   --  ------------------------------
   function Get_Subject (From : in Token) return String is
   begin
      return From.Claims.Get ("sub");
   end Get_Subject;

   --  ------------------------------
   --  Get the audience claim from the token (the "aud" claim).
   --  ------------------------------
   function Get_Audience (From : in Token) return String is
   begin
      return From.Claims.Get ("aud");
   end Get_Audience;

   --  ------------------------------
   --  Get the expiration claim from the token (the "exp" claim).
   --  ------------------------------
   function Get_Expiration (From : in Token) return Ada.Calendar.Time is
   begin
      return Get_Time (From.Claims, "exp");
   end Get_Expiration;

   --  ------------------------------
   --  Get the not before claim from the token (the "nbf" claim).
   --  ------------------------------
   function Get_Not_Before (From : in Token) return Ada.Calendar.Time is
   begin
      return Get_Time (From.Claims, "nbf");
   end Get_Not_Before;

   --  ------------------------------
   --  Get the issued at claim from the token (the "iat" claim).
   --  ------------------------------
   function Get_Issued_At (From : in Token) return Ada.Calendar.Time is
   begin
      return Get_Time (From.Claims, "iat");
   end Get_Issued_At;

   --  ------------------------------
   --  Get the authentication time claim from the token (the "auth_time" claim).
   --  ------------------------------
   function Get_Authentication_Time (From : in Token) return Ada.Calendar.Time is
   begin
      return Get_Time (From.Claims, "auth_time");
   end Get_Authentication_Time;

   --  ------------------------------
   --  Get the JWT ID claim from the token (the "jti" claim).
   --  ------------------------------
   function Get_JWT_ID (From : in Token) return String is
   begin
      return From.Claims.Get ("jti");
   end Get_JWT_ID;

   --  ------------------------------
   --  Get the authorized clients claim from the token (the "azp" claim).
   --  ------------------------------
   function Get_Authorized_Presenters (From : in Token) return String is
   begin
      return From.Claims.Get ("azp");
   end Get_Authorized_Presenters;

   --  ------------------------------
   --  Get the claim with the given name from the token.
   --  ------------------------------
   function Get_Claim (From : in Token;
                       Name : in String) return String is
   begin
      return From.Claims.Get (Name);
   end Get_Claim;

   --  ------------------------------
   --  Decode the part using base64url and parse the JSON content into the property manager.
   --  ------------------------------
   procedure Decode_Part (Into : in out Util.Properties.Manager;
                          Name : in String;
                          Data : in String) is
      Decoder : constant Util.Encoders.Encoder := Util.Encoders.Create (Util.Encoders.BASE_64_URL);
      Content : constant String := Decoder.Decode (Data);
   begin
      Log.Debug ("Decoding {0}: {1}", Name, Content);

      Util.Properties.JSON.Parse_JSON (Into, Content);
   end Decode_Part;

   --  ------------------------------
   --  Decode a string representing an encoded JWT token according to the JWT specification:
   --
   --    Section 7.  Rules for Creating and Validating a JWT
   --
   --  The JWT token is composed of 3 parts encoded in Base64url and separated by '.' .
   --  The first part represents the header, the second part the claims and the last part
   --  the signature.  The <tt>Decode</tt> operation splits the parts, decodes them,
   --  parses the JSON content represented by the header and the claims.
   --  The <tt>Decode</tt> operation does not verify the signature (yet!).
   --
   --  Return the decoded token or raise an exception.
   --  ------------------------------
   function Decode (Content : in String) return Token is
      Pos1   : constant Natural := Util.Strings.Index (Content, '.');
      Pos2   : Natural;
      Result : Token;
   begin
      if Pos1 = 0 then
         Log.Error ("Invalid JWT token: missing '.' separator. JWT: {0}", Content);
         raise Invalid_Token with "Missing header separator";
      end if;
      Pos2 := Util.Strings.Index (Content, '.', Pos1 + 1);
      if Pos2 = 0 then
         Log.Error ("Invalid JWT token: missing second '.' separator. JWT: {0}", Content);
         raise Invalid_Token with "Missing signature separator";
      end if;
      Decode_Part (Result.Header, "header", Content (Content'First .. Pos1 - 1));
      Decode_Part (Result.Claims, "claims", Content (Pos1 + 1 .. Pos2 - 1));
      return Result;
   end Decode;

end Security.OAuth.JWT;

Implement the JWT decoding and extraction


-----------------------------------------------------------------------
--  Render Tests - Unit tests for AWA Wiki rendering
--  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 Ada.Text_IO;
with Ada.Directories;
with Ada.Characters.Conversions;

with Util.Files;
with Util.Measures;
package body AWA.Wikis.Writers.Tests is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Test rendering a wiki text in HTML or text.
   --  ------------------------------
   procedure Test_Render (T : in out Test) is
      function To_Wide (Item : in String) return Wide_Wide_String
        renames Ada.Characters.Conversions.To_Wide_Wide_String;

      Result_File : constant String := To_String (T.Result);
      Content     : Unbounded_String;
   begin
      Util.Files.Read_File (Path     => To_String (T.File),
                            Into     => Content,
                            Max_Size => 10000);
      declare
         Time : Util.Measures.Stamp;
      begin
         if T.Is_Html then
            Content := To_Unbounded_String
              (Writers.To_Html (To_Wide (To_String (Content)), T.Format));
         else
            Content := To_Unbounded_String
              (Writers.To_Text (To_Wide (To_String (Content)), T.Format));
         end if;

         Util.Measures.Report (Time, "Render " & To_String (T.Name));
      end;

      Util.Files.Write_File (Result_File, Content);
      Util.Tests.Assert_Equal_Files (T       => T,
                                     Expect  => To_String (T.Expect),
                                     Test    => Result_File,
                                     Message => "Render");
   end Test_Render;

   --  ------------------------------
   --  Test case name
   --  ------------------------------
   overriding
   function Name (T : in Test) return Util.Tests.Message_String is
   begin
      if T.Is_Html then
         return Util.Tests.Format ("Test HTML " & To_String (T.Name));
      else
         return Util.Tests.Format ("Test TEXT " & To_String (T.Name));
      end if;
   end Name;

   --  ------------------------------
   --  Perform the test.
   --  ------------------------------
   overriding
   procedure Run_Test (T : in out Test) is
   begin
      T.Test_Render;
   end Run_Test;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      use Ada.Directories;
      function Create_Test (Name : in String; Is_Html : in Boolean) return Test_Case_Access;

      Result_Dir  : constant String := "regtests/result";
      Dir         : constant String := "regtests/files/wiki";
      Expect_Dir  : constant String := "regtests/expect";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      Expect_Path : constant String := Util.Tests.Get_Path (Expect_Dir);
      Result_Path : constant String := Util.Tests.Get_Test_Path (Result_Dir);
      Search      : Search_Type;
      Filter      : constant Filter_Type := (others => True);
      Ent         : Directory_Entry_Type;

      function Create_Test (Name : in String; Is_Html : in Boolean) return Test_Case_Access is
         Ext    : constant String := Ada.Directories.Extension (Name);
         Tst    : Test_Case_Access;
      begin
         Tst := new Test;
         Tst.Is_Html := Is_Html;
         Tst.Name    := To_Unbounded_String (Name);
         Tst.File    := To_Unbounded_String (Path & "/" & Name);
         if Is_Html then
            Tst.Expect  := To_Unbounded_String (Expect_Path & "/wiki-html/" & Name);
            Tst.Result  := To_Unbounded_String (Result_Path & "/wiki-html/" & Name);
         else
            Tst.Expect  := To_Unbounded_String (Expect_Path & "/wiki-txt/" & Name);
            Tst.Result  := To_Unbounded_String (Result_Path & "/wiki-txt/" & Name);
         end if;
         if Ext = "wiki" then
            Tst.Format := AWA.Wikis.Parsers.SYNTAX_GOOGLE;
         elsif Ext = "dotclear" then
            Tst.Format := AWA.Wikis.Parsers.SYNTAX_DOTCLEAR;
         elsif Ext = "creole" then
            Tst.Format := AWA.Wikis.Parsers.SYNTAX_CREOLE;
         elsif Ext = "phpbb" then
            Tst.Format := AWA.Wikis.Parsers.SYNTAX_PHPBB;
         elsif Ext = "mediawiki" then
            Tst.Format := AWA.Wikis.Parsers.SYNTAX_MEDIA_WIKI;
         else
            Tst.Format := AWA.Wikis.Parsers.SYNTAX_MIX;
         end if;
         return Tst;
      end Create_Test;

   begin
      if Kind (Path) /= Directory then
         Ada.Text_IO.Put_Line ("Cannot read test directory: " & Path);
      end if;

      Start_Search (Search, Directory => Path, Pattern => "*.*", Filter => Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            Simple : constant String := Simple_Name (Ent);
            Tst    : Test_Case_Access;
         begin
            if Simple /= "." and then Simple /= ".."
              and then Simple /= ".svn" then
               Tst := Create_Test (Simple, True);
               Suite.Add_Test (Tst.all'Access);

               Tst := Create_Test (Simple, False);
               Suite.Add_Test (Tst.all'Access);
            end if;
         end;
      end loop;
   end Add_Tests;

end AWA.Wikis.Writers.Tests;

Implement the new wiki unit tests

Implement the new wiki unit tests


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                A S I S . A D A _ E N V I R O N M E N T S                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2008, 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.adaccore.com).                                               --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Strings;             use Ada.Strings;
with Ada.Strings.Fixed;       use Ada.Strings.Fixed;

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

with Asis.Set_Get;            use Asis.Set_Get;

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.Contt.TT;            use A4G.Contt.TT;
with A4G.Contt.UT;            use A4G.Contt.UT;
with A4G.Vcheck;              use A4G.Vcheck;

with Output;                  use Output;

package body Asis.Ada_Environments is

   Package_Name : constant String := "Asis.Ada_Environments.";

   ---------------
   -- Associate --
   ---------------

   procedure Associate
     (The_Context : in out Asis.Context;
      Name        :        Wide_String;
      Parameters  :        Wide_String := Default_Parameters)
   is
      S_Parameters : constant String := Trim (To_String (Parameters), Both);
      Cont         :          Context_Id;
   begin

      Cont := Get_Cont_Id (The_Context);

      if not A4G.A_Opt.Is_Initialized then

         Set_Error_Status
           (Status    => Initialization_Error,
            Diagnosis => Package_Name & "Associate: "
                       & "called for non-initialized ASIS");

         raise ASIS_Failed;

      end if;

      if Is_Opened (Cont) then
         Set_Error_Status
           (Status    => Value_Error,
            Diagnosis => Package_Name & "Associate: "
                       & "the Context has already been opened");
         raise ASIS_Inappropriate_Context;
      end if;

      if Cont = Non_Associated then
         --  this is the first association for a given Context
         Cont := Allocate_New_Context;
         Set_Cont (The_Context, Cont);
      else
         Erase_Old (Cont);
      end if;

      Verify_Context_Name (To_String (Name), Cont);
      Process_Context_Parameters (S_Parameters, Cont);

      Set_Is_Associated (Cont, True);

      Save_Context (Cont);
      Set_Current_Cont (Nil_Context_Id);

   exception
      when ASIS_Inappropriate_Context =>
         Set_Is_Associated (Cont, False);
         raise;
      when ASIS_Failed =>
         Set_Is_Associated (Cont, False);

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name & "Associate");
         end if;

         raise;
      when Ex : others =>
         Set_Is_Associated (Cont, False);

         Report_ASIS_Bug
           (Query_Name => Package_Name & "Associate",
            Ex         => Ex);
   end Associate;

   -----------
   -- Close --
   -----------

   procedure Close (The_Context : in out Asis.Context) is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      Reset_Context (Cont);

      if not Is_Opened (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => Package_Name & "Close: " &
                           "the Context is not open");
         raise ASIS_Inappropriate_Context;
      end if;

      if Debug_Flag_C    or else
         Debug_Lib_Model or else
         Debug_Mode
      then
         Write_Str ("Closing Context ");
         Write_Int (Int (Cont));
         Write_Eol;
         Print_Units (Cont);
         Print_Trees (Cont);
      end if;

      Set_Is_Opened (Cont, False);

      Set_Current_Cont (Nil_Context_Id);

      Reset_Cache;

   exception
      when ASIS_Inappropriate_Context =>
         raise;
      when ASIS_Failed =>
         Set_Current_Cont (Nil_Context_Id);

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name &  "Close");
         end if;

         raise;
      when Ex : others =>
         Set_Current_Cont (Nil_Context_Id);
         Report_ASIS_Bug
           (Query_Name => Package_Name & "Associate",
            Ex         => Ex);
   end Close;

   -----------------
   -- Debug_Image --
   -----------------

   function Debug_Image
     (The_Context : Asis.Context)
      return        Wide_String
   is
      Arg_Cont : Context_Id;
      LT       : Wide_String renames A4G.A_Types.Asis_Wide_Line_Terminator;
   begin
      Arg_Cont := Get_Cont_Id (The_Context);
      Reset_Context (Arg_Cont);

      return LT & "Context Debug_Image: " &
             LT & "Context Id is" &
             Context_Id'Wide_Image (Arg_Cont) &
             LT & To_Wide_String (Debug_String (The_Context));
   exception
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name => Package_Name & "Debug_Image",
           Ex         => Ex);
   end Debug_Image;

   ------------------
   -- Default_Name --
   ------------------

   function Default_Name return Wide_String is
   begin
      return Nil_Asis_Wide_String;
   end Default_Name;

   ------------------------
   -- Default_Parameters --
   ------------------------

   function Default_Parameters return Wide_String is
   begin
      return Nil_Asis_Wide_String;
   end Default_Parameters;

   ----------------
   -- Dissociate --
   ----------------

   procedure Dissociate (The_Context : in out Asis.Context) is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);

      if Is_Opened (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => Package_Name & "Dissociate: "
                                      & "the Context is open");
         raise ASIS_Inappropriate_Context;
      end if;

      if Debug_Flag_C    or else
         Debug_Lib_Model or else
         Debug_Mode
      then
         Write_Str ("Dissociating Context ");
         Write_Int (Int (Cont));
         Write_Eol;
         Print_Context_Parameters (Cont);
      end if;

      if Is_Associated (Cont) then
         Erase_Old (Cont);
         Set_Is_Associated (Cont, False);
      end if;

   exception
      when ASIS_Inappropriate_Context =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name & "Dissociate");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name => Package_Name & "Dissociate",
            Ex         => Ex);
   end Dissociate;

   ------------
   -- Exists --
   ------------

   function Exists (The_Context : Asis.Context) return Boolean is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return Is_Associated (Cont);
   end Exists;

   ----------------------
   -- Has_Associations --
   ----------------------

   function Has_Associations
     (The_Context : Asis.Context)
      return        Boolean
   is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return Is_Associated (Cont);
   end Has_Associations;

   --------------
   -- Is_Equal --
   --------------

   function Is_Equal
     (Left  : Asis.Context;
      Right : Asis.Context)
      return  Boolean
   is
   begin
      return Get_Cont_Id (Left) = Get_Cont_Id (Right);
      --  Should be revised
   end Is_Equal;

   ------------------
   -- Is_Identical --
   ------------------

   function Is_Identical
     (Left  : Asis.Context;
      Right : Asis.Context)
      return  Boolean
   is
   begin
      return Get_Cont_Id (Left) = Get_Cont_Id (Right);
   end Is_Identical;

   -------------
   -- Is_Open --
   -------------

   function Is_Open (The_Context : Asis.Context) return Boolean is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return Is_Opened (Cont);
   end Is_Open;

   ----------
   -- Name --
   ----------

   function Name (The_Context : Asis.Context) return Wide_String is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return  To_Wide_String (Get_Context_Name (Cont));
   end Name;

   ----------
   -- Open --
   ----------

   procedure Open (The_Context : in out Asis.Context) is
      Cont              : Context_Id;
      Context_Tree_Mode : Tree_Mode;
   begin
      Cont := Get_Cont_Id (The_Context);

      if not Is_Associated (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => Package_Name & "Open: " &
                           "the Context does not have association");
         raise ASIS_Inappropriate_Context;
      elsif Is_Opened (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => Package_Name & "Open: " &
                           "the Context has already been opened");
         raise ASIS_Inappropriate_Context;
      end if;

      Reset_Context (Cont);
      Context_Tree_Mode := Tree_Processing_Mode (Cont);

      if Tree_Processing_Mode (Cont) = GNSA then
         Set_Error_Status (Status    => Use_Error,
                           Diagnosis => Package_Name & "Open: " &
                           "GNSA Context mode is not allowed");
         raise ASIS_Inappropriate_Context;
      end if;

      Increase_ASIS_OS_Time;

      Pre_Initialize (Cont);
      A4G.Contt.Initialize (Cont);
      --  Having these two Pre_Initialize and A4G.Contt.Initialize calling
      --  one after another is a kind of junk, but there are some problems
      --  with multi-context processing which have not been completely
      --  detected and which does not allow to get rid of this definitely
      --  redundunt "initialization"

      case Context_Tree_Mode is
         when Pre_Created | Mixed =>
            Scan_Trees_New (Cont);

         when Incremental =>

            --  Not the best approach, unfortunately
            begin
               Scan_Trees_New (Cont);
            exception
               when Inconsistent_Incremental_Context =>
                  --  Setting empty incremental context:
                  Pre_Initialize (Cont);
                  A4G.Contt.Initialize (Cont);
            end;

         when others =>
            null;
      end case;

      Set_Is_Opened (Cont, True);

      Save_Context (Cont);

      Set_Current_Cont (Nil_Context_Id);

   exception
      when Program_Error =>
         raise;
      when ASIS_Inappropriate_Context =>
         raise;
      when ASIS_Failed =>
         Set_Is_Opened (Cont, False);
         Set_Current_Cont (Nil_Context_Id);

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name & "Open");
         end if;

         raise;
      when Ex : others =>
         Set_Is_Opened (Cont, False);
         Set_Current_Cont (Nil_Context_Id);

         Report_ASIS_Bug
           (Query_Name => Package_Name & "Open",
            Ex         => Ex);
   end Open;

   ----------------
   -- Parameters --
   ----------------

   function Parameters (The_Context : Asis.Context) return Wide_String is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return  To_Wide_String (Get_Context_Parameters (Cont));
   end Parameters;

end Asis.Ada_Environments;

Add the ASIS file $i

Add the ASIS file $i


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

with Util.Systems.Os;
with Util.Streams.Texts;
with Util.Streams.Pipes;
package body Util.Processes.Tools is

   --  ------------------------------
   --  Execute the command and append the output in the vector array.
   --  The program output is read line by line and the standard input is closed.
   --  Return the program exit status.
   --  ------------------------------
   procedure Execute (Command : in String;
                      Output  : in out Util.Strings.Vectors.Vector;
                      Status  : out Integer) is
      Proc    : aliased Util.Streams.Pipes.Pipe_Stream;
      Text    : Util.Streams.Texts.Reader_Stream;
   begin
      Proc.Add_Close (Util.Systems.Os.STDIN_FILENO);
      Text.Initialize (Proc'Unchecked_Access);
      Proc.Open (Command, Util.Processes.READ);
      while not Text.Is_Eof loop
         declare
            Line : Ada.Strings.Unbounded.Unbounded_String;
         begin
            Text.Read_Line (Line, Strip => True);
            exit when Ada.Strings.Unbounded.Length (Line) = 0;
            Output.Append (Ada.Strings.Unbounded.To_String (Line));
         end;
      end loop;
      Proc.Close;
      Status := Proc.Get_Exit_Status;
   end Execute;

end Util.Processes.Tools;

Implement the Execute procedure

Implement the Execute procedure


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


-----------------------------------------------------------------------
--  akt-commands-info -- Info command to describe the current configuration
--  Copyright (C) 2020 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 GNAT.Command_Line;
with AWA.Commands.Drivers;
with AWA.Applications;
with AWA.Modules;
with ASF.Locales;
generic
   with package Command_Drivers is new AWA.Commands.Drivers (<>);
package AWA.Commands.Info is

   type Command_Type is new Command_Drivers.Application_Command_Type with record
      Bundle        : ASF.Locales.Bundle;
      Long_List     : aliased Boolean := False;
      Value_Length  : Positive := 50;
   end record;

   --  Print the configuration about the application.
   overriding
   procedure Execute (Command     : in out Command_Type;
                      Application : in out AWA.Applications.Application'Class;
                      Args        : in Argument_List'Class;
                      Context     : in out Context_Type);

   --  Setup the command before parsing the arguments and executing it.
   overriding
   procedure Setup (Command : in out Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in out Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type);

   --  Print the configuration identified by the given name.
   procedure Print (Command     : in out Command_Type;
                    Name        : in String;
                    Value       : in String;
                    Default     : in String;
                    Context     : in out Context_Type);
   procedure Print (Command     : in out Command_Type;
                    Application : in out AWA.Applications.Application'Class;
                    Name        : in String;
                    Default     : in String;
                    Context     : in out Context_Type);
   procedure Print (Command     : in out Command_Type;
                    Module      : in AWA.Modules.Module'Class;
                    Name        : in String;
                    Default     : in String;
                    Context     : in out Context_Type);

   Command       : aliased Command_Type;

end AWA.Commands.Info;

Add package AWA.Commands.Info to report configuration information


-----------------------------------------------------------------------
--  Util.Concurrent.Pools -- Concurrent Pools
--  Copyright (C) 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;
package body Util.Concurrent.Pools is

   --  ------------------------------
   --  Get an element instance from the pool.
   --  Wait until one instance gets available.
   --  ------------------------------
   procedure Get_Instance (From : in out Pool;
                           Item : out Element_Type) is
   begin
      From.List.Get_Instance (Item);
   end Get_Instance;

   --  ------------------------------
   --  Put the element back to the pool.
   --  ------------------------------
   procedure Release (Into : in out Pool;
                      Item : in Element_Type) is
   begin
      Into.List.Release (Item);
   end Release;

   --  ------------------------------
   --  Set the pool size.
   --  ------------------------------
   procedure Set_Size (Into : in out Pool;
                       Capacity : in Positive) is
   begin
      Into.List.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Release the pool elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Pool) is
   begin
      Object.List.Set_Size (0);
   end Finalize;

   --  Pool of objects
   protected body Protected_Pool is

      --  ------------------------------
      --  Get an element instance from the pool.
      --  Wait until one instance gets available.
      --  ------------------------------
      entry Get_Instance (Item : out Element_Type) when Available > 0 is
      begin
         Item := Elements (Available);
         Available := Available - 1;
      end Get_Instance;

      --  ------------------------------
      --  Put the element back to the pool.
      --  ------------------------------
      procedure Release (Item : in Element_Type) is
      begin
         Available := Available + 1;
         Elements (Available) := Item;
      end Release;

      --  ------------------------------
      --  Set the pool size.
      --  ------------------------------
      procedure Set_Size (Capacity : in Natural) is
         procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
      begin
         if Capacity = 0 then
            Free (Elements);
         elsif Elements = null then
            Elements := new Element_Array (1 .. Capacity);
         else
            declare
               New_Array : Element_Array_Access := new Element_Array (1 .. Capacity);
            begin
               if Capacity > Elements'Size then
                  New_Array (1 .. Elements'Last) := Elements (1 .. Elements'Last);
               else
                  New_Array (1 .. Capacity) := Elements (1 .. Capacity);
               end if;

               Free (Elements);
               Elements := New_Array;
            end;
         end if;
      end Set_Size;

   end Protected_Pool;

end Util.Concurrent.Pools;

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

with Ada.Unchecked_Deallocation;
package body Util.Concurrent.Pools is

   --  ------------------------------
   --  Get an element instance from the pool.
   --  Wait until one instance gets available.
   --  ------------------------------
   procedure Get_Instance (From : in out Pool;
                           Item : out Element_Type) is
   begin
      From.List.Get_Instance (Item);
   end Get_Instance;

   --  ------------------------------
   --  Put the element back to the pool.
   --  ------------------------------
   procedure Release (Into : in out Pool;
                      Item : in Element_Type) is
   begin
      Into.List.Release (Item);
   end Release;

   --  ------------------------------
   --  Set the pool size.
   --  ------------------------------
   procedure Set_Size (Into : in out Pool;
                       Capacity : in Positive) is
   begin
      Into.List.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Release the pool elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Pool) is
   begin
      Object.List.Set_Size (0);
   end Finalize;

   --  Pool of objects
   protected body Protected_Pool is

      --  ------------------------------
      --  Get an element instance from the pool.
      --  Wait until one instance gets available.
      --  ------------------------------
      entry Get_Instance (Item : out Element_Type) when Available > 0 is
      begin
         Item := Elements (Available);
         Available := Available - 1;
      end Get_Instance;

      --  ------------------------------
      --  Put the element back to the pool.
      --  ------------------------------
      procedure Release (Item : in Element_Type) is
      begin
         Available := Available + 1;
         Elements (Available) := Item;
      end Release;

      --  ------------------------------
      --  Set the pool size.
      --  ------------------------------
      procedure Set_Size (Capacity : in Natural) is
         procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
      begin
         if Capacity = 0 then
            Free (Elements);
         elsif Elements = null then
            Elements := new Element_Array (1 .. Capacity);
         else
            declare
               New_Array : constant Element_Array_Access := new Element_Array (1 .. Capacity);
            begin
               if Capacity > Elements'Size then
                  New_Array (1 .. Elements'Last) := Elements (1 .. Elements'Last);
               else
                  New_Array (1 .. Capacity) := Elements (1 .. Capacity);
               end if;

               Free (Elements);
               Elements := New_Array;
            end;
         end if;
      end Set_Size;

   end Protected_Pool;

end Util.Concurrent.Pools;

Fix compilation warning

Fix compilation warning