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

with Asis;  use Asis;

with Types; use Types;

package A4G.Span_End is

   --  This package encapsulates queries needed to find the end of Element's
   --  Span (as the pointer to the Source Buffer).

   function Set_Image_End (E : Asis.Element) return Source_Ptr;
   --  This is the main function in this package. It returns the pointer
   --  to the last character of the given element in the Source Buffer

end A4G.Span_End;

Add the ASIS file $i

Add the ASIS file $i


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

--  with Asis.Text;         use Asis.Text;
with Asis.Elements;     use Asis.Elements;

with A4G.A_Debug;       use A4G.A_Debug;
with A4G.A_Types;       use A4G.A_Types;
with A4G.Int_Knds;      use A4G.Int_Knds;
with A4G.Contt;         use A4G.Contt;
with A4G.Contt.UT;      use A4G.Contt.UT;
with A4G.Contt.TT;      use A4G.Contt.TT;
with A4G.A_Opt;         use A4G.A_Opt;
with A4G.Vcheck;        use A4G.Vcheck;

with Asis.Set_Get;      use  Asis.Set_Get;

with Atree;             use Atree;
with Namet;             use Namet;
with Output;            use Output;
with Sinfo;             use Sinfo;
with Sinput;            use Sinput;

package body A4G.A_Output is

   LT : String renames A4G.A_Types.ASIS_Line_Terminator;

   ---------
   -- Add --
   ---------
   procedure Add (Phrase : String) is
   begin
      if Debug_Buffer_Len = Max_Debug_Buffer_Len then
         return;
      end if;
      for I in Phrase'Range loop
         Debug_Buffer_Len := Debug_Buffer_Len + 1;
         Debug_Buffer (Debug_Buffer_Len) := Phrase (I);
         if Debug_Buffer_Len = Max_Debug_Buffer_Len then
            exit;
         end if;
      end loop;
   end Add;

   ------------------
   -- ASIS_Warning --
   ------------------

   procedure ASIS_Warning
     (Message : String;
      Error   : Asis.Errors.Error_Kinds := Not_An_Error)
   is
   begin
      case ASIS_Warning_Mode is
         when Suppress =>
            null;
         when Normal =>
            Set_Standard_Error;
            Write_Str ("ASIS warning: ");
            Write_Eol;
            Write_Str (Message);
            Write_Eol;
            Set_Standard_Output;
         when Treat_As_Error =>
            --  ??? Raise_ASIS_Failed should be revised to use like that
            Raise_ASIS_Failed (
               Argument  => Nil_Element,
               Diagnosis => Message,
               Stat      => Error);
      end case;
   end ASIS_Warning;

   --------------------------------------
   --  Debug_String (Compilation Unit) --
   --------------------------------------

   --  SHOULD BE REVISED USING Debug_Buffer!!!

   function Debug_String (CUnit : Compilation_Unit) return String is
      LT : String renames A4G.A_Types.ASIS_Line_Terminator;
      U  : Unit_Id;
      C  : Context_Id;
   begin
      U := Get_Unit_Id  (CUnit);
      C := Encl_Cont_Id (CUnit);

      if No (U) then
         return "This is a Nil Compilation Unit";
      else
         Reset_Context (C);
         return LT &
             "Unit Id: " & Unit_Id'Image (U) & LT
             &
             "   Unit name: " & Unit_Name (CUnit) & LT
             &
             "   Kind:      " & Asis.Unit_Kinds'Image (Kind (C, U)) & LT
             &
             "   Class:     " & Asis.Unit_Classes'Image (Class (C, U)) & LT
             &
             "   Origin:    " & Asis.Unit_Origins'Image (Origin (C, U)) & LT
             &
             "   Enclosing Context Id: " & Context_Id'Image (C) & LT
             &
             "   Is consistent: " & Boolean'Image (Is_Consistent (C, U)) & LT
             &
             "-------------------------------------------------";
      end if;

   end Debug_String;

   procedure  Debug_String
     (CUnit    : Compilation_Unit;
      No_Abort : Boolean := False)
   is
      LT : String renames A4G.A_Types.ASIS_Line_Terminator;
      U  : Unit_Id;
      C  : Context_Id;
   begin
      Debug_Buffer_Len := 0;
      U                := Get_Unit_Id  (CUnit);
      C                := Encl_Cont_Id (CUnit);

      if No (U) then
         Add ("This is a Nil Compilation Unit");
      else
         Reset_Context (C);
         Add (LT);
         Add ("Unit Id: " & Unit_Id'Image (U) & LT);
         Add ("   Unit name: " & Unit_Name (CUnit) & LT);
         Add ("   Kind:      " & Asis.Unit_Kinds'Image (Kind (C, U)) & LT);
         Add ("   Class:     " & Asis.Unit_Classes'Image (Class (C, U)) & LT);
         Add ("   Origin:    " & Asis.Unit_Origins'Image (Origin (C, U)) & LT);
         Add ("   Enclosing Context Id: " & Context_Id'Image (C) & LT);
         Add ("   Is consistent: " &
                  Boolean'Image (Is_Consistent (C, U)) & LT);
         Add ("-------------------------------------------------");
      end if;

   exception
      when Ex : others =>

         if No_Abort then
            Add (LT & "Can not complete the unit debug image because of" & LT);
            Add (Exception_Information (Ex));
         else
            raise;
         end if;

   end Debug_String;

   -----------------------------
   --  Debug_String (Context) --
   -----------------------------

   --  SHOULD BE REVISED USING Debug_Buffer!!!

   function Debug_String (Cont : Context) return String is
      LT : String renames A4G.A_Types.ASIS_Line_Terminator;
      C  : constant Context_Id := Get_Cont_Id (Cont);

      Debug_String_Prefix : constant String :=
         "Context Id: " & Context_Id'Image (C) & LT;
   begin
      if C = Non_Associated then
         return Debug_String_Prefix
            &  "   This Context has never been associated";

      elsif not Is_Associated (C) and then
            not Is_Opened (C)
      then
         return Debug_String_Prefix
            &  "   This Context is dissociated at the moment";
      elsif not Is_Opened (C) then
      --  here Is_Associated (C)
         return Debug_String_Prefix
            &  "   This Context has associations," & LT
            &  "   but it is closed at the moment";
      else  -- here Is_Associated (C) and Is_Opened (C)
         return Debug_String_Prefix
            &
            "   This Context is opened at the moment" & LT
            &
            "      All tree files:   "
            & Tree_Id'Image (Last_Tree (C) - First_Tree_Id + 1) & LT
            &
            "      All units:        "
            & Unit_Id'Image (Last_Unit - First_Unit_Id + 1) & LT
            &
            "      Existing specs :  "
            & Natural'Image (Lib_Unit_Decls (C)) & LT
            &
            "      Existing bodies:  "
            & Natural'Image (Comp_Unit_Bodies (C)) & LT
            &
            "      Nonexistent units:"
            & Natural'Image (Natural (Last_Unit - First_Unit_Id + 1) -
                (Lib_Unit_Decls (C) + Comp_Unit_Bodies (C)))
            & LT
            & "=================";
      end if;
   end Debug_String;

   -----------------------------
   --  Debug_String (Element) --
   -----------------------------

   procedure Debug_String
     (E        : Element;
      No_Abort : Boolean := False)
   is
      E_Kind       : constant Internal_Element_Kinds := Int_Kind (E);
      E_Kind_Image : constant String := Internal_Element_Kinds'Image (E_Kind);
      E_Unit       : constant Asis.Compilation_Unit := Encl_Unit (E);
      E_Unit_Class : constant Unit_Classes := Class (E_Unit);

      N     : constant Node_Id := Node         (E);
      R_N   : constant Node_Id := R_Node       (E);
      N_F_1 : constant Node_Id := Node_Field_1 (E);
      N_F_2 : constant Node_Id := Node_Field_2 (E);

      C  : constant Context_Id := Encl_Cont_Id (E);
      T  : constant Tree_Id    := Encl_Tree    (E);
   begin

      Debug_Buffer_Len := 0;

      if Is_Nil (E) then
         Add ("This is a Nil Element");
      else
         Add (E_Kind_Image);
         Add (LT & "located in ");
         Add (Unit_Name (E_Unit));

         if E_Unit_Class = A_Separate_Body then
            Add (" (subunit, Unit_Id =");
         elsif E_Unit_Class = A_Public_Declaration or else
               E_Unit_Class =  A_Private_Declaration
         then
            Add (" (spec, Unit_Id =");
         else
            Add (" (body, Unit_Id =");
         end if;

         Add (Unit_Id'Image (Encl_Unit_Id (E)));
         Add (", Context_Id =");
         Add (Context_Id'Image (C));
         Add (")" & LT);

         if not (Debug_Flag_I) then
            Add ("text position :");

--            if not Is_Text_Available (E) then

               --  Creating the source location from the element node. We
               --  cannot safely use Element_Span here because in case of a
               --  bug in a structural query this may result in curcling of
               --  query blow-ups.

               if Sloc (N) <= No_Location then
                  Add (" not available");
                  Add (LT);
               else

                  Add (" ");

                  declare
                     use Ada.Strings;

                     P              : Source_Ptr;
                     Sindex         : Source_File_Index;
                     Instance_Depth : Natural := 0;

                     procedure Enter_Sloc;
                     --  For the current value of P, adds to the debug string
                     --  the string of the form file_name:line_number. Also
                     --  computes Sindex as the Id of the sourse file of P.

                     procedure Enter_Sloc is
                        F_Name : File_Name_Type;
                     begin
                        Sindex := Get_Source_File_Index (P);
                        F_Name := File_Name (Sindex);

                        Get_Name_String (F_Name);

                        Add (Name_Buffer (1 .. Name_Len) & ":");
                        Add (Trim (Get_Physical_Line_Number (P)'Img, Both));
                        Add (":");
                        Add (Trim (Get_Column_Number (P)'Img, Both));
                     end Enter_Sloc;

                  begin

                     P := Sloc (N);
                     Enter_Sloc;
                     P := Instantiation (Sindex);

                     while P /= No_Location loop
                        Add ("[");
                        Instance_Depth := Instance_Depth + 1;
                        Enter_Sloc;
                        P := Instantiation (Sindex);

                     end loop;

                     for J in 1 .. Instance_Depth loop
                        Add ("]");
                     end loop;

                     Add (LT);
                  end;

               end if;

--            else
--               declare
--                  Arg_Span : Span;
--                  FL : String_Ptr;
--                  LL : String_Ptr;
--                  FC : String_Ptr;
--                  LC : String_Ptr;
--               begin
--                  --  this operation is potentially dangerous - it may
--                  --  change the tree (In fact, it should not, if we
--                  --  take into account the typical conditions when
--                  --  this routine is called
--                  Arg_Span := Element_Span (E);
--                  FL := new String'(Line_Number'Image (Arg_Span.First_Line));
--                  LL := new String'(Line_Number'Image (Arg_Span.Last_Line));
--                  FC := new String'(Character_Position'Image
--                              (Arg_Span.First_Column));
--                  LC := new String'(Character_Position'Image
--                              (Arg_Span.Last_Column));
--                  Add (FL.all);
--                  Add (" :");
--                  Add (FC.all);
--                  Add (" -");
--                  Add (LL.all);
--                  Add (" :");
--                  Add (LC.all);
--                  Add (LT);
--               end;
--            end if;

         end if;

         Add ("   Nodes:" & LT);
         Add ("      Node            :" & Node_Id'Image (N));
         Add (" - " & Node_Kind'Image (Nkind (N)) & LT);

         Add ("      R_Node          :" & Node_Id'Image (R_N));
         Add (" - " & Node_Kind'Image (Nkind (R_N)) & LT);

         Add ("      Node_Field_1    :" & Node_Id'Image (N_F_1));
         Add (" - " & Node_Kind'Image (Nkind (N_F_1)) & LT);

         Add ("      Node_Field_2    :" & Node_Id'Image (N_F_2));
         Add (" - " & Node_Kind'Image (Nkind (N_F_2)) & LT);

         Add ("   Rel_Sloc           :");
         Add (Source_Ptr'Image (Rel_Sloc (E)) & LT);

         if Special_Case (E) /= Not_A_Special_Case then
            Add ("   Special Case       : ");
            Add (Special_Cases'Image (Special_Case (E)) & LT);

         end if;

         if Special_Case (E) = Stand_Char_Literal or else
            Character_Code (E) /= 0
         then
            Add ("   Character_Code     :");
            Add (Char_Code'Image (Character_Code (E)) & LT);
         end if;

         case Normalization_Case (E) is
            when Is_Normalized =>
               Add ("   Normalized" & LT);
            when Is_Normalized_Defaulted =>
               Add ("   Normalized (with default value)" & LT);
            when Is_Normalized_Defaulted_For_Box =>
               Add ("   Normalized (with default value computed for box)"
                    & LT);
            when Is_Not_Normalized =>
               null;
         end case;

         if Parenth_Count (E) > 0 then
            Add ("   Parenth_Count      :");
            Add (Nat'Image (Parenth_Count (E)) & LT);
         end if;

         if Is_From_Implicit (E) then
            Add ("   Is implicit" & LT);
         end if;

         if Is_From_Inherited (E) then
            Add ("   Is inherited" & LT);
         end if;

         if Is_From_Instance (E) then
            Add ("   Is from instance" & LT);
         end if;

         Add ("   obtained from the tree ");

         if Present (T) then
            Get_Name_String (C, T);
            Add (A_Name_Buffer (1 ..  A_Name_Len));
            Add (" (Tree_Id =" & Tree_Id'Image (T) & ")");
         else
            Add (" <nil tree>");
         end if;

      end if;

   exception
      when Ex : others =>

         if No_Abort then
            Add (LT & "Can not complete the unit debug image because of" & LT);
            Add (Exception_Information (Ex));
         else
            raise;
         end if;

   end Debug_String;

   ----------------
   -- Write_Node --
   ----------------

   procedure Write_Node (N : Node_Id; Prefix : String := "") is
   begin
      Write_Str (Prefix);
      Write_Str ("Node_Id =  ");
      Write_Int (Int (N));
      Write_Eol;
      Write_Str (Prefix);
      Write_Str ("Nkind   =  ");
      Write_Str (Node_Kind'Image (Nkind (N)));
      Write_Eol;
      Write_Str (Prefix);
      Write_Str ("Rewrite_Sub       value : ");
      Write_Str (Boolean'Image (Is_Rewrite_Substitution (N)));
      Write_Eol;
      Write_Str (Prefix);
      Write_Str ("Rewrite_Ins       value : ");
      Write_Str (Boolean'Image (Is_Rewrite_Insertion (N)));
      Write_Eol;
      Write_Str (Prefix);
      Write_Str ("Comes_From_Source value : ");
      Write_Str (Boolean'Image (Comes_From_Source (N)));
      Write_Eol;

      if Original_Node (N) = N then
         Write_Str (Prefix);
         Write_Str ("  Node is unchanged");
         Write_Eol;
      elsif Original_Node (N) = Empty then
         Write_Str (Prefix);
         Write_Str ("  Node has been inserted");
         Write_Eol;
      else
         Write_Str (Prefix);
         Write_Str ("  Node has been rewritten");
         Write_Eol;
         Write_Node (N      => Original_Node (N),
                     Prefix => Write_Node.Prefix & " Original node -> ");
      end if;

      Write_Eol;

   end Write_Node;

end A4G.A_Output;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  Util.Beans.Objects.Datasets -- Datasets
--  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.Beans.Objects.Datasets is

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Object_Array,
                                      Name   => Object_Array_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Dataset_Array,
                                     Name   => Dataset_Array_Access);

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : in Dataset) return Natural is
   begin
      return From.Count;
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out Dataset;
                            Index : in Natural) is
   begin
      From.Current_Pos  := Index;
      From.Current.Data := From.Data (Index);
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : in Dataset) return Util.Beans.Objects.Object is
   begin
      return From.Row;
   end Get_Row;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Dataset;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "count" then
         return Util.Beans.Objects.To_Object (From.Count);
      elsif Name = "rowIndex" then
         return Util.Beans.Objects.To_Object (From.Current_Pos);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Append a row in the dataset and call the fill procedure to populate
   --  the row content.
   --  ------------------------------
   procedure Append (Into : in out Dataset;
                     Fill : not null access procedure (Data : in out Object_Array)) is
      Data : constant Object_Array_Access := new Object_Array (1 .. Into.Columns);
   begin
      if Into.Data = null then
         Into.Data := new Dataset_Array (1 .. 10);
      elsif Into.Count >= Into.Data'Last then
         declare
            --  Sun's Java ArrayList use a 2/3 grow factor.
            --  Python's array use 8/9.
            Grow : constant Positive := (Into.Count * 2) / 3;
            Set  : constant Dataset_Array_Access := new Dataset_Array (1 .. Grow);
         begin
            Set (Into.Data'Range) := Into.Data.all;
            Free (Into.Data);
            Into.Data := Set;
         end;
      end if;
      Into.Count := Into.Count + 1;
      Into.Data (Into.Count) := Data;
      Fill (Data.all);
   end Append;

   --  ------------------------------
   --  Add a column to the dataset.  If the position is not specified,
   --  the column count is incremented and the name associated with the last column.
   --  Raises Invalid_State exception if the dataset contains some rows,
   --  ------------------------------
   procedure Add_Column (Into : in out Dataset;
                         Name : in String;
                         Pos  : in Natural := 0) is
      Col : Positive;
   begin
      if Into.Count /= 0 then
         raise Invalid_State with "The dataset contains some rows.";
      end if;
      if Pos = 0 then
         Col := Into.Columns + 1;
      else
         Col := Pos;
      end if;
      Into.Map.Insert (Name, Col);
      if Into.Columns < Col then
         Into.Columns := Col;
      end if;
   end Add_Column;

   --  ------------------------------
   --  Clear the content of the dataset.
   --  ------------------------------
   procedure Clear (Set : in out Dataset) is
   begin
      for I in 1 .. Set.Count loop
         Free (Set.Data (I));
      end loop;
      Set.Count        := 0;
      Set.Current_Pos  := 0;
      Set.Current.Data := null;
   end Clear;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Row;
                       Name : in String) return Util.Beans.Objects.Object is
      Pos : constant Dataset_Map.Cursor := From.Map.Find (Name);
   begin
      if From.Data /= null and then Dataset_Map.Has_Element (Pos) then
         return From.Data (Dataset_Map.Element (Pos));
      else
         return Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Row;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
      Pos : constant Dataset_Map.Cursor := From.Map.Find (Name);
   begin
      if From.Data /= null and then Dataset_Map.Has_Element (Pos) then
         From.Data (Dataset_Map.Element (Pos)) := Value;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Initialize the dataset and the row bean instance.
   --  ------------------------------
   overriding
   procedure Initialize (Set : in out Dataset) is
   begin
      Set.Row := To_Object (Value   => Set.Current'Unchecked_Access,
                            Storage => STATIC);
      Set.Current.Map := Set.Map'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Release the dataset storage.
   --  ------------------------------
   overriding
   procedure Finalize (Set : in out Dataset) is
   begin
      Set.Clear;
      Free (Set.Data);
   end Finalize;

end Util.Beans.Objects.Datasets;

Implement the Datasets package

Implement the Datasets package


-----------------------------------------------------------------------
--  strings.tests -- Unit tests for strings
--  Copyright (C) 2009, 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings;
with Ada.Strings.Unbounded;
with Ada.Strings.Fixed;
with Ada.Strings.Unbounded.Hash;
with Util.Test_Caller;
with Util.Strings.Transforms;
with Util.Strings.Maps;
with Util.Perfect_Hash;
with Ada.Streams;
with Util.Measures;
package body Util.Strings.Tests is

   use Ada.Strings.Unbounded;
   use Util.Tests;
   use Util.Strings.Transforms;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Strings.Transforms.Escape_Javascript",
                       Test_Escape_Javascript'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Transforms.Escape_Xml",
                       Test_Escape_Xml'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Transforms.Capitalize",
                       Test_Capitalize'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Transforms.To_Upper_Case",
                       Test_To_Upper_Case'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Transforms.To_Lower_Case",
                       Test_To_Lower_Case'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Transforms.To_Hex",
                       Test_To_Hex'Access);
      Caller.Add_Test (Suite, "Test Measure",
                       Test_Measure_Copy'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Index",
                       Test_Index'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Rindex",
                       Test_Rindex'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Benchmark",
                       Test_Measure_Hash'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.String_Ref",
                       Test_String_Ref'Access);
      Caller.Add_Test (Suite, "Test perfect hash",
                       Test_Perfect_Hash'Access);

   end Add_Tests;

   procedure Test_Escape_Javascript (T : in out Test) is
      Result : Unbounded_String;
   begin
      Escape_Javascript (Content => ASCII.LF & " ""a string"" a 'single quote'",
                         Into    => Result);
      Assert_Equals (T, "\n \""a string\"" a \'single quote\'", Result);

      Result := To_Unbounded_String ("");
      Escape_Javascript (Content => ASCII.ESC & "[m " & Character'Val (255),
                         Into    => Result);
      Assert_Equals (T, "\u001B[m \u00FF", Result);
   end Test_Escape_Javascript;

   procedure Test_Escape_Xml (T : in out Test) is
      Result : Unbounded_String;
   begin
      Escape_Xml (Content => ASCII.LF & " < ""a string"" a 'single quote' >& ",
                  Into    => Result);
      Assert_Equals (T, ASCII.LF & " < ""a string"" a 'single quote' >& ",
                     Result);

      Result := To_Unbounded_String ("");
      Escape_Xml (Content => ASCII.ESC & "[m " & Character'Val (255),
                  Into    => Result);
      Assert_Equals (T, ASCII.ESC & "[m ÿ", Result);
   end Test_Escape_Xml;

   procedure Test_Capitalize (T : in out Test) is
      Result : Unbounded_String;
   begin
      Assert_Equals (T, "Capitalize_A_String", Capitalize ("capITalIZe_a_strING"));

      Capitalize ("CapAS_String", Result);
      Assert_Equals (T, "Capas_String", Result);
   end Test_Capitalize;

   procedure Test_To_Upper_Case (T : in out Test) is
   begin
      Assert_Equals (T, "UPPERCASE_0123_STR", To_Upper_Case ("upperCase_0123_str"));
   end Test_To_Upper_Case;

   procedure Test_To_Lower_Case (T : in out Test) is
   begin
      Assert_Equals (T, "lowercase_0123_str", To_Lower_Case ("LowERCase_0123_STR"));
   end Test_To_Lower_Case;

   procedure Test_To_Hex (T : in out Test) is
      Result : Unbounded_String;
   begin
      To_Hex (Result, Character'Val (23));
      Assert_Equals (T, "\u0017", Result);

      To_Hex (Result, Character'Val (31));
      Assert_Equals (T, "\u0017\u001F", Result);

      To_Hex (Result, Character'Val (255));
      Assert_Equals (T, "\u0017\u001F\u00FF", Result);
   end Test_To_Hex;

   procedure Test_Measure_Copy (T : in out Test) is
      pragma Unreferenced (T);

      Buf : constant Ada.Streams.Stream_Element_Array (1 .. 10_024) := (others => 23);
      pragma Suppress (All_Checks, Buf);
   begin
      declare
         T : Util.Measures.Stamp;
         R : Ada.Strings.Unbounded.Unbounded_String;
      begin
         for I in Buf'Range loop
            Append (R, Character'Val (Buf (I)));
         end loop;
         Util.Measures.Report (T, "Stream transform using Append (1024 bytes)");
      end;
      declare
         T : Util.Measures.Stamp;
         R : Ada.Strings.Unbounded.Unbounded_String;
         S : String (1 .. 10_024);
         pragma Suppress (All_Checks, S);
      begin
         for I in Buf'Range loop
            S (Natural (I)) := Character'Val (Buf (I));
         end loop;
         Append (R, S);
         Util.Measures.Report (T, "Stream transform using temporary string (1024 bytes)");
      end;
--        declare
--           T : Util.Measures.Stamp;
--           R : Ada.Strings.Unbounded.Unbounded_String;
--           P : constant Ptr := new String (1 .. Buf'Length);
--
--           pragma Suppress (All_Checks, P);
--        begin
--           for I in P'Range loop
--              P (I) := Character'Val (Buf (Ada.Streams.Stream_Element_Offset (I)));
--           end loop;
--           Ada.Strings.Unbounded.Aux.Set_String (R, P.all'Access);
--           Util.Measures.Report (T, "Stream transform using Aux string (1024 bytes)");
--        end;
   end Test_Measure_Copy;

   --  Test the Index operation
   procedure Test_Index (T : in out Test) is
      Str : constant String := "0123456789abcdefghijklmnopq";
   begin
      declare
         St  : Util.Measures.Stamp;
         Pos : Integer;
      begin
         for I in 1 .. 10 loop
            Pos := Index (Str, 'q');
         end loop;
         Util.Measures.Report (St, "Util.Strings.Index");
         Assert_Equals (T, 27, Pos, "Invalid index position");
      end;
      declare
         St  : Util.Measures.Stamp;
         Pos : Integer;
      begin
         for I in 1 .. 10 loop
            Pos := Ada.Strings.Fixed.Index (Str, "q");
         end loop;
         Util.Measures.Report (St, "Ada.Strings.Fixed.Index");
         Assert_Equals (T, 27, Pos, "Invalid index position");
      end;
   end Test_Index;

   --  Test the Rindex operation
   procedure Test_Rindex (T : in out Test) is
      Str : constant String := "0123456789abcdefghijklmnopq";
   begin
      declare
         St  : Util.Measures.Stamp;
         Pos : Natural;
      begin
         for I in 1 .. 10 loop
            Pos := Rindex (Str, '0');
         end loop;
         Util.Measures.Report (St, "Util.Strings.Rindex");
         Assert_Equals (T, 1, Pos, "Invalid rindex position");
      end;
      declare
         St  : Util.Measures.Stamp;
         Pos : Natural;
      begin
         for I in 1 .. 10 loop
            Pos := Ada.Strings.Fixed.Index (Str, "0", Ada.Strings.Backward);
         end loop;
         Util.Measures.Report (St, "Ada.Strings.Fixed.Rindex");
         Assert_Equals (T, 1, Pos, "Invalid rindex position");
      end;
   end Test_Rindex;

   package String_Map is new Ada.Containers.Hashed_Maps
     (Key_Type        => Unbounded_String,
      Element_Type    => Unbounded_String,
      Hash            => Hash,
      Equivalent_Keys => "=");

   package String_Ref_Map is new Ada.Containers.Hashed_Maps
     (Key_Type        => String_Ref,
      Element_Type    => String_Ref,
      Hash            => Hash,
      Equivalent_Keys => Equivalent_Keys);

   --  Do some benchmark on String -> X hash mapped.
   procedure Test_Measure_Hash (T : in out Test) is
      KEY     : aliased constant String := "testing";
      Str_Map : Util.Strings.Maps.Map;
      Ptr_Map : Util.Strings.String_Access_Map.Map;
      Ref_Map : String_Ref_Map.Map;
      Unb_Map : String_Map.Map;
      Name    : String_Access := new String '(KEY);
      Ref     : constant String_Ref := To_String_Ref (KEY);
   begin
      Str_Map.Insert (Name.all, Name.all);
      Ptr_Map.Insert (Name.all'Access, Name.all'Access);
      Unb_Map.Insert (To_Unbounded_String (KEY), To_Unbounded_String (KEY));
      Ref_Map.Insert (Ref, Ref);

      --  Performance of Hashed_Map Name_Access -> Name_Access
      --  (the fastest hash)
      declare
         St  : Util.Measures.Stamp;
         Pos : constant Strings.String_Access_Map.Cursor := Ptr_Map.Find (KEY'Unchecked_Access);
         Val : constant Name_Access := Util.Strings.String_Access_Map.Element (Pos);
      begin
         Util.Measures.Report (St, "Util.Strings.String_Access_Maps.Find+Element");
         Assert_Equals (T, "testing", Val.all, "Invalid value returned");
      end;

      --  Performance of Hashed_Map String_Ref -> String_Ref
      --  (almost same performance as Hashed_Map Name_Access -> Name_Access)
      declare
         St  : Util.Measures.Stamp;
         Pos : constant String_Ref_Map.Cursor := Ref_Map.Find (Ref);
         Val : constant String_Ref := String_Ref_Map.Element (Pos);
      begin
         Util.Measures.Report (St, "Util.Strings.String_Ref_Maps.Find+Element");
         Assert_Equals (T, "testing", String '(To_String (Val)), "Invalid value returned");
      end;

      --  Performance of Hashed_Map Unbounded_String -> Unbounded_String
      --  (little overhead due to String copy made by Unbounded_String)
      declare
         St  : Util.Measures.Stamp;
         Pos : constant String_Map.Cursor := Unb_Map.Find (To_Unbounded_String (KEY));
         Val : constant Unbounded_String := String_Map.Element (Pos);
      begin
         Util.Measures.Report (St, "Hashed_Maps<Unbounded,Unbounded..Find+Element");
         Assert_Equals (T, "testing", Val, "Invalid value returned");
      end;

      --  Performance for Indefinite_Hashed_Map String -> String
      --  (the slowest hash, string copy to get the result, pointer to key and element
      --  in the hash map implementation)
      declare
         St  : Util.Measures.Stamp;
         Pos : constant Util.Strings.Maps.Cursor := Str_Map.Find (KEY);
         Val : constant String := Util.Strings.Maps.Element (Pos);
      begin
         Util.Measures.Report (St, "Util.Strings.Maps.Find+Element");
         Assert_Equals (T, "testing", Val, "Invalid value returned");
      end;

      Free (Name);
   end Test_Measure_Hash;

   --  ------------------------------
   --  Test String_Ref creation
   --  ------------------------------
   procedure Test_String_Ref (T : in out Test) is
      R1 : String_Ref := To_String_Ref ("testing a string");
   begin
      for I in 1 .. 1_000 loop
         declare
            S  : constant String (1 .. I) := (others => 'x');
            R2 : constant String_Ref := To_String_Ref (S);
         begin
            Assert_Equals (T, S, To_String (R2), "Invalid String_Ref");
            T.Assert (R2 = S, "Invalid comparison");
            Assert_Equals (T, I, Length (R2), "Invalid length");
            R1 := R2;
            T.Assert (R1 = R2, "Invalid String_Ref copy");
         end;
      end loop;
   end Test_String_Ref;

   --  Test perfect hash (samples/gperfhash)
   procedure Test_Perfect_Hash (T : in out Test) is
   begin
      for I in Util.Perfect_Hash.Keywords'Range loop
         declare
            K : constant String := Util.Perfect_Hash.Keywords (I).all;
         begin
            Assert_Equals (T, I, Util.Perfect_Hash.Hash (K),
                           "Invalid hash");
            Assert_Equals (T, I, Util.Perfect_Hash.Hash (To_Lower_Case (K)),
                           "Invalid hash");
            Assert (T, Util.Perfect_Hash.Is_Keyword (K), "Keyword " & K & " is not a keyword");
            Assert (T, Util.Perfect_Hash.Is_Keyword (To_Lower_Case (K)),
                    "Keyword " & K & " is not a keyword");
         end;
      end loop;
   end Test_Perfect_Hash;

end Util.Strings.Tests;

-----------------------------------------------------------------------
--  strings.tests -- Unit tests for strings
--  Copyright (C) 2009, 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings;
with Ada.Strings.Unbounded;
with Ada.Strings.Fixed;
with Ada.Strings.Unbounded.Hash;
with Util.Test_Caller;
with Util.Strings.Transforms;
with Util.Strings.Maps;
with Util.Perfect_Hash;
with Ada.Streams;
with Util.Measures;
package body Util.Strings.Tests is

   use Ada.Strings.Unbounded;
   use Util.Tests;
   use Util.Strings.Transforms;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Strings.Transforms.Escape_Javascript",
                       Test_Escape_Javascript'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Transforms.Escape_Xml",
                       Test_Escape_Xml'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Transforms.Capitalize",
                       Test_Capitalize'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Transforms.To_Upper_Case",
                       Test_To_Upper_Case'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Transforms.To_Lower_Case",
                       Test_To_Lower_Case'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Transforms.To_Hex",
                       Test_To_Hex'Access);
      Caller.Add_Test (Suite, "Test Measure",
                       Test_Measure_Copy'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Index",
                       Test_Index'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Rindex",
                       Test_Rindex'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.Benchmark",
                       Test_Measure_Hash'Access);
      Caller.Add_Test (Suite, "Test Util.Strings.String_Ref",
                       Test_String_Ref'Access);
      Caller.Add_Test (Suite, "Test perfect hash",
                       Test_Perfect_Hash'Access);

   end Add_Tests;

   procedure Test_Escape_Javascript (T : in out Test) is
      Result : Unbounded_String;
   begin
      Escape_Javascript (Content => ASCII.LF & " ""a string"" a 'single quote'",
                         Into    => Result);
      Assert_Equals (T, "\n \""a string\"" a \'single quote\'", Result);

      Result := To_Unbounded_String ("");
      Escape_Javascript (Content => ASCII.ESC & "[m " & Character'Val (255),
                         Into    => Result);
      Assert_Equals (T, "\u001B[m " & Character'Val (255), Result);
   end Test_Escape_Javascript;

   procedure Test_Escape_Xml (T : in out Test) is
      Result : Unbounded_String;
   begin
      Escape_Xml (Content => ASCII.LF & " < ""a string"" a 'single quote' >& ",
                  Into    => Result);
      Assert_Equals (T, ASCII.LF & " < ""a string"" a 'single quote' >& ",
                     Result);

      Result := To_Unbounded_String ("");
      Escape_Xml (Content => ASCII.ESC & "[m " & Character'Val (255),
                  Into    => Result);
      Assert_Equals (T, ASCII.ESC & "[m ÿ", Result);
   end Test_Escape_Xml;

   procedure Test_Capitalize (T : in out Test) is
      Result : Unbounded_String;
   begin
      Assert_Equals (T, "Capitalize_A_String", Capitalize ("capITalIZe_a_strING"));

      Capitalize ("CapAS_String", Result);
      Assert_Equals (T, "Capas_String", Result);
   end Test_Capitalize;

   procedure Test_To_Upper_Case (T : in out Test) is
   begin
      Assert_Equals (T, "UPPERCASE_0123_STR", To_Upper_Case ("upperCase_0123_str"));
   end Test_To_Upper_Case;

   procedure Test_To_Lower_Case (T : in out Test) is
   begin
      Assert_Equals (T, "lowercase_0123_str", To_Lower_Case ("LowERCase_0123_STR"));
   end Test_To_Lower_Case;

   procedure Test_To_Hex (T : in out Test) is
      Result : Unbounded_String;
   begin
      To_Hex (Result, Character'Val (23));
      Assert_Equals (T, "\u0017", Result);

      To_Hex (Result, Character'Val (31));
      Assert_Equals (T, "\u0017\u001F", Result);

      To_Hex (Result, Character'Val (255));
      Assert_Equals (T, "\u0017\u001F\u00FF", Result);
   end Test_To_Hex;

   procedure Test_Measure_Copy (T : in out Test) is
      pragma Unreferenced (T);

      Buf : constant Ada.Streams.Stream_Element_Array (1 .. 10_024) := (others => 23);
      pragma Suppress (All_Checks, Buf);
   begin
      declare
         T : Util.Measures.Stamp;
         R : Ada.Strings.Unbounded.Unbounded_String;
      begin
         for I in Buf'Range loop
            Append (R, Character'Val (Buf (I)));
         end loop;
         Util.Measures.Report (T, "Stream transform using Append (1024 bytes)");
      end;
      declare
         T : Util.Measures.Stamp;
         R : Ada.Strings.Unbounded.Unbounded_String;
         S : String (1 .. 10_024);
         pragma Suppress (All_Checks, S);
      begin
         for I in Buf'Range loop
            S (Natural (I)) := Character'Val (Buf (I));
         end loop;
         Append (R, S);
         Util.Measures.Report (T, "Stream transform using temporary string (1024 bytes)");
      end;
--        declare
--           T : Util.Measures.Stamp;
--           R : Ada.Strings.Unbounded.Unbounded_String;
--           P : constant Ptr := new String (1 .. Buf'Length);
--
--           pragma Suppress (All_Checks, P);
--        begin
--           for I in P'Range loop
--              P (I) := Character'Val (Buf (Ada.Streams.Stream_Element_Offset (I)));
--           end loop;
--           Ada.Strings.Unbounded.Aux.Set_String (R, P.all'Access);
--           Util.Measures.Report (T, "Stream transform using Aux string (1024 bytes)");
--        end;
   end Test_Measure_Copy;

   --  Test the Index operation
   procedure Test_Index (T : in out Test) is
      Str : constant String := "0123456789abcdefghijklmnopq";
   begin
      declare
         St  : Util.Measures.Stamp;
         Pos : Integer;
      begin
         for I in 1 .. 10 loop
            Pos := Index (Str, 'q');
         end loop;
         Util.Measures.Report (St, "Util.Strings.Index");
         Assert_Equals (T, 27, Pos, "Invalid index position");
      end;
      declare
         St  : Util.Measures.Stamp;
         Pos : Integer;
      begin
         for I in 1 .. 10 loop
            Pos := Ada.Strings.Fixed.Index (Str, "q");
         end loop;
         Util.Measures.Report (St, "Ada.Strings.Fixed.Index");
         Assert_Equals (T, 27, Pos, "Invalid index position");
      end;
   end Test_Index;

   --  Test the Rindex operation
   procedure Test_Rindex (T : in out Test) is
      Str : constant String := "0123456789abcdefghijklmnopq";
   begin
      declare
         St  : Util.Measures.Stamp;
         Pos : Natural;
      begin
         for I in 1 .. 10 loop
            Pos := Rindex (Str, '0');
         end loop;
         Util.Measures.Report (St, "Util.Strings.Rindex");
         Assert_Equals (T, 1, Pos, "Invalid rindex position");
      end;
      declare
         St  : Util.Measures.Stamp;
         Pos : Natural;
      begin
         for I in 1 .. 10 loop
            Pos := Ada.Strings.Fixed.Index (Str, "0", Ada.Strings.Backward);
         end loop;
         Util.Measures.Report (St, "Ada.Strings.Fixed.Rindex");
         Assert_Equals (T, 1, Pos, "Invalid rindex position");
      end;
   end Test_Rindex;

   package String_Map is new Ada.Containers.Hashed_Maps
     (Key_Type        => Unbounded_String,
      Element_Type    => Unbounded_String,
      Hash            => Hash,
      Equivalent_Keys => "=");

   package String_Ref_Map is new Ada.Containers.Hashed_Maps
     (Key_Type        => String_Ref,
      Element_Type    => String_Ref,
      Hash            => Hash,
      Equivalent_Keys => Equivalent_Keys);

   --  Do some benchmark on String -> X hash mapped.
   procedure Test_Measure_Hash (T : in out Test) is
      KEY     : aliased constant String := "testing";
      Str_Map : Util.Strings.Maps.Map;
      Ptr_Map : Util.Strings.String_Access_Map.Map;
      Ref_Map : String_Ref_Map.Map;
      Unb_Map : String_Map.Map;
      Name    : String_Access := new String '(KEY);
      Ref     : constant String_Ref := To_String_Ref (KEY);
   begin
      Str_Map.Insert (Name.all, Name.all);
      Ptr_Map.Insert (Name.all'Access, Name.all'Access);
      Unb_Map.Insert (To_Unbounded_String (KEY), To_Unbounded_String (KEY));
      Ref_Map.Insert (Ref, Ref);

      --  Performance of Hashed_Map Name_Access -> Name_Access
      --  (the fastest hash)
      declare
         St  : Util.Measures.Stamp;
         Pos : constant Strings.String_Access_Map.Cursor := Ptr_Map.Find (KEY'Unchecked_Access);
         Val : constant Name_Access := Util.Strings.String_Access_Map.Element (Pos);
      begin
         Util.Measures.Report (St, "Util.Strings.String_Access_Maps.Find+Element");
         Assert_Equals (T, "testing", Val.all, "Invalid value returned");
      end;

      --  Performance of Hashed_Map String_Ref -> String_Ref
      --  (almost same performance as Hashed_Map Name_Access -> Name_Access)
      declare
         St  : Util.Measures.Stamp;
         Pos : constant String_Ref_Map.Cursor := Ref_Map.Find (Ref);
         Val : constant String_Ref := String_Ref_Map.Element (Pos);
      begin
         Util.Measures.Report (St, "Util.Strings.String_Ref_Maps.Find+Element");
         Assert_Equals (T, "testing", String '(To_String (Val)), "Invalid value returned");
      end;

      --  Performance of Hashed_Map Unbounded_String -> Unbounded_String
      --  (little overhead due to String copy made by Unbounded_String)
      declare
         St  : Util.Measures.Stamp;
         Pos : constant String_Map.Cursor := Unb_Map.Find (To_Unbounded_String (KEY));
         Val : constant Unbounded_String := String_Map.Element (Pos);
      begin
         Util.Measures.Report (St, "Hashed_Maps<Unbounded,Unbounded..Find+Element");
         Assert_Equals (T, "testing", Val, "Invalid value returned");
      end;

      --  Performance for Indefinite_Hashed_Map String -> String
      --  (the slowest hash, string copy to get the result, pointer to key and element
      --  in the hash map implementation)
      declare
         St  : Util.Measures.Stamp;
         Pos : constant Util.Strings.Maps.Cursor := Str_Map.Find (KEY);
         Val : constant String := Util.Strings.Maps.Element (Pos);
      begin
         Util.Measures.Report (St, "Util.Strings.Maps.Find+Element");
         Assert_Equals (T, "testing", Val, "Invalid value returned");
      end;

      Free (Name);
   end Test_Measure_Hash;

   --  ------------------------------
   --  Test String_Ref creation
   --  ------------------------------
   procedure Test_String_Ref (T : in out Test) is
      R1 : String_Ref := To_String_Ref ("testing a string");
   begin
      for I in 1 .. 1_000 loop
         declare
            S  : constant String (1 .. I) := (others => 'x');
            R2 : constant String_Ref := To_String_Ref (S);
         begin
            Assert_Equals (T, S, To_String (R2), "Invalid String_Ref");
            T.Assert (R2 = S, "Invalid comparison");
            Assert_Equals (T, I, Length (R2), "Invalid length");
            R1 := R2;
            T.Assert (R1 = R2, "Invalid String_Ref copy");
         end;
      end loop;
   end Test_String_Ref;

   --  Test perfect hash (samples/gperfhash)
   procedure Test_Perfect_Hash (T : in out Test) is
   begin
      for I in Util.Perfect_Hash.Keywords'Range loop
         declare
            K : constant String := Util.Perfect_Hash.Keywords (I).all;
         begin
            Assert_Equals (T, I, Util.Perfect_Hash.Hash (K),
                           "Invalid hash");
            Assert_Equals (T, I, Util.Perfect_Hash.Hash (To_Lower_Case (K)),
                           "Invalid hash");
            Assert (T, Util.Perfect_Hash.Is_Keyword (K), "Keyword " & K & " is not a keyword");
            Assert (T, Util.Perfect_Hash.Is_Keyword (To_Lower_Case (K)),
                    "Keyword " & K & " is not a keyword");
         end;
      end loop;
   end Test_Perfect_Hash;

end Util.Strings.Tests;

Update the unit test

Update the unit test


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                         A 4 G . A _ S I N P U T                          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2010, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR  PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public  License  distributed with ASIS-for-GNAT;  see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by AdaCore                     --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

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

with Asis.Set_Get;            use Asis.Set_Get;

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

package body A4G.A_Sinput is

   use ASCII;
   --  Make control characters visible

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

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

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

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

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

      while S <= P loop

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

         Result := Result + 1;
      end loop;

      return Result;
   end A_Get_Column_Number;

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

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

      Scan_The_Line : while Scanner_Pos < Line_Image_End loop

         Scanner_Pos := Scanner_Pos + 1;

         case Line_Image (Scanner_Pos) is

            when '"' | '%' =>

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

                  String_Delimiter := Line_Image (Scanner_Pos);

                  Skip_String_Literal : loop
                     Scanner_Pos := Scanner_Pos + 1;

                     if Line_Image (Scanner_Pos) = String_Delimiter then

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

                     end if;

                  end loop Skip_String_Literal;

               end if;

            when '-' =>

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

            when others =>
               null;

         end case;

      end loop Scan_The_Line;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      return S;
   end Get_Num_Literal_End;

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

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

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

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

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

      end loop;

      return S;
   end Get_String_End;

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

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

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

      S := P_Start;

      while S <= P_End loop

         Last_Idx := Last_Idx + 1;

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

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

      end loop;

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

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

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

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

         Result := Wide_Character'Val (Ch);

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

      return Result;

   end Get_Wide_Ch;

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

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

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

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

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

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

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

      return Result;

   end In_Identifier;

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

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

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

      return Result;
   end Is_EOL_Char;

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

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

      if C /= No_Location and then P > C then

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

      else
         Result := Is_Start_Of_Wide_Char (S, P);

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

      end if;

      return Result;
   end Is_Start_Of_Wide_Char_For_ASIS;

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

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

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

      end loop;

      return S;
   end Next_Identifier;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      return S_P + 1;
   end Search_Beginning_Of_Word;

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

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

      Char := Src (S_P);

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

      S_P := S_P - 1;

      return S_P;

   end Search_End_Of_Word;

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

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

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

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

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

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

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

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

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

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

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

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

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

         else
            S := S + 1;
         end if;

      end loop;

      return S;
   end Search_Rightmost_Symbol;

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

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

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

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

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

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

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

      end if;

   end Skip_Wide_For_ASIS;

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

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

      return Sp;
   end Source_Locations_To_Span;

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

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

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

         while S <= S_End loop

            Last_Idx := Last_Idx + 1;

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

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

         end loop;

         return Result (1 .. Last_Idx);
      end;

   end Wide_String_Image;

end A4G.A_Sinput;

Add the ASIS file $i

Add the ASIS file $i


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

with Asis;        use Asis;

with A4G.A_Types; use A4G.A_Types;

with Types;       use Types;

--  This package contains the routines used to compute the unit attributes
--  during the second pass through the tree files, when ASIS operates in
--  Use_Pre_Created_Trees mode. There is some duplication of the
--  functionalities provided by this package and by A4G.C_U_Info and
--  A4G.S_U_Info; the last two packages were coded before for
--  Compile_On_The_Fly ASIS operation mode. The intent is to get rid of
--  A4G.C_U_Info and A4G.S_U_Info in the final ASIS version, so we do not
--  bother about these duplications for now.

--  ???THIS COMMENT HEADER SHOULD BE REVISED!!!???

package A4G.CU_Info2 is

   procedure Set_Kind_and_Class
     (C   : Context_Id;
      U   : Unit_Id;
      Top : Node_Id);
   --  Taking the unit's subtree top node, this procedure computes and sets
   --  the Unit Kind and the Unit Class for U. Because of some technical ,
   --  reasons, it is more easy to define the Unit Kind and the Unit Class
   --  in the same routine

   procedure Get_Ada_Name (Top : Node_Id);
   --  Computes (by traversing the tree) the fully expanded Ada name
   --  of a compilation unit whose subtree contained as having Top as
   --  its top node in the full tree currently being accessed. This name
   --  then is set in A_Name_Buffer, and A_Name_Len is set as its length

   procedure Set_S_F_Name_and_Origin
     (Context : Context_Id;
      Unit    : Unit_Id;
      Top     : Node_Id);
   --  This procedure obtains the source file name from the GNAT tree and
   --  stores it in the Unit_Table. By analyzing the file name (this analysis
   --  is based on the Fname.Is_Predefined_File_Name GNAt function, the
   --  Unit_Origin for the Unit is defined and stored in the Unit table.

   function Is_Main (Top : Node_Id; Kind : Unit_Kinds) return Boolean;
   --  Defines if the Unit having Top as its N_Compilation_Unit node
   --  can be a main subprogram for a partition. Asis Unit Kind is
   --  used to optimize this computation

   procedure Set_Dependencies
     (C   : Context_Id;
      U   : Unit_Id;
      Top : Node_Id);
   --  Taking the unit's subtree top node, this procedure computes and sets
   --  all the dependency information needed for semantic queries from the
   --  Asis.Compilation_Units package. This information is stored as unit
   --  lists (see A4G.Unit_Rec). For now, we do not compute the lists of
   --  *direct* supporters and *direct* dependents, because we think, that
   --  these ASIS notions are ill-defined and cannot be mapped onto RM95
   --  in a natural way.

end A4G.CU_Info2;

Add the ASIS file $i

Add the ASIS file $i