-----------------------------------------------------------------------
--  util-serialize-io-json -- JSON Serialization Driver
--  Copyright (C) 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.Characters.Latin_1;
with Ada.IO_Exceptions;

with Util.Strings;
with Util.Streams;
with Util.Streams.Buffered;
package body Util.Serialize.IO.JSON is

   use Ada.Strings.Unbounded;

   --  -----------------------
   --  Write the string as a quoted JSON string
   --  -----------------------
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String) is
   begin
      Stream.Write ('"');
      for I in Value'Range loop
         declare
            C : constant Character := Value (I);
         begin
            if C = '"' then
               Stream.Write ("\""");

            elsif C = '\'  then
               Stream.Write ("\\");

            elsif Character'Pos (C) >= 16#20# then
               Stream.Write (C);

            else
               case C is
                  when Ada.Characters.Latin_1.BS =>
                     Stream.Write ("\b");

                  when Ada.Characters.Latin_1.VT =>
                     Stream.Write ("\f");

                  when Ada.Characters.Latin_1.LF =>
                     Stream.Write ("\n");

                  when Ada.Characters.Latin_1.CR =>
                     Stream.Write ("\r");

                  when Ada.Characters.Latin_1.HT =>
                     Stream.Write ("\t");

                  when others =>
                     Util.Streams.Texts.TR.To_Hex (Streams.Buffered.Buffered_Stream (Stream), C);

               end case;
            end if;
         end;
      end loop;
      Stream.Write ('"');
   end Write_String;

   --  -----------------------
   --  Start writing an object identified by the given name
   --  -----------------------
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is
      Current : access Node_Info := Node_Info_Stack.Current (Stream.Stack);
   begin
      if Current /= null then
         if Current.Has_Fields then
            Stream.Write (',');
         else
            Current.Has_Fields := True;
         end if;
      end if;
      Node_Info_Stack.Push (Stream.Stack);
      Current := Node_Info_Stack.Current (Stream.Stack);
      Current.Has_Fields := False;

      if Name'Length > 0 then
         Stream.Write_String (Name);
         Stream.Write (':');
      end if;
      Stream.Write ('{');
   end Start_Entity;

   --  -----------------------
   --  Finish writing an object identified by the given name
   --  -----------------------
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is
      pragma Unreferenced (Name);
   begin
      Node_Info_Stack.Pop (Stream.Stack);
      Stream.Write ('}');
   end End_Entity;

   --  -----------------------
   --  Write an attribute member from the current object
   --  -----------------------
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;

      Current : constant access Node_Info := Node_Info_Stack.Current (Stream.Stack);
   begin
      if Current /= null then
         if Current.Has_Fields then
            Stream.Write (",");
         else
            Current.Has_Fields := True;
         end if;
      end if;
      Stream.Write_String (Name);
      Stream.Write (':');
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            Stream.Write ("null");

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write_String (Util.Beans.Objects.To_String (Value));

      end case;
   end Write_Attribute;

   --  -----------------------
   --  Write an object value as an entity
   --  -----------------------
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is
   begin
      Stream.Write_Attribute (Name, Value);
   end Write_Entity;

   --  -----------------------
   --  Start an array that will contain the specified number of elements
   --  -----------------------
   procedure Start_Array (Stream : in out Output_Stream;
                          Length : in Ada.Containers.Count_Type) is
      pragma Unreferenced (Length);
   begin
      Node_Info_Stack.Push (Stream.Stack);
      Stream.Write ('[');
   end Start_Array;

   --  -----------------------
   --  Finishes an array
   --  -----------------------
   procedure End_Array (Stream : in out Output_Stream) is
   begin
      Node_Info_Stack.Pop (Stream.Stack);
      Stream.Write (']');
   end End_Array;

   --  -----------------------
   --  Get the current location (file and line) to report an error message.
   --  -----------------------
   function Get_Location (Handler : in Parser) return String is
   begin
      return Util.Strings.Image (Handler.Line_Number);
   end Get_Location;

   procedure Parse (Handler : in out Parser;
                    Stream : in out Util.Streams.Buffered.Buffered_Stream'Class) is

      --  Put back a token in the buffer.
      procedure Put_Back (P     : in out Parser'Class;
                          Token : in Token_Type);

      --  Parse the expression buffer to find the next token.
      procedure Peek (P     : in out Parser'Class;
                      Token : out Token_Type);

      --  Parse a list of members
      --  members ::= pair | pair ',' members
      --  pair    ::= string ':' value
      --  value   ::= string | number | object | array | true | false | null
      procedure Parse_Pairs (P : in out Parser'Class);

      --  Parse a value
      --  value   ::= string | number | object | array | true | false | null
      procedure Parse_Value (P    : in out Parser'Class;
                             Name : in String);

      procedure Parse (P : in out Parser'Class);

      procedure Parse (P : in out Parser'Class) is
         Token : Token_Type;
      begin
         Peek (P, Token);
         if Token /= T_LEFT_BRACE then
            P.Error ("Missing '{'");
         end if;
         Parse_Pairs (P);
         Peek (P, Token);
         if Token /= T_RIGHT_BRACE then
            P.Error ("Missing '}'");
         end if;
      end Parse;

      --  ------------------------------
      --  Parse a list of members
      --  members ::= pair | pair ',' members
      --  pair    ::= string ':' value
      --  value   ::= string | number | object | array | true | false | null
      --  ------------------------------
      procedure Parse_Pairs (P : in out Parser'Class) is
         Current_Name : Unbounded_String;
         Token        : Token_Type;
      begin
         loop
            Peek (P, Token);
            if Token /= T_STRING then
               Put_Back (P, Token);
               return;
            end if;
            Current_Name := P.Token;
            Peek (P, Token);
            if Token /= T_COLON then
               P.Error ("Missing ':'");
            end if;

            Parse_Value (P, To_String (Current_Name));
            Peek (P, Token);
            if Token /= T_COMMA then
               Put_Back (P, Token);
               return;
            end if;
         end loop;
      end Parse_Pairs;

      --  ------------------------------
      --  Parse a value
      --  value   ::= string | number | object | array | true | false | null
      --  ------------------------------
      procedure Parse_Value (P    : in out Parser'Class;
                             Name : in String) is
         Token : Token_Type;
      begin
         Peek (P, Token);
         case Token is
            when T_LEFT_BRACE =>
               P.Start_Object (Name);
               Parse_Pairs (P);
               Peek (P, Token);
               if Token /= T_RIGHT_BRACE then
                  P.Error ("Missing '}'");
               end if;
               P.Finish_Object (Name);

                  --
            when T_LEFT_BRACKET =>
               P.Start_Array (Name);
               Peek (P, Token);
               if Token /= T_RIGHT_BRACKET then
                  Put_Back (P, Token);
                  loop
                     Parse_Value (P, Name);
                     Peek (P, Token);
                     exit when Token = T_RIGHT_BRACKET;
                     if Token /= T_COMMA then
                        P.Error ("Missing ']'");
                     end if;
                  end loop;
               end if;
               P.Finish_Array (Name);

            when T_NULL =>
               P.Set_Member (Name, Util.Beans.Objects.Null_Object);

            when T_NUMBER =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (P.Token));

            when T_STRING =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (P.Token));

            when T_TRUE =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (True));

            when T_FALSE =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (False));

            when T_EOF =>
               P.Error ("End of stream reached");
               return;

            when others =>
               P.Error ("Invalid token");
         end case;
      end Parse_Value;

      --  ------------------------------
      --  Put back a token in the buffer.
      --  ------------------------------
      procedure Put_Back (P     : in out Parser'Class;
                          Token : in Token_Type) is
      begin
         P.Pending_Token := Token;
      end Put_Back;

      --  ------------------------------
      --  Parse the expression buffer to find the next token.
      --  ------------------------------
      procedure Peek (P     : in out Parser'Class;
                      Token : out Token_Type) is
         C, C1 : Character;
      begin
         --  If a token was put back, return it.
         if P.Pending_Token /= T_EOF then
            Token := P.Pending_Token;
            P.Pending_Token := T_EOF;
            return;
         end if;

         if P.Has_Pending_Char then
            C := P.Pending_Char;
         else
            --  Skip white spaces
            loop
               Stream.Read (Char => C);
               if C = Ada.Characters.Latin_1.LF then
                  P.Line_Number := P.Line_Number + 1;
               else
                  exit when C /= ' '
                    and C /= Ada.Characters.Latin_1.CR and C /= Ada.Characters.Latin_1.HT;
               end if;
            end loop;
         end if;
         P.Has_Pending_Char := False;

         --  See what we have and continue parsing.
         case C is
            --  Literal string using double quotes
            --  Collect up to the end of the string and put
            --  the result in the parser token result.
         when '"' =>
            Delete (P.Token, 1, Length (P.Token));
            loop
               Stream.Read (Char => C1);
               if C1 = '\' then
                  Stream.Read (Char => C1);
                  case C1 is
                     when '"' | '\' | '/' =>
                        C := C1;

                     when 'b' =>
                        C1 := Ada.Characters.Latin_1.BS;

                     when 'f' =>
                        C1 := Ada.Characters.Latin_1.VT;

                     when 'n' =>
                        C1 := Ada.Characters.Latin_1.LF;

                     when 'r' =>
                        C1 := Ada.Characters.Latin_1.CR;

                     when 't' =>
                        C1 := Ada.Characters.Latin_1.HT;

                     when 'u' =>
                        null;

                     when others =>
                        P.Error ("Invalid character '" & C1 & "' in \x sequence");

                  end case;
               elsif C1 = C then
                  Token := T_STRING;
                  return;
               end if;
               Append (P.Token, C1);
            end loop;

            --  Number
         when '-' | '0' .. '9' =>
            Delete (P.Token, 1, Length (P.Token));
            Append (P.Token, C);
            loop
               Stream.Read (Char => C);
               exit when C not in '0' .. '9';
               Append (P.Token, C);
            end loop;
            if C = '.' then
               Append (P.Token, C);
               loop
                  Stream.Read (Char => C);
                  exit when C not in '0' .. '9';
                  Append (P.Token, C);
               end loop;
            end if;
            if C = 'e' or C = 'E' then
               Append (P.Token, C);
               Stream.Read (Char => C);
               if C = '+' or C = '-' then
                  Append (P.Token, C);
                  Stream.Read (Char => C);
               end if;
               loop
                  Stream.Read (Char => C);
                  exit when C not in '0' .. '9';
                  Append (P.Token, C);
               end loop;
            end if;
            if C /= ' ' and C /= Ada.Characters.Latin_1.HT then
               P.Has_Pending_Char := True;
               P.Pending_Char := C;
            end if;
            Token := T_NUMBER;
            return;

            --  Parse a name composed of letters or digits.
         when 'a' .. 'z' | 'A' .. 'Z' =>
            Delete (P.Token, 1, Length (P.Token));
            Append (P.Token, C);
            loop
               Stream.Read (Char => C);
               exit when not (C in 'a' .. 'z' or C in 'A' .. 'Z'
                              or C in '0' .. '9' or C = '_');
               Append (P.Token, C);
            end loop;
            --  Putback the last character unless we can ignore it.
            if C /= ' ' and C /= Ada.Characters.Latin_1.HT then
               P.Has_Pending_Char := True;
               P.Pending_Char := C;
            end if;

            --  and empty eq false ge gt le lt ne not null true
            case Element (P.Token, 1) is
               when 'n' | 'N' =>
                  if P.Token = "null" then
                     Token := T_NULL;
                     return;
                  end if;

               when 'f' | 'F' =>
                  if P.Token = "false" then
                     Token := T_FALSE;
                     return;
                  end if;

               when 't' | 'T' =>
                  if P.Token = "true" then
                     Token := T_TRUE;
                     return;
                  end if;

               when others =>
                  null;
            end case;
            Token := T_UNKNOWN;
            return;

         when '{' =>
            Token := T_LEFT_BRACE;
            return;

         when '}' =>
            Token := T_RIGHT_BRACE;
            return;

         when '[' =>
            Token := T_LEFT_BRACKET;
            return;

         when ']' =>
            Token := T_RIGHT_BRACKET;
            return;

         when ':' =>
            Token := T_COLON;
            return;

         when ',' =>
            Token := T_COMMA;
            return;

         when others =>
            Token := T_UNKNOWN;
            return;
         end case;

      exception
         when Ada.IO_Exceptions.Data_Error =>
            Token := T_EOF;
            return;
      end Peek;

   begin
      Parse (Handler);
   end Parse;

end Util.Serialize.IO.JSON;

-----------------------------------------------------------------------
--  util-serialize-io-json -- JSON Serialization Driver
--  Copyright (C) 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.Characters.Latin_1;
with Ada.IO_Exceptions;

with Util.Strings;
with Util.Streams;
with Util.Streams.Buffered;
package body Util.Serialize.IO.JSON is

   use Ada.Strings.Unbounded;

   --  -----------------------
   --  Write the string as a quoted JSON string
   --  -----------------------
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String) is
   begin
      Stream.Write ('"');
      for I in Value'Range loop
         declare
            C : constant Character := Value (I);
         begin
            if C = '"' then
               Stream.Write ("\""");

            elsif C = '\'  then
               Stream.Write ("\\");

            elsif Character'Pos (C) >= 16#20# then
               Stream.Write (C);

            else
               case C is
                  when Ada.Characters.Latin_1.BS =>
                     Stream.Write ("\b");

                  when Ada.Characters.Latin_1.VT =>
                     Stream.Write ("\f");

                  when Ada.Characters.Latin_1.LF =>
                     Stream.Write ("\n");

                  when Ada.Characters.Latin_1.CR =>
                     Stream.Write ("\r");

                  when Ada.Characters.Latin_1.HT =>
                     Stream.Write ("\t");

                  when others =>
                     Util.Streams.Texts.TR.To_Hex (Streams.Buffered.Buffered_Stream (Stream), C);

               end case;
            end if;
         end;
      end loop;
      Stream.Write ('"');
   end Write_String;

   --  -----------------------
   --  Start writing an object identified by the given name
   --  -----------------------
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is
      Current : access Node_Info := Node_Info_Stack.Current (Stream.Stack);
   begin
      if Current /= null then
         if Current.Has_Fields then
            Stream.Write (',');
         else
            Current.Has_Fields := True;
         end if;
      end if;
      Node_Info_Stack.Push (Stream.Stack);
      Current := Node_Info_Stack.Current (Stream.Stack);
      Current.Has_Fields := False;

      if Name'Length > 0 then
         Stream.Write_String (Name);
         Stream.Write (':');
      end if;
      Stream.Write ('{');
   end Start_Entity;

   --  -----------------------
   --  Finish writing an object identified by the given name
   --  -----------------------
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is
      pragma Unreferenced (Name);
   begin
      Node_Info_Stack.Pop (Stream.Stack);
      Stream.Write ('}');
   end End_Entity;

   --  -----------------------
   --  Write an attribute member from the current object
   --  -----------------------
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;

      Current : constant access Node_Info := Node_Info_Stack.Current (Stream.Stack);
   begin
      if Current /= null then
         if Current.Has_Fields then
            Stream.Write (",");
         else
            Current.Has_Fields := True;
         end if;
      end if;
      Stream.Write_String (Name);
      Stream.Write (':');
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            Stream.Write ("null");

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write_String (Util.Beans.Objects.To_String (Value));

      end case;
   end Write_Attribute;

   --  -----------------------
   --  Write an object value as an entity
   --  -----------------------
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is
   begin
      Stream.Write_Attribute (Name, Value);
   end Write_Entity;

   --  -----------------------
   --  Start an array that will contain the specified number of elements
   --  -----------------------
   procedure Start_Array (Stream : in out Output_Stream;
                          Length : in Ada.Containers.Count_Type) is
      pragma Unreferenced (Length);
   begin
      Node_Info_Stack.Push (Stream.Stack);
      Stream.Write ('[');
   end Start_Array;

   --  -----------------------
   --  Finishes an array
   --  -----------------------
   procedure End_Array (Stream : in out Output_Stream) is
   begin
      Node_Info_Stack.Pop (Stream.Stack);
      Stream.Write (']');
   end End_Array;

   --  -----------------------
   --  Get the current location (file and line) to report an error message.
   --  -----------------------
   function Get_Location (Handler : in Parser) return String is
   begin
      return Util.Strings.Image (Handler.Line_Number);
   end Get_Location;

   procedure Parse (Handler : in out Parser;
                    Stream : in out Util.Streams.Buffered.Buffered_Stream'Class) is

      --  Put back a token in the buffer.
      procedure Put_Back (P     : in out Parser'Class;
                          Token : in Token_Type);

      --  Parse the expression buffer to find the next token.
      procedure Peek (P     : in out Parser'Class;
                      Token : out Token_Type);

      --  Parse a list of members
      --  members ::= pair | pair ',' members
      --  pair    ::= string ':' value
      --  value   ::= string | number | object | array | true | false | null
      procedure Parse_Pairs (P : in out Parser'Class);

      --  Parse a value
      --  value   ::= string | number | object | array | true | false | null
      procedure Parse_Value (P    : in out Parser'Class;
                             Name : in String);

      procedure Parse (P : in out Parser'Class);

      procedure Parse (P : in out Parser'Class) is
         Token : Token_Type;
      begin
         Peek (P, Token);
         if Token /= T_LEFT_BRACE then
            P.Error ("Missing '{'");
         end if;
         Parse_Pairs (P);
         Peek (P, Token);
         if Token /= T_RIGHT_BRACE then
            P.Error ("Missing '}'");
         end if;
      end Parse;

      --  ------------------------------
      --  Parse a list of members
      --  members ::= pair | pair ',' members
      --  pair    ::= string ':' value
      --  value   ::= string | number | object | array | true | false | null
      --  ------------------------------
      procedure Parse_Pairs (P : in out Parser'Class) is
         Current_Name : Unbounded_String;
         Token        : Token_Type;
      begin
         loop
            Peek (P, Token);
            if Token /= T_STRING then
               Put_Back (P, Token);
               return;
            end if;
            Current_Name := P.Token;
            Peek (P, Token);
            if Token /= T_COLON then
               P.Error ("Missing ':'");
            end if;

            Parse_Value (P, To_String (Current_Name));
            Peek (P, Token);
            if Token /= T_COMMA then
               Put_Back (P, Token);
               return;
            end if;
         end loop;
      end Parse_Pairs;

      --  ------------------------------
      --  Parse a value
      --  value   ::= string | number | object | array | true | false | null
      --  ------------------------------
      procedure Parse_Value (P    : in out Parser'Class;
                             Name : in String) is
         Token : Token_Type;
      begin
         Peek (P, Token);
         case Token is
            when T_LEFT_BRACE =>
               P.Start_Object (Name);
               Parse_Pairs (P);
               Peek (P, Token);
               if Token /= T_RIGHT_BRACE then
                  P.Error ("Missing '}'");
               end if;
               P.Finish_Object (Name);

                  --
            when T_LEFT_BRACKET =>
               P.Start_Array (Name);
               Peek (P, Token);
               if Token /= T_RIGHT_BRACKET then
                  Put_Back (P, Token);
                  loop
                     Parse_Value (P, Name);
                     Peek (P, Token);
                     exit when Token = T_RIGHT_BRACKET;
                     if Token /= T_COMMA then
                        P.Error ("Missing ']'");
                     end if;
                  end loop;
               end if;
               P.Finish_Array (Name);

            when T_NULL =>
               P.Set_Member (Name, Util.Beans.Objects.Null_Object);

            when T_NUMBER =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (P.Token));

            when T_STRING =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (P.Token));

            when T_TRUE =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (True));

            when T_FALSE =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (False));

            when T_EOF =>
               P.Error ("End of stream reached");
               return;

            when others =>
               P.Error ("Invalid token");
         end case;
      end Parse_Value;

      --  ------------------------------
      --  Put back a token in the buffer.
      --  ------------------------------
      procedure Put_Back (P     : in out Parser'Class;
                          Token : in Token_Type) is
      begin
         P.Pending_Token := Token;
      end Put_Back;

      --  ------------------------------
      --  Parse the expression buffer to find the next token.
      --  ------------------------------
      procedure Peek (P     : in out Parser'Class;
                      Token : out Token_Type) is
         C, C1 : Character;
      begin
         --  If a token was put back, return it.
         if P.Pending_Token /= T_EOF then
            Token := P.Pending_Token;
            P.Pending_Token := T_EOF;
            return;
         end if;

         if P.Has_Pending_Char then
            C := P.Pending_Char;
         else
            --  Skip white spaces
            loop
               Stream.Read (Char => C);
               if C = Ada.Characters.Latin_1.LF then
                  P.Line_Number := P.Line_Number + 1;
               else
                  exit when C /= ' '
                    and C /= Ada.Characters.Latin_1.CR and C /= Ada.Characters.Latin_1.HT;
               end if;
            end loop;
         end if;
         P.Has_Pending_Char := False;

         --  See what we have and continue parsing.
         case C is
            --  Literal string using double quotes
            --  Collect up to the end of the string and put
            --  the result in the parser token result.
         when '"' =>
            Delete (P.Token, 1, Length (P.Token));
            loop
               Stream.Read (Char => C1);
               if C1 = '\' then
                  Stream.Read (Char => C1);
                  case C1 is
                     when '"' | '\' | '/' =>
                        null;

                     when 'b' =>
                        C1 := Ada.Characters.Latin_1.BS;

                     when 'f' =>
                        C1 := Ada.Characters.Latin_1.VT;

                     when 'n' =>
                        C1 := Ada.Characters.Latin_1.LF;

                     when 'r' =>
                        C1 := Ada.Characters.Latin_1.CR;

                     when 't' =>
                        C1 := Ada.Characters.Latin_1.HT;

                     when 'u' =>
                        null;

                     when others =>
                        P.Error ("Invalid character '" & C1 & "' in \x sequence");

                  end case;
               elsif C1 = C then
                  Token := T_STRING;
                  return;
               end if;
               Append (P.Token, C1);
            end loop;

            --  Number
         when '-' | '0' .. '9' =>
            Delete (P.Token, 1, Length (P.Token));
            Append (P.Token, C);
            loop
               Stream.Read (Char => C);
               exit when C not in '0' .. '9';
               Append (P.Token, C);
            end loop;
            if C = '.' then
               Append (P.Token, C);
               loop
                  Stream.Read (Char => C);
                  exit when C not in '0' .. '9';
                  Append (P.Token, C);
               end loop;
            end if;
            if C = 'e' or C = 'E' then
               Append (P.Token, C);
               Stream.Read (Char => C);
               if C = '+' or C = '-' then
                  Append (P.Token, C);
                  Stream.Read (Char => C);
               end if;
               loop
                  Stream.Read (Char => C);
                  exit when C not in '0' .. '9';
                  Append (P.Token, C);
               end loop;
            end if;
            if C /= ' ' and C /= Ada.Characters.Latin_1.HT then
               P.Has_Pending_Char := True;
               P.Pending_Char := C;
            end if;
            Token := T_NUMBER;
            return;

            --  Parse a name composed of letters or digits.
         when 'a' .. 'z' | 'A' .. 'Z' =>
            Delete (P.Token, 1, Length (P.Token));
            Append (P.Token, C);
            loop
               Stream.Read (Char => C);
               exit when not (C in 'a' .. 'z' or C in 'A' .. 'Z'
                              or C in '0' .. '9' or C = '_');
               Append (P.Token, C);
            end loop;
            --  Putback the last character unless we can ignore it.
            if C /= ' ' and C /= Ada.Characters.Latin_1.HT then
               P.Has_Pending_Char := True;
               P.Pending_Char := C;
            end if;

            --  and empty eq false ge gt le lt ne not null true
            case Element (P.Token, 1) is
               when 'n' | 'N' =>
                  if P.Token = "null" then
                     Token := T_NULL;
                     return;
                  end if;

               when 'f' | 'F' =>
                  if P.Token = "false" then
                     Token := T_FALSE;
                     return;
                  end if;

               when 't' | 'T' =>
                  if P.Token = "true" then
                     Token := T_TRUE;
                     return;
                  end if;

               when others =>
                  null;
            end case;
            Token := T_UNKNOWN;
            return;

         when '{' =>
            Token := T_LEFT_BRACE;
            return;

         when '}' =>
            Token := T_RIGHT_BRACE;
            return;

         when '[' =>
            Token := T_LEFT_BRACKET;
            return;

         when ']' =>
            Token := T_RIGHT_BRACKET;
            return;

         when ':' =>
            Token := T_COLON;
            return;

         when ',' =>
            Token := T_COMMA;
            return;

         when others =>
            Token := T_UNKNOWN;
            return;
         end case;

      exception
         when Ada.IO_Exceptions.Data_Error =>
            Token := T_EOF;
            return;
      end Peek;

   begin
      Parser'Class (Handler).Start_Object ("");
      Parse (Handler);
      Parser'Class (Handler).Finish_Object ("");
   end Parse;

end Util.Serialize.IO.JSON;

Fix parsing and mapping of JSON

Fix parsing and mapping of JSON


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

   Not_Found : exception;

   package Target_Event_Vectors is
     new Ada.Containers.Vectors (Positive, Target_Event_Type);

   subtype Target_Event_Vector is Target_Event_Vectors.Vector;
   subtype Target_Event_Cursor is Target_Event_Vectors.Cursor;

   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Target_Event_Type;

end MAT.Events.Tools;

Declare the MAT.Events.Tools package and move the Target_Event_Vectors definition in it


with Ada.Text_IO;
use Ada.Text_IO;

procedure main is
begin -- Bonjour
    Put("Hello Master Falindir");
end main;

Add ai with ADA

Add ai with ADA


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                            A 4 G . V C H E C K                           --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            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.Exceptions; use Ada.Exceptions;

with Asis;           use Asis;
with Asis.Text;      use Asis.Text;
with Asis.Errors;    use Asis.Errors;

with A4G.A_Types;    use A4G.A_Types;
with A4G.Int_Knds;   use A4G.Int_Knds;

--  This package contains the routines for checking the validity of the
--  arguments of the ASIS queries and for generating the diagnostic info.
--  This package in its current state originated from the very beginning of
--  the ASIS project and it definitely needs revising.

package A4G.Vcheck is

--  GNAT-style reformatting required!! Only formal compatibility with -gnatg
--  is achieved by now.

--  This package contains procedures for checking the validity of the
--  Context, Compilation_Unit and Element values, raising the
--  Asis-defined exceptions (with previous setting of the status
--  value and forming the Diagnosis string) in some standard
--  situations and utility subprograms to be used in the keeping to
--  the "catch-all" policy defined in the subsection 3.6 of the
--  ASIS: Detailed Semantics and Implementation Document (v. 1.1.1)
--
--  The first prototype implementation uses rather roof approach
--  to keep to the "catch-all" policy in respect to the
--  non-Asis-defined exceptions and to handle the status and Diagnosis
--  information. The main principles of this approach are:
--
--  (a) all non-Asis exceptions are caught by
--
--        when others =>
--          Raise_ASIS_Failed (Diagnosis => "Name of the routine in which"
--                             &" this handler is" );
--
--       exception handler, and as a rule no attempt is undertaken
--       to recover from the error situation (Status is set as
--       "Value_Error" and ASIS_Failed is raised);
--
--  (b) Diagnosis string contains only general description of the failure
--      and the indication of the Asis query or low-level implementation
--      utility subprogram in which the Asis-defined exception was initially
--      raised;
--
--  (c) if Asis-defined exception propagates through the Asis implementation,
--      then the information related to the dynamic context of the exception
--      propagation is added to the Diagnosis (and separated by the
--      Asis_Types_And_Limits.ASIS_Line_Terminator constant).
--
--  (d) most of the routines in the Asis implementation should contain the
--      exception handler with the "others" choice (as described in the
--      paragraph (a) above. If it is known that the Asis_defined exception
--      could be raised in the procedure or function body, then the body
--      should contain two following exception handlers in the order given:
--
--      when Asis_ASIS_Inappropriate_Context    |
--          ASIS_Inappropriate_Compilation_Unit |
--          ASIS_Inappropriate_Element            =>
--
--          raise; -- nothing should be done additionally;
--                 -- exception has been raised in the argument(s)
--                 -- validity/appropriation checks in the same
--                 -- frame
--
--      when ASIS_Failed -- | other possible Asis-defined exceptions
--                           =>
--        Add_Call_Information (Outer_Call => "Name of the routine in which"
--                           &" this handler is" );
--        raise; ---????????
--
--      when others =>
--        Raise_ASIS_Failed (Diagnosis => "Name of the routine in which"
--                           &" this handler is" );
--

   procedure Add (Phrase : String);
   --  Adds Phrase to Diagnosis_Buffer and resets Diagnosis_Len. Exits with no
   --  (further) change in Diagnosis_Buffer as soon as Diagnosis_Len attains
   --  Max_Diagnosis_Length.

   ------------------------------------------------------------
   --  Checking the validity of Context, Compilation_Unit and
   --  Element
   ------------------------------------------------------------

------------------------------------------------------------
   procedure Check_Validity
     (Compilation_Unit : Asis.Compilation_Unit;
      Query            : String);
------------------------------------------------------------
--   Compilation_Unit - Specifies the unit to check
--   Query            - Specifies the name of query in which the check
--                      is performed. The parameter value is used to
--                      form the Diagnosis string
--
--  Performs the check if the unit does not belong to the closed library
--  Sets the corresponding Status and forms the corresponding Diagnosis
--  if the check fails
--
--  BETTER DOCS NEEDED!!
---------------------------------------------------------------
   procedure Check_Validity
     (Element : Asis.Element;
      Query   : String);
------------------------------------------------------------
--   Element - Specifies the element to check
--   Query   - Specifies the name of query in which the check is performed.
--             The parameter value is used to form the Diagnosis string
--
--  Performs the check if the element does not belong to the invalid
--  element
--  Sets the corresponding Status and forms the corresponding Diagnosis
--  if the check fails
--
--  BETTER DOCS NEEDED!!
---------------------------------------------------------------
   procedure Check_Validity (Line  : Asis.Text.Line;
                             Query : String);
------------------------------------------------------------
--   Line    - Specifies the Line to check
--   Query   - Specifies the name of query in which the check is performed.
--             The parameter value is used to form the Diagnosis string
--
--  Performs the check if the line does not belong to the invalid
--   Context
--  Sets the corresponding Status and forms the corresponding Diagnosis
--  if the check fails
--
--  BETTER DOCS NEEDED!!
------------------------------------------------------------
   procedure Check_Validity (Context : Asis.Context;
                             Query   : String);
------------------------------------------------------------
--   Context - Specifies the ASIS Context to check
--   Query   - Specifies the name of query in which the check is performed.
--             The parameter value is used to form the Diagnosis string
--
--  Performs the check if the Context is not in inassosiated or inopened
--  state
--  Sets the corresponding Status and forms the corresponding Diagnosis
--  if the check fails
--
--  BETTER DOCS NEEDED!!

   -------------------------------------
   -- Raising Asis-defined exceptions --
   -------------------------------------

   procedure Raise_ASIS_Failed
     (Diagnosis    : String;
      Argument     : Asis.Element            := Nil_Element;
      Stat         : Asis.Errors.Error_Kinds := Internal_Error;
      Bool_Par     : Boolean                 := False;
      Internal_Bug : Boolean := True);
   --  Raises ASIS_Failed with Stat as the value of ASIS Error Status.
   --  Usually expects the query name as Diagnosis. If the corresponding ASIS
   --  standard query has an optional boolean parameter, and if this parameter
   --  is set on for the given call to this query, then Bool_Par is expected to
   --  be set True. Internal_Bug specifies if the procedure is called for an
   --  internal implementation bug.
   --  This routine may be used to raise ASIS_Failed not only for the cases of
   --  internal implementation errors. In this case Internal_Bug should be set
   --  OFF, and Stat should specify the error kind.
   --  If Argument is not IS_Nil, adds the debug image of the argument to the
   --  diagnosis string.

   procedure Raise_ASIS_Failed_In_Traversing
     (Start_Element  : Asis.Element;
      Failure_At     : Asis.Element;
      Pre_Op         : Boolean;
      Exception_Info : String);
   --  Raises ASIS_Failed with Stat as Unhandled_Exception_Error for the
   --  situation  when some non-ASIS exception is raised in actual Pre-
   --  (Pre-Op is set ON) or Post-Operation (Pre_Op is set False). If forms the
   --  diagnostic message indicating the starting Element of the traversal
   --  (should be provided as the actual for Start_Element), the Element for
   --  which the failure took place (actual for Failure_At) and the information
   --  about the exception raised (passed as Exception_Info)

--------------------------------------------------------------------
   procedure Raise_ASIS_Inappropriate_Compilation_Unit
                         (Diagnosis : String);
--------------------------------------------------------------------
--  Diagnosis - Specifies the query to which the Compilation Unit
--              with inappropriate kind was passed
--
--  Raises ASIS_Inappropriate_Compilation_Unit with Value_Error status
--
--  BETTER DOCS NEEDED!!
--------------------------------------------------------------------
   procedure Raise_ASIS_Inappropriate_Element
     (Diagnosis  : String;
      Wrong_Kind : Internal_Element_Kinds;
      Status     : Error_Kinds      := Value_Error);
--------------------------------------------------------------------
--  Diagnosis - Specifies the query to which the Element with
--              inappropriate kind was passed
--
--  Raises ASIS_Inappropriate_Element with Status error status
--
--  BETTER DOCS NEEDED!!
--
--------------------------------------------------------------------
   procedure Raise_ASIS_Inappropriate_Line_Number
     (Diagnosis : String;
      Status    : Error_Kinds      := Value_Error);
--------------------------------------------------------------------
   procedure Not_Implemented_Yet (Diagnosis : String);
--------------------------------------------------------------------
--  Diagnosis - Specifies the query which has not been implemented
--              properly yet and has a placeholder as its body
--
--  Raises ASIS_Failed with Not_Implemented_Error status
--
--  This procedure is used in the placeholder bodies of the non-implemented
--  queries
--
--  BETTER DOCS NEEDED!!
--------------------------------------------------------------------

   ----------------------------------------------
   --  Setting the Status and Diagnosis values --
   ----------------------------------------------

--------------------------------------------------------------------
   procedure Set_Error_Status
     (Status    : Error_Kinds      := Not_An_Error;
      Diagnosis : String := Nil_Asis_String);
--------------------------------------------------------------------
--
--  This procedure is the full analog of the A4G.Set_Status
--  procedure, it is intended to be used as the implementation of the
--  A4G.Set_Status (by means of the renaming_as_a_body
--  in the body of Asis_Environment)
--------------------------------------------------------------------

   -----------------------------
   -- Adding Call Information --
   -----------------------------

   procedure Add_Call_Information
     (Outer_Call : String;
      Argument   : Asis.Element := Nil_Element;
      Bool_Par   : Boolean := False);
   --  Adds in the ASIS diagnosis the information about dynamically enclosing
   --  calls when an ASIS exception is propagated from some dynamically
   --  enclosed routine. If Argument is not Nil, adds its debug image in the
   --  Diagnosis, if needed (that is, if Argument_Postponed flag is set on,
   --  and resets this flag OFF after that)

   pragma No_Return (Raise_ASIS_Failed);
   pragma No_Return (Raise_ASIS_Inappropriate_Compilation_Unit);
   pragma No_Return (Raise_ASIS_Inappropriate_Element);
   pragma No_Return (Not_Implemented_Yet);

   -------------------------------------------
   -- The revised code is below this header --
   -------------------------------------------

   ---------------------------------------------------------------------
   -- Data Objects for Handling the Diagnosis string and Error Status --
   ---------------------------------------------------------------------

   Status_Indicator : Error_Kinds := Not_An_Error;

   Diagnosis_Buffer : String (1 .. Max_Diagnosis_Length);
   Diagnosis_Len    : Natural range 0 .. Max_Diagnosis_Length := 0;
   --  The string buffer to form ASIS Diagnosis

   ---------------------------
   --  ASIS Error handling  --
   ---------------------------

   --  The following documentation item should be revised when the revising of
   --  the ASIS exception handling is completed (BB14-010)

   --  According to the ASIS Standard, only ASIS-defined exceptions are allowed
   --  to be raised by ASIS queries.
   --
   --  The semantics of ASIS_Inappropriate_*** expectations well-defined and is
   --  supposed to be implemented in full conformance with ASIS Standard
   --  requirements.
   --
   --  According to  Asis.Exceptions, ASIS_Failed is "is a catch-all exception
   --  that may be raised for different reasons in different ASIS
   --  implementations".
   --
   --  We are using the following approach to handing and reporting the
   --  internal implementation errors and to raising ASIS_Failed.
   --
   --  1. According to the (rather ill-defined) requirement of the ASIS
   --     Standard and other documents generated during the ASIS
   --     standardization process (in particular, "ASIS: Detailed Semantics and
   --     Implementation. Ada Semantic Interface Specification. ASIS version
   --     1.1.1. April 26, 1994 by Gary E. Barnes), the body of every ASIS
   --     query contains 'when OTHERS' exception handler which does not allow
   --     any non-ASIS exception to propagate out of any ASIS query. (The
   --     exception is a set of rather trivial bodies of ASIS queries for which
   --     raising of non-ASIS exceptions is practically impossible).
   --
   --  2. By default any unexpected exception raise (that is, raising of any
   --     non-ASIS exception because of any reason) is treated as ASIS
   --     implementation error which should be immediately reported and which
   --     does not allow to continue the execution of any ASIS application.
   --     That is, detection of such an error should result in immediate exit
   --     to OS. This is implemented as the default behavior of all the ASIS
   --     and ASIS extensions queries.
   --
   --  3. An application may want to continue its execution even in case when
   --     an internal ASIS implementation error is detected. (The reason could
   --     be to try to use some workarounds for known ASIS implementation
   --     problems and to get the required information by some other ways).
   --     For this the application may set the Keep_Going flag ON by setting
   --     '-k' parameter of Asis.Implementation.Initialize. As a result,
   --     instead of generating the exit to OS, ASIS_Failed is raised with
   --     Unhandled_Exception_Error status.
   --
   --  4. We have some other reasons for raising ASIS_Failed. It can be raised
   --     in case when ASIS is initialized with "treat ASIS warnings as errors"
   --     mode as a part of generating of the ASIS warning. We have to use
   --     ASIS_Failed here, because the ASIS Standard does not give us any
   --     other choice. ASIS_Failed may also be raised by queries from
   --     Asis.Compilation_Units which are not supposed to be used for a
   --     dynamic Context. The important thing is that when ASIS_Failed is
   --     raised as a result of ASIS warning, the Error Status can never be
   --     Unhandled_Exception_Error
   --
   --  5. The general approach to exception handling in our ASIS implementation
   --     is:
   --
   --     - For every standard ASIS query and for every ASIS Extensions query
   --       which is not trivial enough to conclude that raising of any
   --       non-ASIS exception is practically impossible, the body of this
   --       query should contain "when EX : OTHERS' handler, and the only
   --       statement in this handler should be the call to Report_ASIS_Bug
   --       procedure (see the documentation of this procedure below)
   --
   --     - For every standard ASIS query and for every ASIS Extensions query
   --       which is not trivial enough to conclude that generating of the ASIS
   --       failure is practically impossible or for which we can not be sure
   --       that its implementation does not use any other ASIS queries, the
   --       body of this query should contain the handler for ASIS_Failed with
   --       the following code
   --
   --          when ASIS_Failed =>
   --             is Status_Indicator = Unhandled_Exception_Error then
   --                Add_Call_Information (...)
   --             end if;
   --
   --             raise;
   --
   --     The idea in behind is: if ASIS_Failed is the result of the internal
   --     ASIS implementation bug (that is, unexpected exception suppressed),
   --     we are collecting the information of enclosing calls, this may be
   --     useful if the call to one ASIS query is used in the implementation
   --     of some other ASIS query, the full "trace" of calls of the ASIS
   --     queries may be useful for an ASIS application programmer if (s)he
   --     would like to provide protections for ASIS bugs and to use some
   --     workarounds. And if ASIS_Failed is a result of ASIS warning, it
   --     should just propagated out of ASIS with the Diagnosis string formed
   --     as a part of error generation. ASIS_Failed raised when calling
   --     Asis.Compilation_Units queries which can not be used for a dynamic
   --     context could never be raised inside the call to an ASIS query
   --     enclosed into a call to some other ASIS query.

   procedure Report_ASIS_Bug
     (Query_Name    : String;
      Ex            : Exception_Occurrence;
      Arg_Element   : Asis.Element          := Nil_Element;
      Arg_Element_2 : Asis.Element          := Nil_Element;
      Arg_CU        : Asis.Compilation_Unit := Nil_Compilation_Unit;
      Arg_CU_2      : Asis.Compilation_Unit := Nil_Compilation_Unit;
      Arg_Line      : Asis.Text.Line        := Nil_Line;
      Arg_Span      : Asis.Text.Span        := Nil_Span;
      Bool_Par_ON   : Boolean               := False;
      Context_Par   : Boolean               := False
      --  What else???
      );
   pragma No_Return (Report_ASIS_Bug);
   --  This procedure is supposed to be called in "when OTHERS" exception
   --  handlers of an ASIS queries only. If we are in such an exception
   --  handler, then for sure we have detected some ASIS implementation bug.
   --  Depending on the ASIS initialization options, this procedure may
   --  perform the following options:
   --
   --  - generates the ASIS bug box similar to the GNAT bug box generated by
   --    the GNAT Comperr.Compiler_Abort procedure.
   --
   --  - raises ASIS_Failed with the summary of the information which should
   --    go into the ASIS bug box as the ASIS Diagnosis string
   --
   --  - causes the exit to OS.
   --
   --  Either exit to OS or raising ASIS_Failed should take place in any case.
   --  In case of exit to OS, the ASIS bug box should be generated.
   --
   --  The call to this procedure should never result in exception raise (other
   --  then raising ASIS_Failed by purpose), the worst case is that the
   --  diagnostic information formed by this procedure is incomplete.
   --
   --  Query_Name should be set to the full expanded Ada name of the query
   --  where this procedure is called
   --
   --  Ex should be the exception name form enclosing "when Ex : others"
   --  handlers.
   --
   --  All the other parameters are used to compose some debug information
   --  about the parameters of the call which fails. Some ASIS queries have
   --  two Element or Compilation Unit parameters, that's why we need
   --  Arg_Element_2 and Arg_CU_2. For queries having only one Element or CU
   --  parameter, Arg_Element or Arg_CU should be used to pass the argument of
   --  the call to form the diagnostic info.

end A4G.Vcheck;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                        ASIS-for-GNAT COMPONENTS                          --
--                                                                          --
--             A S I S . E X T E N S I O N S . I T E R A T O R              --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--         Copyright (c) 2003-2006, 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).                                                --
--                                                                          --
------------------------------------------------------------------------------

--  This package encapsulates the generic procedure Traverse_Unit which
--  is a generalization of the standard ASIS Asis.Iterator.Traverse_Element
--  procedure. Traverse_Unit traverses all the syntactical components of the
--  argument ASIS Compilation Unit.

package Asis.Extensions.Iterator is

   generic

      type State_Information is limited private;

      with procedure Pre_Operation
                       (Element :        Asis.Element;
                        Control : in out Traverse_Control;
                        State   : in out State_Information) is <>;

      with procedure Post_Operation
                       (Element :        Asis.Element;
                        Control : in out Traverse_Control;
                        State   : in out State_Information) is <>;

   procedure Traverse_Unit
     (Unit    :        Asis.Compilation_Unit;
      Control : in out Traverse_Control;
      State   : in out State_Information);
   --  Traverses all the syntactical structure of the argument Compilation
   --  Unit. In ASIS, a Compilation Unit consists of context clause Elements
   --  and of the Element representing the program unit, and these syntax
   --  elements does not have a common root. Traverse_Unit instantiates
   --  Asis.Iterator.Traverse_Element passing its own formal parameters as
   --  actuals for Traverse_Element. Then it goes into all the
   --  first-depth-level structural components of the argument Compilation
   --  Unit by applying this instance of Traverse_Element to it.
   --
   --  If the value of traverse Control becomes Terminate_Immediately,
   --  traversing of all the unit components is terminated (that is, if it
   --  happens in some context clause Element, the Unit declaration Element
   --  will not be traversed.
   --
   --  Appropriate Unit_Kinds:
   --     A_Procedure
   --     A_Function
   --     A_Package
   --
   --     A_Generic_Procedure
   --     A_Generic_Function
   --     A_Generic_Package
   --
   --     A_Procedure_Instance
   --     A_Function_Instance
   --     A_Package_Instance
   --
   --     A_Procedure_Renaming
   --     A_Function_Renaming
   --     A_Package_Renaming
   --
   --     A_Generic_Procedure_Renaming
   --     A_Generic_Function_Renaming
   --     A_Generic_Package_Renaming
   --
   --     A_Procedure_Body
   --     A_Procedure_Body
   --     A_Function_Body
   --     A_Package_Body
   --
   --     A_Procedure_Body_Subunit
   --     A_Function_Body_Subunit
   --     A_Package_Body_Subunit
   --     A_Task_Body_Subunit
   --     A_Protected_Body_Subunit

end Asis.Extensions.Iterator;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                    A S I S . T E X T . S E T _ G E T                     --
--                                                                          --
--                                 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,  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 Ada.Characters.Handling; use Ada.Characters.Handling;

with Asis.Set_Get;            use Asis.Set_Get;

with A4G.A_Sinput;            use A4G.A_Sinput;
with A4G.Contt;               use A4G.Contt;
with A4G.Contt.TT;            use A4G.Contt.TT;

with Sinput;                  use Sinput;
with Widechar;                use Widechar;

package body Asis.Text.Set_Get is

   ---------
   -- Get --
   ---------

   function Line_Length (L : Line) return Character_Position is
   begin
      return L.Length;
   end Line_Length;

   function Line_Location (L : Line) return Source_Ptr is
   begin
      if not (L.Enclosing_Context = Get_Current_Cont and then
              L.Enclosing_Tree    = Get_Current_Tree)
      then
         Reset_Tree (L.Enclosing_Context, L.Enclosing_Tree);
      end if;

      return L.Sloc;
   end Line_Location;

   function Valid (L : Line) return Boolean is
   begin
      return Is_Opened (L.Enclosing_Context) and then
             Later (Opened_At (L.Enclosing_Context), L.Obtained);
   end Valid;

   ------------------------
   -- Debug_Image (Span) --
   ------------------------

   function Debug_Image (The_Span : Span) return String is
      LT : String renames ASIS_Line_Terminator;
   begin
      return    LT
            & "Debug image for Asis.Text.Span:"
            & LT
            & "First Line   : "
            & Int'Image (Int (The_Span.First_Line))
            & LT
            & "First Column : "
            & Int'Image (Int (The_Span.First_Column))
            & LT
            & "Last Line    : "
            & Int'Image (Int (The_Span.Last_Line))
            & LT
            & "Last Column  : "
            & Int'Image (Int (The_Span.Last_Column))
            & LT
            & LT;
   end Debug_Image;

   ---------------------
   -- Line_Wide_Image --
   ---------------------

   function Line_Wide_Image (L : Line) return Wide_String is
   begin
      if Line_Length (L) = 0 then
         return "";
      end if;

      declare
         Result : Wide_String (1 .. Line_Length (L));

         S       : Source_Ptr := L.Sloc;
         SFI     : constant Source_File_Index := Get_Source_File_Index (S);
         Src     : constant Source_Buffer_Ptr := Source_Text (SFI);
         Next_Ch : Char_Code;
         Success : Boolean;
         pragma Unreferenced (Success);
      begin

         for J in Result'Range loop

               if Is_Start_Of_Wide_Char_For_ASIS (Src, S, L.Comment_Sloc) then
                  Scan_Wide (Src, S, Next_Ch, Success);

                  Result (J) := Wide_Character'Val (Next_Ch);

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

         end loop;

         return Result;
      end;

   end Line_Wide_Image;

   ---------
   -- Set --
   ---------

   procedure Set_Line_Length (L : in out Line; N : Character_Position) is
   begin
      L.Length := N;
   end Set_Line_Length;

   procedure Set_Line_Location (L : in out Line; S : Source_Ptr) is
   begin
      L.Rel_Sloc := L.Rel_Sloc + (S - L.Sloc);
      L.Sloc := S;
   end Set_Line_Location;

   ---------------
   -- Set_Lines --
   ---------------

   procedure Set_Lines (LList : in out Line_List; El : Element) is
      First_Line : constant Line_Number := LList'First;
      Last_Line  : constant Line_Number := LList'Last;
      El_Sloc    : constant Source_Ptr  := Location (El);
      --  This call to Location resets the tree for El, if needed;
      --  and this makes all the routine "tree-swapping-safe"
      Sloc_Move : constant Source_Ptr   := Rel_Sloc (El) - El_Sloc;
      --  Sloc_Move in fact is equal to - Sloc (Top (Enclosing_CU)),
      --  so by adding Sloc_Move we can get relative Sloc for lines:

      --  We define local variables for Element characteristics in order
      --  not to compute this in the loop:
      El_Encl_Unit : constant Unit_Id      := Encl_Unit_Id (El);
      El_Encl_Cont : constant Context_Id   := Encl_Cont_Id (El);
      El_Encl_Tree : constant Tree_Id      := Encl_Tree    (El);
      El_Obtained  : constant ASIS_OS_Time := Obtained     (El);

      SFI : constant Source_File_Index := Get_Source_File_Index (El_Sloc);
      Src_First : constant Source_Ptr := Source_First (SFI);
      Src       : constant Source_Buffer_Ptr := Source_Text (SFI);

      S           : Source_Ptr;
      Wide_Length : Character_Position;
      --  Line length counted in wide characters

      Comment_Pos : Source_Ptr;
      --  Start of the comment in the next line image. Zero if there is no
      --  comment as a part of the line image
   begin
      --  the only thing which requires special processing is
      --  setting of the length of the last Line in LList if
      --  this Line corresponds to the last line in the compilation
      --  containing El.

      --  We start from settings which do not require any
      --  special processing. We take from Element all which can
      --  be safely "transferred" into Lines. Note, that we know,
      --  that El is valid, that is, the Context from which it had been
      --  obtained was not closed after obtaining this Element. So we
      --  simply copy the time when El was obtained in all the Lines
      --  in Line list
      for LN in First_Line .. Last_Line loop
         LList (LN).Enclosing_Unit    := El_Encl_Unit;
         LList (LN).Enclosing_Context := El_Encl_Cont;
         LList (LN).Enclosing_Tree    := El_Encl_Tree;
         LList (LN).Obtained          := El_Obtained;

         LList (LN).Sloc     := Line_Start (Physical_Line_Number (LN), SFI);
         LList (LN).Rel_Sloc := LList (LN).Sloc + Sloc_Move;
      end loop;

      --  Counting Line lengths. Firtst we count length in the internal
      --  representation:
      for LN in First_Line .. Last_Line - 1 loop
         S := LList (LN + 1).Sloc - 1;

         while S > Src_First
            and then
               Is_EOL_Char (Src (S))
            and then
               S >= LList (LN).Sloc
         loop
            S := S - 1;
         end loop;

         if S = Src_First then
            --  Empty lines in the beginning of a source file
            LList (LN).Length := 0;
         else
            LList (LN).Length :=
               Character_Position (S - LList (LN).Sloc + 1);
         end if;

      end loop;

      --  The special case of the last Line in the list:
      S := LList (Last_Line).Sloc;

      while S < Source_Last (SFI)
         and then
            not Is_EOL_Char (Src (S))
      loop
         S := S + 1;
      end loop;

      LList (Last_Line).Length :=
         Character_Position (S - LList (Last_Line).Sloc);

      --  Recompute line lengths, taking into account possible encodings of
      --  upper half characters. The result should be the lengths of the lines
      --  in the original source

      for LN in First_Line .. Last_Line loop

         if LList (LN).Length /= 0 then
            Wide_Length := 0;
            S           := LList (LN).Sloc;
            Comment_Pos := Comment_Beginning
              (Src (S .. S + Source_Ptr (LList (LN).Length) - 1));

            LList (LN).Comment_Sloc := Comment_Pos;

            while S < LList (LN).Sloc + Source_Ptr (LList (LN).Length) loop

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

               Wide_Length := Wide_Length + 1;
            end loop;

            LList (LN).Length := Wide_Length;
         end if;
      end loop;

   end Set_Lines;

end Asis.Text.Set_Get;

Add the ASIS file $i

Add the ASIS file $i


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2021 onox <denkpadje@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 Orka.Numerics.Tensors.SIMD_CPU;

with Orka.SIMD.AVX.Doubles.Arithmetic;
with Orka.SIMD.AVX.Doubles.Compare;
with Orka.SIMD.AVX.Doubles.Logical;
with Orka.SIMD.AVX.Doubles.Math;
with Orka.SIMD.AVX.Longs.Logical;
with Orka.SIMD.AVX2.Longs.Arithmetic;
with Orka.SIMD.AVX2.Longs.Logical;
with Orka.SIMD.AVX2.Longs.Shift;
with Orka.SIMD.AVX2.Longs.Random;

package Orka.Numerics.Doubles.Tensors.CPU is new Orka.Numerics.Doubles.Tensors.SIMD_CPU
  (Index_4D,
   Integer_64,
   SIMD.AVX.Longs.m256l,
   SIMD.AVX2.Longs.Arithmetic."+",
   SIMD.AVX2.Longs.Logical."and",
   SIMD.AVX2.Longs.Shift.Shift_Elements_Left_Zeros,
   SIMD.AVX2.Longs.Shift.Shift_Elements_Right_Zeros,
   SIMD.AVX.Longs.Logical.Test_All_Ones,
   SIMD.AVX.Longs.Logical.Test_All_Zero,
   SIMD.AVX.Doubles.m256d,
   SIMD.AVX.Doubles.Arithmetic."*",
   SIMD.AVX.Doubles.Arithmetic."/",
   SIMD.AVX.Doubles.Arithmetic."+",
   SIMD.AVX.Doubles.Arithmetic."-",
   SIMD.AVX.Doubles.Arithmetic."-",
   SIMD.AVX.Doubles.Arithmetic."abs",
   SIMD.AVX.Doubles.Arithmetic.Sum,
   SIMD.AVX.Doubles.Arithmetic.Divide_Or_Zero,
   SIMD.AVX.Doubles.Math.Sqrt,
   SIMD.AVX.Doubles.Math.Min,
   SIMD.AVX.Doubles.Math.Max,
   SIMD.AVX.Doubles.Math.Ceil,
   SIMD.AVX.Doubles.Math.Floor,
   SIMD.AVX.Doubles.Math.Round_Nearest_Integer,
   SIMD.AVX.Doubles.Math.Round_Truncate,
   SIMD.AVX.Doubles.Logical.And_Not,
   SIMD.AVX.Doubles.Logical."and",
   SIMD.AVX.Doubles.Logical."or",
   SIMD.AVX.Doubles.Logical."xor",
   SIMD.AVX.Doubles.Compare."=",
   SIMD.AVX.Doubles.Compare."/=",
   SIMD.AVX.Doubles.Compare.">",
   SIMD.AVX.Doubles.Compare."<",
   SIMD.AVX.Doubles.Compare.">=",
   SIMD.AVX.Doubles.Compare."<=",
   SIMD.AVX2.Longs.Random.State,
   SIMD.AVX2.Longs.Random.Next,
   SIMD.AVX2.Longs.Random.Reset);
pragma Preelaborate (Orka.Numerics.Doubles.Tensors.CPU);

numerics: Add instantiation of SIMD_CPU for Float_64 using AVX2

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


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

with Gtk.Main;
package body MAT.Callbacks is

   --  ------------------------------
   --  Callback executed when the "quit" action is executed from the menu.
   --  ------------------------------
   procedure On_Menu_Quit (Object : access Gtkada.Builder.Gtkada_Builder_Record'Class) is
   begin
      Gtk.Main.Main_Quit;
   end On_Menu_Quit;

end MAT.Callbacks;

Implement the On_Menu_Quit procedure

Implement the On_Menu_Quit procedure


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . A _ T Y P E S                           --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (C) 1995-2012, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU  General  Public  License  distributed with ASIS-for-GNAT;  see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  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.Latin_1;  use  Ada.Characters.Latin_1;
with Ada.Characters.Handling; use  Ada.Characters.Handling;

with GNAT.OS_Lib;             use  GNAT.OS_Lib;

package A4G.A_Types is

   pragma Elaborate_Body (A4G.A_Types);

--  This package is the ASIS implementation's analog of the GNAT Types
--  package (except the part related to the ASIS_OS_Time type).
--  It contains host independent type and constant definitions
--  which is supposed to be used in more than one unit in the ASIS
--  implementation.

   ------------------
   -- ASIS_OS_Time --
   ------------------

   --  To check, that a given abstraction is valid in the sense defined by the
   --  ASIS standard (that is, that the enclosing Context of the given
   --  abstraction has not been closed after creating this abstraction), ASIS
   --  needs some kind of logical time (or logical time stamp). This logical
   --  time is increased each time when any ASIS Context is opened. It is not
   --  reset when ASIS is initialized, because it may lead to collisions in
   --  validity checks

   --  An ASIS abstraction is valid if its logical time stamp is equal or
   --  greater than the time stamp of its enclosing Context.

   type ASIS_OS_Time is private;

   Nil_ASIS_OS_Time  : constant ASIS_OS_Time;
   Last_ASIS_OS_Time : constant ASIS_OS_Time;

   procedure Increase_ASIS_OS_Time;
   --  Increases the ASIS logical "clock"

   function A_OS_Time return ASIS_OS_Time;
   --  Gets the current value of the ASIS logical "clock"

   function Later (L, R : ASIS_OS_Time) return Boolean;
   --  Compares time stamps.

   -----------------------------------------
   -- Types for Context and Context Table --
   -----------------------------------------

   Inconsistent_Incremental_Context : exception;
   --  raised when any inconsistency found for Incremental Tree processing
   --  mode

   Context_Low_Bound  : constant :=         0;
   Context_High_Bound : constant := 1_000_000;

   type Context_Id is range Context_Low_Bound .. Context_High_Bound;
   --  Type used to identify entries in ASIS Context table

   Non_Associated   : constant Context_Id := Context_Low_Bound;
   Nil_Context_Id   : constant Context_Id := Context_Low_Bound;
   First_Context_Id : constant Context_Id := Context_Low_Bound + 1;

   ---------------------------------------------
   -- Types for Container and Container Table --
   ---------------------------------------------

   Container_Low_Bound  : constant :=   0;
   Container_High_Bound : constant := 100;

   type Container_Id is range Container_Low_Bound .. Container_High_Bound;
   --  Type used to identify entries in ASIS Container table

   Nil_Container_Id   : constant Container_Id := Container_Low_Bound;
   First_Container_Id : constant Container_Id := Container_Low_Bound + 1;

   -----------------------------------------------
   -- Types for Compilation_Unit and Unit Table --
   -----------------------------------------------

   Unit_Low_Bound  : constant :=       0;
   Unit_High_Bound : constant := 100_000;

   type Unit_Id is range Unit_Low_Bound .. Unit_High_Bound;
   --  Type used to identify entries in the ASIS Unit table

   Nil_Unit   : constant Unit_Id := Unit_Low_Bound;
   No_Unit_Id :          Unit_Id renames Nil_Unit;

   First_Unit_Id : constant Unit_Id := Unit_Low_Bound + 1;
   Standard_Id   : constant Unit_Id := First_Unit_Id;
   --  The entry in the Unit table corresponding to the package Standard
   --  Standard goes first in any Unit table

   Config_Comp_Id : constant Unit_Id := Standard_Id + 1;
   --  The entry in the Unit table corresponding to the artificial
   --  A_Configuration_Compilation unit. We may have at most one such unit.
   --  If there is no configuration pragmas in the Context, there is no harm
   --  to allocate such a unit, because the only way for an ASIS client to get
   --  it is to get the enclosing unit for a configuration pragma.

   type Unit_Id_List is array (Natural range <>) of Unit_Id;
   Nil_Unit_Id_List : constant Unit_Id_List (1 .. 0) := (others => Nil_Unit);

   --------------------------
   -- Types for Tree Table --
   --------------------------

   Tree_Low_Bound  : constant :=       0;
   Tree_High_Bound : constant := 100_000;

   type Tree_Id is range Tree_Low_Bound .. Tree_High_Bound;
   --  Type used to identify entries in ASIS Tree table

   Nil_Tree      : constant Tree_Id := Tree_Low_Bound;
   No_Tree_Name  : Tree_Id renames Nil_Tree; --  ???
   First_Tree_Id : constant Tree_Id := Tree_Low_Bound + 1;

   -----------------------------------------------
   -- Types for Search Directories Paths Tables --
   -----------------------------------------------

   No_Dir       : constant :=     0;
   First_Dir_Id : constant :=     1;
   Last_Dir_Id  : constant := 1_000;

   type Dir_Id is range No_Dir .. Last_Dir_Id;

   type Search_Dir_Kinds is (
      Source, --  for source search path
      Object, --  for object search path
      Tree);  --  for tree search path
   --  this type may be further expanded

   --------------------------------------------
   --  Types for Internal Element Structure  --
   --------------------------------------------

   type Special_Cases is (
   --  this enumeration type is needed to distinguish some special
   --  cases in Element constructing and handling
      Not_A_Special_Case,

      A_Dummy_Block_Statement,
      --  the result of an obsolescent function
      --  Declarations.Body_Block_Statement

      Predefined_Operation,
      --  indicates the predefined operation for a user-defined type
      --  (or component thereof???). Note, that such an operation is
      --  defined not in the Standard package.

      Explicit_From_Standard,
      --  indicates the explicit Element obtained  from the package
      --  Standard. "Explicit" means here any construct which is
      --  contained in the "source" text of Standard included in RM95
      --  plus explicit constants substituting "implementation-defined"
      --  italic strings in this "source"

      Numeric_Error_Renaming,
      --  Indicates the artificial ASIS Element created to represent the
      --  obsolete renaming of Numeric_Error in the package Standard
      --  (see B712-005)

      Implicit_From_Standard,
      --  indicates the implicit Element obtained from the package
      --  Standard, that is, implicitly declared predefined operations
      --  and their components, and root and universal numeric type
      --  definitions and declarations

      Stand_Char_Literal,
      --  indicates the defining character literal declared in the
      --  definition of the predefined type Standard.Character
      --  or Standard.Wide_Character. An ASIS Element representing such
      --  a literal has no corresponding node in the tree, and it is
      --  based on the N_Defining_Identifier node for the corresponding
      --  type

      Expanded_Package_Instantiation,
      --  indicates A_Package_Declaration element which represents the
      --  package declaration which is the result of an instantiation
      --  of a generic package

      Expanded_Subprogram_Instantiation,
      --  indicates A_Procedure_Declaration or A_Function_Declaration
      --  element which represents the package declaration which is the
      --  result of an instantiation of a generic package

      Configuration_File_Pragma,
      --  Indicates a configuration pragma belonging not to the source of some
      --  Ada compilation unit, but to the configuration file (an components
      --  thereof)

      Rewritten_Named_Number,
      --  Indicates An_Identifier Element representing a named number in the
      --  situation when the corresponding tree structure is rewritten into
      --  N_Integer/Real_Literal node and no original tree structure is
      --  available (see BB10-002)

      Is_From_Gen_Association,
      --  See D722-012.
      --  The problem here is that in case of a formal object, the front-end
      --  creates the renaming declaration as a means to pass an actual
      --  parameter, and the parameter itself (the corresponding tree node)
      --  is used as a part of this renaming declaration. So we have a problem
      --  with Enclosing_Element. The Parent pointer from this actual points
      --  to the renaming declaration structure. In case if we are not in the
      --  expanded code, we may compare levels of instantiation and it helps,
      --  but in general case it is too complicated. So the solution is to
      --  mark the corresponding node if it comes from the generic association
      --  (and we can gen into this node only by means of a structural query!)
      --  and to use this mark in the Enclosing_Element processing.

      Is_From_Imp_Neq_Declaration,
      --  Indicates if the given element is an implicit declaration of the
      --  "/=" operation corresponding to the explicit redefinition of "=" or
      --  a subcomponent thereof

--      Implicit_Inherited_Subprogram
      --  indicates the declaration of an implicit inherited user-defined
      --  subprogram or a component thereof.
      --  may be continued...

      Dummy_Base_Attribute_Designator,
      Dummy_Class_Attribute_Designator,
      Dummy_Base_Attribute_Prefix,
      Dummy_Class_Attribute_Prefix,
      --  These four values are used to mark components of the artificial
      --  'Base and 'Class attribute reference that ASIS has to simulate when
      --  processing references to a formal type in the instantiation in case
      --  when a formal type is an unconstrained type, and the actual type is a
      --  'Class attribute, or when an actual is a 'Base attribute and the
      --  front-end creates too much of artificial data structures in the tree.

      From_Limited_View
      --  The corresponding Element is (a part of) a package or type limited
      --  view, see RM 05 10.1.1 (12.1/2 .. 12.5.2)

      --  may be continued...

   );

   type Normalization_Cases is (
   --  This enumeration type represents the different possible states of
   --  An_Association Elements in respect to normalization of associations
      Is_Not_Normalized,
      Is_Normalized,
      --  normalized association created for an actual parameter which itself
      --  is presented at the place of the call/instantiation
      Is_Normalized_Defaulted,
      --  normalized association created for an actual parameter which itself
      --  is NOT presented at the place of the call/instantiation, so the
      --  default value should be used
      Is_Normalized_Defaulted_For_Box);
      --  normalized association created for an actual parameter which itself
      --  is NOT presented at the place of the instantiation and the definition
      --  of the formal parameter includes box as the default value, so the
      --  actual parameter should be found at the place of the instantiation

   subtype Expanded_Spec is Special_Cases
     range Expanded_Package_Instantiation .. Expanded_Subprogram_Instantiation;

   subtype Normalized_Association is Normalization_Cases
     range Is_Normalized .. Is_Normalized_Defaulted_For_Box;

   subtype Defaulted_Association is Normalization_Cases
     range Is_Normalized_Defaulted .. Is_Normalized_Defaulted_For_Box;

   subtype Predefined is Special_Cases
     range Predefined_Operation .. Stand_Char_Literal;

   --  COMMENTS
   --
   --  *1* Handling the Parenthesized Expressions and
   --      One_Pair_Of_Parentheses_Away and Two_Pairs_Of_Parentheses_Away
   --      Special Cases.
   --
   --      An Asis Element of A_Parenthesized_Expression could be built
   --      on the base of any tree node which could be used for building the
   --      elements of all other An_Expresion subordinate kinds.
   --      A_Parenthesized_Expression kind is determined by comparing (during
   --      the automatic Internal_Element_Kinds determination only!!!) the
   --      Paren_Count field of the node with zero - see Sinfo.ads, the
   --      documentation item for "4.4  (Primary)" RM subsection, and
   --      Atree.ads the documentation item related to the Paren_Count field.
   --
   --      When a subexpression is to be selected from the element of
   --      A_Parenthesized_Expression kind by the
   --      Asis_Definition.Expression_Parenthesized function, the result will
   --      be built on the base of just the same node as the argument having,
   --      just the same value of the Paren_Count field. If the argument has
   --      more than one pair of parentheses, the result will also be of

   --     A_Parenthesized_Expression kind, and the Special_Cases values
   --     One_Pair_Of_Parentheses_Away and Two_Pairs_Of_Parentheses_Away
   --     are intended to be used to count the pairs of parentheses remained
   --     in the result element. All the corresponding element kind
   --     determination and element construction should be performed in
   --     "by-hand" mode, except the case when the argument parenthesized
   --     expression has only one pair of parentheses.
   --
   --     GNAT cannot distinguish more than three levels of the enclosing
   --     pairs of parentheses for a non-parenthesized enclosed expression.
   --     (Paren_Count = 3 stands for any number of the enclosing parentheses
   --     equal or greater than 3.) So ASIS-for-GNAT implementation cannot
   --     do more than GNAT itself (of course, we could do some search in the
   --     source buffer, but we prefer to agree with GNAT team that even
   --     Paren_Count = 3 already is a pathological case :).
   --
   --     See also Asis_Definition.Expression_Parenthesized (body) and
   --     A4G.Mapping.Node_To_Element (body)
   --
   --  *2* Root/Universal types definitions - we do not need any special
   --      value for representing elements of Root_Type_Kinds, because for
   --      each value there may be only one Element of the corresponding kind
   --      in a given opened Context.
   --

   -------------------------
   -- Nil String constants--
   -------------------------

   Nil_Asis_String      : constant String      := "";
   Nil_Asis_Wide_String : constant Wide_String := "";

   -------------------------------------------------
   --  Constants for the Diagnosis string buffer  --
   -------------------------------------------------

   ASIS_Line_Terminator : constant String := (1 => LF);
   --  what about DOS-like end-of-line?

   Diagnosis_String_Length : constant Positive :=
     76 + ASIS_Line_Terminator'Length;
   --  We are trying to set ASIS_Line_Terminator in the Diagnosis string to
   --  keep text strings at most 76 characters long

   Max_Diagnosis_Length : constant Positive := 32 * Diagnosis_String_Length;
   --  The length of the buffer in which the Diagnosis string is formed,
   --  now it is at most 32 lines 76 character each. Should be enough for
   --  any practically meaningful diagnosis

   Asis_Wide_Line_Terminator : constant Wide_String :=
      (1 => To_Wide_Character (LF));
   --
   --  the physical line terminator, is used in the Diagnosis string
   --  to separate the parts of the diagnosis message
   --  See also documentation of the Skip_Line_Terminators procedure
   --  in the (GNAT.)sinput.adb

   ASIS_Line_Terminator_Len : constant Positive
                            := ASIS_Line_Terminator'Length;

   Incorrect_Setting : constant String := "Attempt to set Not_An_Error "
                                & "status with non-nil diagnosis string";

   Incorrect_Setting_Len : constant Positive := Incorrect_Setting'Length;

   -------------------
   -- Miscellaneous --
   -------------------

   ASIS_Path_Separator : Character;
   --  Is initialized in the package body. Takes into account that in VMS
   --  ',' should be used instead of GNAT.OS_Lib.Path_Separator.

   ASIS_Current_Directory : String_Access;
   --  Is initialized in the package body. "[]" in VMS, "." otherwise

   function Asis_Normalize_Pathname
     (Name           : String;
      Directory      : String  := "";
      Resolve_Links  : Boolean := True;
      Case_Sensitive : Boolean := True) return String;
   --  ASIS version of GNAT.OS_Lib.Normalize_Pathname. It applies
   --  To_Host_Dir_Spec to the result of GNAT.OS_Lib.Normalize_Pathname.
   --  Should be applied to directory names only! For file names
   --  GNAT.OS_Lib.Normalize_Pathname should be used.
   --  ??? Is this the right place for this subprogram???

   Internal_Implementation_Error : exception;
   --  Means exactly this. Is supposed to be raised in control statement
   --  paths which should never be reached. We need this exception mostly
   --  because some parts of old ASIS code (developed at the research stage of
   --  the ASIS project) sometimes are not structured properly.

   function Parameter_String_To_List
     (Par_String : String)
      return       Argument_List_Access;
   --  Take a string that is a converted to the String type Parameters string
   --  of the ASIS query Initialize, Associate or Finalize (??? Should we
   --  process the original Wide_String Parameters string without converting
   --  it to String?) and parse it into an Argument_List.
   --
   --  This function is similar to GNAT.OS_Int.Argument_String_To_List, but
   --  it does not treat '\' as a backquoting character.

private

   type ASIS_OS_Time is new Long_Integer range 0 .. Long_Integer'Last;

   ASIS_Clock : ASIS_OS_Time := 1;
   --  This is the ASIS logical "clock" used to ret ASIS logical time.

   Nil_ASIS_OS_Time  : constant ASIS_OS_Time := 0;
   Last_ASIS_OS_Time : constant ASIS_OS_Time := ASIS_OS_Time'Last;

end A4G.A_Types;

Add the ASIS file $i

Add the ASIS file $i