--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- R E P I N F O - I N P U T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- --
+-- 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 Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Alloc;
+with Csets; use Csets;
+with Hostparm; use Hostparm;
+with Namet; use Namet;
+with Output; use Output;
+with Snames; use Snames;
+with Table;
+
+package body Repinfo.Input is
+
+ SSU : constant := 8;
+ -- Value for Storage_Unit, we do not want to get this from TTypes, since
+ -- this introduces problematic dependencies in ASIS, and in any case this
+ -- value is assumed to be 8 for the implementation of the DDA.
+
+ type JSON_Entity_Kind is (JE_Record_Type, JE_Array_Type, JE_Other);
+ -- Kind of an entiy
+
+ type JSON_Entity_Node (Kind : JSON_Entity_Kind := JE_Other) is record
+ Esize : Node_Ref_Or_Val;
+ RM_Size : Node_Ref_Or_Val;
+ case Kind is
+ when JE_Record_Type => Variant : Nat;
+ when JE_Array_Type => Component_Size : Node_Ref_Or_Val;
+ when JE_Other => Dummy : Boolean;
+ end case;
+ end record;
+ pragma Unchecked_Union (JSON_Entity_Node);
+ -- Record to represent an entity
+
+ package JSON_Entity_Table is new Table.Table (
+ Table_Component_Type => JSON_Entity_Node,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => Alloc.Rep_JSON_Table_Initial,
+ Table_Increment => Alloc.Rep_JSON_Table_Increment,
+ Table_Name => "JSON_Entity_Table");
+ -- Table of entities
+
+ type JSON_Component_Node is record
+ Bit_Offset : Node_Ref_Or_Val;
+ Esize : Node_Ref_Or_Val;
+ end record;
+ -- Record to represent a component
+
+ package JSON_Component_Table is new Table.Table (
+ Table_Component_Type => JSON_Component_Node,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => Alloc.Rep_JSON_Table_Initial,
+ Table_Increment => Alloc.Rep_JSON_Table_Increment,
+ Table_Name => "JSON_Component_Table");
+ -- Table of components
+
+ type JSON_Variant_Node is record
+ Present : Node_Ref_Or_Val;
+ Variant : Nat;
+ Next : Nat;
+ end record;
+ -- Record to represent a variant
+
+ package JSON_Variant_Table is new Table.Table (
+ Table_Component_Type => JSON_Variant_Node,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => Alloc.Rep_JSON_Table_Initial,
+ Table_Increment => Alloc.Rep_JSON_Table_Increment,
+ Table_Name => "JSON_Variant_Table");
+ -- Table of variants
+
+ -------------------------------------
+ -- Get_JSON_Component_Bit_Offset --
+ -------------------------------------
+
+ function Get_JSON_Component_Bit_Offset
+ (Name : String;
+ Record_Name : String) return Node_Ref_Or_Val
+ is
+ Namid : constant Valid_Name_Id := Name_Find (Record_Name & '.' & Name);
+ Index : constant Int := Get_Name_Table_Int (Namid);
+
+ begin
+ -- Return No_Uint if no information is available for the component
+
+ if Index = 0 then
+ return No_Uint;
+ end if;
+
+ return JSON_Component_Table.Table (Index).Bit_Offset;
+ end Get_JSON_Component_Bit_Offset;
+
+ -------------------------------
+ -- Get_JSON_Component_Size --
+ -------------------------------
+
+ function Get_JSON_Component_Size (Name : String) return Node_Ref_Or_Val is
+ Namid : constant Valid_Name_Id := Name_Find (Name);
+ Index : constant Int := Get_Name_Table_Int (Namid);
+
+ begin
+ -- Return No_Uint if no information is available for the component
+
+ if Index = 0 then
+ return No_Uint;
+ end if;
+
+ return JSON_Entity_Table.Table (Index).Component_Size;
+ end Get_JSON_Component_Size;
+
+ ----------------------
+ -- Get_JSON_Esize --
+ ----------------------
+
+ function Get_JSON_Esize (Name : String) return Node_Ref_Or_Val is
+ Namid : constant Valid_Name_Id := Name_Find (Name);
+ Index : constant Int := Get_Name_Table_Int (Namid);
+
+ begin
+ -- Return No_Uint if no information is available for the entity
+
+ if Index = 0 then
+ return No_Uint;
+ end if;
+
+ return JSON_Entity_Table.Table (Index).Esize;
+ end Get_JSON_Esize;
+
+ ----------------------
+ -- Get_JSON_Esize --
+ ----------------------
+
+ function Get_JSON_Esize
+ (Name : String;
+ Record_Name : String) return Node_Ref_Or_Val
+ is
+ Namid : constant Valid_Name_Id := Name_Find (Record_Name & '.' & Name);
+ Index : constant Int := Get_Name_Table_Int (Namid);
+
+ begin
+ -- Return No_Uint if no information is available for the entity
+
+ if Index = 0 then
+ return No_Uint;
+ end if;
+
+ return JSON_Component_Table.Table (Index).Esize;
+ end Get_JSON_Esize;
+
+ ------------------------
+ -- Get_JSON_RM_Size --
+ ------------------------
+
+ function Get_JSON_RM_Size (Name : String) return Node_Ref_Or_Val is
+ Namid : constant Valid_Name_Id := Name_Find (Name);
+ Index : constant Int := Get_Name_Table_Int (Namid);
+
+ begin
+ -- Return No_Uint if no information is available for the entity
+
+ if Index = 0 then
+ return No_Uint;
+ end if;
+
+ return JSON_Entity_Table.Table (Index).RM_Size;
+ end Get_JSON_RM_Size;
+
+ -----------------------
+ -- Read_JSON_Stream --
+ -----------------------
+
+ procedure Read_JSON_Stream (Text : Text_Buffer; File_Name : String) is
+
+ type Text_Position is record
+ Index : Text_Ptr := 0;
+ Line : Natural := 0;
+ Column : Natural := 0;
+ end record;
+ -- Record to represent position in the text
+
+ type Token_Kind is
+ (J_NULL,
+ J_TRUE,
+ J_FALSE,
+ J_NUMBER,
+ J_INTEGER,
+ J_STRING,
+ J_ARRAY,
+ J_OBJECT,
+ J_ARRAY_END,
+ J_OBJECT_END,
+ J_COMMA,
+ J_COLON,
+ J_EOF);
+ -- JSON Token kind. Note that in ECMA 404 there is no notion of integer.
+ -- Only numbers are supported. In our implementation we return J_INTEGER
+ -- if there is no decimal part in the number. The semantic is that this
+ -- is a J_NUMBER token that might be represented as an integer. Special
+ -- token J_EOF means that end of stream has been reached.
+
+ function Decode_Integer (Lo, Hi : Text_Ptr) return Uint;
+ -- Decode and return the integer in Text (Lo .. Hi)
+
+ function Decode_Name (Lo, Hi : Text_Ptr) return Valid_Name_Id;
+ -- Decode and return the name in Text (Lo .. Hi)
+
+ function Decode_Symbol (Lo, Hi : Text_Ptr) return TCode;
+ -- Decode and return the expression symbol in Text (Lo .. Hi)
+
+ procedure Error (Msg : String);
+ pragma No_Return (Error);
+ -- Print an error message and raise an exception
+
+ procedure Read_Entity;
+ -- Read an entity
+
+ function Read_Name return Valid_Name_Id;
+ -- Read a name
+
+ function Read_Name_With_Prefix return Valid_Name_Id;
+ -- Read a name and prepend a prefix
+
+ function Read_Number return Uint;
+ -- Read a number
+
+ function Read_Numerical_Expr return Node_Ref_Or_Val;
+ -- Read a numerical expression
+
+ procedure Read_Record;
+ -- Read a record
+
+ function Read_String return Valid_Name_Id;
+ -- Read a string
+
+ procedure Read_Token
+ (Kind : out Token_Kind;
+ Token_Start : out Text_Position;
+ Token_End : out Text_Position);
+ -- Read a token and return it (this is a standard JSON lexer)
+
+ procedure Read_Token_And_Error
+ (TK : Token_Kind;
+ Token_Start : out Text_Position;
+ Token_End : out Text_Position);
+ pragma Inline (Read_Token_And_Error);
+ -- Read a specified token and error out on failure
+
+ function Read_Variant_Part return Nat;
+ -- Read a variant part
+
+ procedure Skip_Value;
+ -- Skip a value
+
+ Pos : Text_Position := (Text'First, 1, 1);
+ -- The current position in the text buffer
+
+ Name_Buffer : Bounded_String (4 * Max_Name_Length);
+ -- The buffer used to build full qualifed names
+
+ Prefix_Len : Natural := 0;
+ -- The length of the prefix present in Name_Buffer
+
+ ----------------------
+ -- Decode_Integer --
+ ----------------------
+
+ function Decode_Integer (Lo, Hi : Text_Ptr) return Uint is
+ Len : constant Nat := Int (Hi) - Int (Lo) + 1;
+
+ begin
+ -- Decode up to 9 characters manually, otherwise call into Uint
+
+ if Len < 10 then
+ declare
+ Val : Int := 0;
+
+ begin
+ for J in Lo .. Hi loop
+ Val := Val * 10
+ + Character'Pos (Text (J)) - Character'Pos ('0');
+ end loop;
+ return UI_From_Int (Val);
+ end;
+
+ else
+ declare
+ Val : Uint := Uint_0;
+
+ begin
+ for J in Lo .. Hi loop
+ Val := Val * 10
+ + Character'Pos (Text (J)) - Character'Pos ('0');
+ end loop;
+ return Val;
+ end;
+ end if;
+ end Decode_Integer;
+
+ -------------------
+ -- Decode_Name --
+ -------------------
+
+ function Decode_Name (Lo, Hi : Text_Ptr) return Valid_Name_Id is
+ begin
+ -- Names are stored in lower case so fold them if need be
+
+ if Is_Upper_Case_Letter (Text (Lo)) then
+ declare
+ S : String (Integer (Lo) .. Integer (Hi));
+
+ begin
+ for J in Lo .. Hi loop
+ S (Integer (J)) := Fold_Lower (Text (J));
+ end loop;
+
+ return Name_Find (S);
+ end;
+
+ else
+ declare
+ S : String (Integer (Lo) .. Integer (Hi));
+ for S'Address use Text (Lo)'Address;
+
+ begin
+ return Name_Find (S);
+ end;
+ end if;
+ end Decode_Name;
+
+ ---------------------
+ -- Decode_Symbol --
+ ---------------------
+
+ function Decode_Symbol (Lo, Hi : Text_Ptr) return TCode is
+
+ function Cmp12 (A, B : Character) return Boolean;
+ pragma Inline (Cmp12);
+ -- Compare Text (Lo + 1 .. Lo + 2) with A & B.
+
+ -------------
+ -- Cmp12 --
+ -------------
+
+ function Cmp12 (A, B : Character) return Boolean is
+ begin
+ return Text (Lo + 1) = A and then Text (Lo + 2) = B;
+ end Cmp12;
+
+ Len : constant Nat := Int (Hi) - Int (Lo) + 1;
+
+ -- Start of processing for Decode_Symbol
+
+ begin
+ case Len is
+ when 1 =>
+ case Text (Lo) is
+ when '+' =>
+ return Plus_Expr;
+ when '-' =>
+ return Minus_Expr; -- or Negate_Expr
+ when '*' =>
+ return Mult_Expr;
+ when '<' =>
+ return Lt_Expr;
+ when '>' =>
+ return Gt_Expr;
+ when '&' =>
+ return Bit_And_Expr;
+ when '#' =>
+ return Discrim_Val;
+ when others =>
+ null;
+ end case;
+ when 2 =>
+ if Text (Lo) = '/' then
+ case Text (Lo + 1) is
+ when 't' =>
+ return Trunc_Div_Expr;
+ when 'c' =>
+ return Ceil_Div_Expr;
+ when 'f' =>
+ return Floor_Div_Expr;
+ when 'e' =>
+ return Exact_Div_Expr;
+ when others =>
+ null;
+ end case;
+ elsif Text (Lo + 1) = '=' then
+ case Text (Lo) is
+ when '<' =>
+ return Le_Expr;
+ when '>' =>
+ return Ge_Expr;
+ when '=' =>
+ return Eq_Expr;
+ when '!' =>
+ return Ne_Expr;
+ when others =>
+ null;
+ end case;
+ elsif Text (Lo) = 'o' and then Text (Lo + 1) = 'r' then
+ return Truth_Or_Expr;
+ end if;
+ when 3 =>
+ case Text (Lo) is
+ when '?' =>
+ if Cmp12 ('<', '>') then
+ return Cond_Expr;
+ end if;
+ when 'a' =>
+ if Cmp12 ('b', 's') then
+ return Abs_Expr;
+ elsif Cmp12 ('n', 'd') then
+ return Truth_And_Expr;
+ end if;
+ when 'm' =>
+ if Cmp12 ('a', 'x') then
+ return Max_Expr;
+ elsif Cmp12 ('i', 'n') then
+ return Min_Expr;
+ end if;
+ when 'n' =>
+ if Cmp12 ('o', 't') then
+ return Truth_Not_Expr;
+ end if;
+ when 'x' =>
+ if Cmp12 ('o', 'r') then
+ return Truth_Xor_Expr;
+ end if;
+ when 'v' =>
+ if Cmp12 ('a', 'r') then
+ return Dynamic_Val;
+ end if;
+ when others =>
+ null;
+ end case;
+ when 4 =>
+ if Text (Lo) = 'm'
+ and then Text (Lo + 1) = 'o'
+ and then Text (Lo + 2) = 'd'
+ then
+ case Text (Lo + 3) is
+ when 't' =>
+ return Trunc_Mod_Expr;
+ when 'c' =>
+ return Ceil_Mod_Expr;
+ when 'f' =>
+ return Floor_Mod_Expr;
+ when others =>
+ null;
+ end case;
+ end if;
+
+ pragma Annotate
+ (CodePeer, Intentional,
+ "condition predetermined", "Error called as defensive code");
+
+ when others =>
+ null;
+ end case;
+
+ Error ("unknown symbol");
+ end Decode_Symbol;
+
+ -----------
+ -- Error --
+ -----------
+
+ procedure Error (Msg : String) is
+ L : constant String := Pos.Line'Img;
+ C : constant String := Pos.Column'Img;
+
+ begin
+ Set_Standard_Error;
+ Write_Eol;
+ Write_Str (File_Name);
+ Write_Char (':');
+ Write_Str (L (L'First + 1 .. L'Last));
+ Write_Char (':');
+ Write_Str (C (C'First + 1 .. C'Last));
+ Write_Char (':');
+ Write_Line (Msg);
+ raise Invalid_JSON_Stream;
+ end Error;
+
+ ------------------
+ -- Read_Entity --
+ ------------------
+
+ procedure Read_Entity is
+ Ent : JSON_Entity_Node;
+ Nam : Name_Id := No_Name;
+ Siz : Node_Ref_Or_Val;
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+ TK : Token_Kind;
+
+ begin
+ Ent.Esize := No_Uint;
+ Ent.RM_Size := No_Uint;
+ Ent.Component_Size := No_Uint;
+
+ -- Read the members as string : value pairs
+
+ loop
+ case Read_String is
+ when Name_Name =>
+ Nam := Read_Name;
+ when Name_Record =>
+ if Nam = No_Name then
+ Error ("name expected");
+ end if;
+ Ent.Variant := 0;
+ Prefix_Len := Natural (Length_Of_Name (Nam));
+ Name_Buffer.Chars (1 .. Prefix_Len) := Get_Name_String (Nam);
+ Read_Record;
+ when Name_Variant =>
+ Ent.Variant := Read_Variant_Part;
+ when Name_Size =>
+ Siz := Read_Numerical_Expr;
+ Ent.Esize := Siz;
+ Ent.RM_Size := Siz;
+ when Name_Object_Size =>
+ Ent.Esize := Read_Numerical_Expr;
+ when Name_Value_Size =>
+ Ent.RM_Size := Read_Numerical_Expr;
+ when Name_Component_Size =>
+ Ent.Component_Size := Read_Numerical_Expr;
+ when others =>
+ Skip_Value;
+ end case;
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_OBJECT_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+ end loop;
+
+ -- Store the entity into the table
+
+ JSON_Entity_Table.Append (Ent);
+
+ -- Associate the name with the entity
+
+ if Nam = No_Name then
+ Error ("name expected");
+ end if;
+
+ Set_Name_Table_Int (Nam, JSON_Entity_Table.Last);
+ end Read_Entity;
+
+ -----------------
+ -- Read_Name --
+ -----------------
+
+ function Read_Name return Valid_Name_Id is
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+
+ begin
+ -- Read a single string
+
+ Read_Token_And_Error (J_STRING, Token_Start, Token_End);
+
+ return Decode_Name (Token_Start.Index + 1, Token_End.Index - 1);
+ end Read_Name;
+
+ -----------------------------
+ -- Read_Name_With_Prefix --
+ -----------------------------
+
+ function Read_Name_With_Prefix return Valid_Name_Id is
+ Len : Natural;
+ Lo, Hi : Text_Ptr;
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+
+ begin
+ -- Read a single string
+
+ Read_Token_And_Error (J_STRING, Token_Start, Token_End);
+ Lo := Token_Start.Index + 1;
+ Hi := Token_End.Index - 1;
+
+ -- Prepare for the concatenation with the prefix
+
+ Len := Integer (Hi) - Integer (Lo) + 1;
+ if Prefix_Len + 1 + Len > Name_Buffer.Max_Length then
+ Error ("Name buffer too small");
+ end if;
+
+ Name_Buffer.Length := Prefix_Len + 1 + Len;
+ Name_Buffer.Chars (Prefix_Len + 1) := '.';
+
+ -- Names are stored in lower case so fold them if need be
+
+ if Is_Upper_Case_Letter (Text (Lo)) then
+ for J in Lo .. Hi loop
+ Name_Buffer.Chars (Prefix_Len + 2 + Integer (J - Lo)) :=
+ Fold_Lower (Text (J));
+ end loop;
+
+ else
+ declare
+ S : String (Integer (Lo) .. Integer (Hi));
+ for S'Address use Text (Lo)'Address;
+
+ begin
+ Name_Buffer.Chars (Prefix_Len + 2 .. Prefix_Len + 1 + Len) := S;
+ end;
+ end if;
+
+ return Name_Find (Name_Buffer);
+ end Read_Name_With_Prefix;
+
+ ------------------
+ -- Read_Number --
+ ------------------
+
+ function Read_Number return Uint is
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+
+ begin
+ -- Only integers are to be expected here
+
+ Read_Token_And_Error (J_INTEGER, Token_Start, Token_End);
+
+ return Decode_Integer (Token_Start.Index, Token_End.Index);
+ end Read_Number;
+
+ --------------------------
+ -- Read_Numerical_Expr --
+ --------------------------
+
+ function Read_Numerical_Expr return Node_Ref_Or_Val is
+ Code : TCode;
+ Nop : Integer;
+ Ops : array (1 .. 3) of Node_Ref_Or_Val;
+ TK : Token_Kind;
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+
+ begin
+ -- Read either an integer or an expression
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_INTEGER then
+ return Decode_Integer (Token_Start.Index, Token_End.Index);
+
+ elsif TK = J_OBJECT then
+ -- Read the code of the expression and decode it
+
+ if Read_String /= Name_Code then
+ Error ("name expected");
+ end if;
+
+ Read_Token_And_Error (J_STRING, Token_Start, Token_End);
+ Code := Decode_Symbol (Token_Start.Index + 1, Token_End.Index - 1);
+ Read_Token_And_Error (J_COMMA, Token_Start, Token_End);
+
+ -- Read the array of operands
+
+ if Read_String /= Name_Operands then
+ Error ("operands expected");
+ end if;
+
+ Read_Token_And_Error (J_ARRAY, Token_Start, Token_End);
+
+ Nop := 0;
+ Ops := (others => No_Uint);
+ loop
+ Nop := Nop + 1;
+ Ops (Nop) := Read_Numerical_Expr;
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_ARRAY_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+ end loop;
+
+ Read_Token_And_Error (J_OBJECT_END, Token_Start, Token_End);
+
+ -- Resolve the ambiguity for '-' now
+
+ if Code = Minus_Expr and then Nop = 1 then
+ Code := Negate_Expr;
+ end if;
+
+ return Create_Node (Code, Ops (1), Ops (2), Ops (3));
+
+ else
+ Error ("numerical expression expected");
+ end if;
+ end Read_Numerical_Expr;
+
+ -------------------
+ -- Read_Record --
+ -------------------
+
+ procedure Read_Record is
+ Comp : JSON_Component_Node;
+ First_Bit : Node_Ref_Or_Val := No_Uint;
+ Is_First : Boolean := True;
+ Nam : Name_Id := No_Name;
+ Position : Node_Ref_Or_Val := No_Uint;
+ TK : Token_Kind;
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+
+ begin
+ -- Read a possibly empty array of components
+
+ Read_Token_And_Error (J_ARRAY, Token_Start, Token_End);
+
+ loop
+ Read_Token (TK, Token_Start, Token_End);
+ if Is_First and then TK = J_ARRAY_END then
+ exit;
+ elsif TK /= J_OBJECT then
+ Error ("object expected");
+ end if;
+
+ -- Read the members as string : value pairs
+
+ loop
+ case Read_String is
+ when Name_Name =>
+ Nam := Read_Name_With_Prefix;
+ when Name_Discriminant =>
+ Skip_Value;
+ when Name_Position =>
+ Position := Read_Numerical_Expr;
+ when Name_First_Bit =>
+ First_Bit := Read_Number;
+ when Name_Size =>
+ Comp.Esize := Read_Numerical_Expr;
+ when others =>
+ Error ("invalid component");
+ end case;
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_OBJECT_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+ end loop;
+
+ -- Compute Component_Bit_Offset from Position and First_Bit,
+ -- either symbolically or literally depending on Position.
+
+ if Position = No_Uint or else First_Bit = No_Uint then
+ Error ("bit offset expected");
+ end if;
+
+ if Position < Uint_0 then
+ declare
+ Bit_Position : constant Node_Ref_Or_Val :=
+ Create_Node (Mult_Expr, Position, UI_From_Int (SSU));
+ begin
+ if First_Bit = Uint_0 then
+ Comp.Bit_Offset := Bit_Position;
+ else
+ Comp.Bit_Offset :=
+ Create_Node (Plus_Expr, Bit_Position, First_Bit);
+ end if;
+ end;
+ else
+ Comp.Bit_Offset := Position * SSU + First_Bit;
+ end if;
+
+ -- Store the component into the table
+
+ JSON_Component_Table.Append (Comp);
+
+ -- Associate the name with the component
+
+ if Nam = No_Name then
+ Error ("name expected");
+ end if;
+
+ Set_Name_Table_Int (Nam, JSON_Component_Table.Last);
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_ARRAY_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+
+ Is_First := False;
+ end loop;
+ end Read_Record;
+
+ ------------------
+ -- Read_String --
+ ------------------
+
+ function Read_String return Valid_Name_Id is
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+ Nam : Valid_Name_Id;
+
+ begin
+ -- Read the string and the following colon
+
+ Read_Token_And_Error (J_STRING, Token_Start, Token_End);
+ Nam := Decode_Name (Token_Start.Index + 1, Token_End.Index - 1);
+ Read_Token_And_Error (J_COLON, Token_Start, Token_End);
+
+ return Nam;
+ end Read_String;
+
+ ------------------
+ -- Read_Token --
+ ------------------
+
+ procedure Read_Token
+ (Kind : out Token_Kind;
+ Token_Start : out Text_Position;
+ Token_End : out Text_Position)
+ is
+ procedure Next_Char;
+ -- Update Pos to point to next char
+
+ function Is_Whitespace return Boolean;
+ pragma Inline (Is_Whitespace);
+ -- Return True of current character is a whitespace
+
+ function Is_Structural_Token return Boolean;
+ pragma Inline (Is_Structural_Token);
+ -- Return True if current character is one of the structural tokens
+
+ function Is_Token_Sep return Boolean;
+ pragma Inline (Is_Token_Sep);
+ -- Return True if current character is a token separator
+
+ procedure Delimit_Keyword (Kw : String);
+ -- Helper function to parse tokens such as null, false and true
+
+ ---------------
+ -- Next_Char --
+ ---------------
+
+ procedure Next_Char is
+ begin
+ if Pos.Index > Text'Last then
+ Pos.Column := Pos.Column + 1;
+ elsif Text (Pos.Index) = ASCII.LF then
+ Pos.Column := 1;
+ Pos.Line := Pos.Line + 1;
+ else
+ Pos.Column := Pos.Column + 1;
+ end if;
+ Pos.Index := Pos.Index + 1;
+ end Next_Char;
+
+ -------------------
+ -- Is_Whitespace --
+ -------------------
+
+ function Is_Whitespace return Boolean is
+ begin
+ return
+ Pos.Index <= Text'Last
+ and then
+ (Text (Pos.Index) = ASCII.LF
+ or else
+ Text (Pos.Index) = ASCII.CR
+ or else
+ Text (Pos.Index) = ASCII.HT
+ or else
+ Text (Pos.Index) = ' ');
+ end Is_Whitespace;
+
+ -------------------------
+ -- Is_Structural_Token --
+ -------------------------
+
+ function Is_Structural_Token return Boolean is
+ begin
+ return
+ Pos.Index <= Text'Last
+ and then
+ (Text (Pos.Index) = '['
+ or else
+ Text (Pos.Index) = ']'
+ or else
+ Text (Pos.Index) = '{'
+ or else
+ Text (Pos.Index) = '}'
+ or else
+ Text (Pos.Index) = ','
+ or else
+ Text (Pos.Index) = ':');
+ end Is_Structural_Token;
+
+ ------------------
+ -- Is_Token_Sep --
+ ------------------
+
+ function Is_Token_Sep return Boolean is
+ begin
+ return
+ Pos.Index > Text'Last
+ or else
+ Is_Whitespace
+ or else
+ Is_Structural_Token;
+ end Is_Token_Sep;
+
+ ---------------------
+ -- Delimit_Keyword --
+ ---------------------
+
+ procedure Delimit_Keyword (Kw : String) is
+ pragma Unreferenced (Kw);
+ begin
+ while not Is_Token_Sep loop
+ Token_End := Pos;
+ Next_Char;
+ end loop;
+ end Delimit_Keyword;
+
+ CC : Character;
+ Can_Be_Integer : Boolean := True;
+
+ -- Start of processing for Read_Token
+
+ begin
+ -- Skip leading whitespaces
+
+ while Is_Whitespace loop
+ Next_Char;
+ end loop;
+
+ -- Initialize token delimiters
+
+ Token_Start := Pos;
+ Token_End := Pos;
+
+ -- End of stream reached
+
+ if Pos.Index > Text'Last then
+ Kind := J_EOF;
+ return;
+ end if;
+
+ CC := Text (Pos.Index);
+
+ if CC = '[' then
+ Next_Char;
+ Kind := J_ARRAY;
+ return;
+ elsif CC = ']' then
+ Next_Char;
+ Kind := J_ARRAY_END;
+ return;
+ elsif CC = '{' then
+ Next_Char;
+ Kind := J_OBJECT;
+ return;
+ elsif CC = '}' then
+ Next_Char;
+ Kind := J_OBJECT_END;
+ return;
+ elsif CC = ',' then
+ Next_Char;
+ Kind := J_COMMA;
+ return;
+ elsif CC = ':' then
+ Next_Char;
+ Kind := J_COLON;
+ return;
+ elsif CC = 'n' then
+ Delimit_Keyword ("null");
+ Kind := J_NULL;
+ return;
+ elsif CC = 'f' then
+ Delimit_Keyword ("false");
+ Kind := J_FALSE;
+ return;
+ elsif CC = 't' then
+ Delimit_Keyword ("true");
+ Kind := J_TRUE;
+ return;
+ elsif CC = '"' then
+ -- We expect a string
+ -- Just scan till the end the of the string but do not attempt
+ -- to decode it. This means that even if we get a string token
+ -- it might not be a valid string from the ECMA 404 point of
+ -- view.
+
+ Next_Char;
+ while Pos.Index <= Text'Last and then Text (Pos.Index) /= '"' loop
+ if Text (Pos.Index) in ASCII.NUL .. ASCII.US then
+ Error ("control character not allowed in string");
+ end if;
+
+ if Text (Pos.Index) = '\' then
+ Next_Char;
+ if Pos.Index > Text'Last then
+ Error ("non terminated string token");
+ end if;
+
+ case Text (Pos.Index) is
+ when 'u' =>
+ for Idx in 1 .. 4 loop
+ Next_Char;
+ if Pos.Index > Text'Last
+ or else (Text (Pos.Index) not in 'a' .. 'f'
+ and then
+ Text (Pos.Index) not in 'A' .. 'F'
+ and then
+ Text (Pos.Index) not in '0' .. '9')
+ then
+ Error ("invalid unicode escape sequence");
+ end if;
+ end loop;
+ when '\' | '/' | '"' | 'b' | 'f' | 'n' | 'r' | 't' =>
+ null;
+ when others =>
+ Error ("invalid escape sequence");
+ end case;
+ end if;
+ Next_Char;
+ end loop;
+
+ -- No quote found report and error
+
+ if Pos.Index > Text'Last then
+ Error ("non terminated string token");
+ end if;
+
+ Token_End := Pos;
+
+ -- Go to next char and ensure that this is separator. Indeed
+ -- construction such as "string1""string2" are not allowed
+
+ Next_Char;
+ if not Is_Token_Sep then
+ Error ("invalid syntax");
+ end if;
+ Kind := J_STRING;
+ return;
+ elsif CC = '-' or else CC in '0' .. '9' then
+ -- We expect a number
+ if CC = '-' then
+ Next_Char;
+ end if;
+
+ if Pos.Index > Text'Last then
+ Error ("invalid number");
+ end if;
+
+ -- Parse integer part of a number. Superfluous leading zeros are
+ -- not allowed.
+
+ if Text (Pos.Index) = '0' then
+ Token_End := Pos;
+ Next_Char;
+ elsif Text (Pos.Index) in '1' .. '9' then
+ Token_End := Pos;
+ Next_Char;
+ while Pos.Index <= Text'Last
+ and then Text (Pos.Index) in '0' .. '9'
+ loop
+ Token_End := Pos;
+ Next_Char;
+ end loop;
+ else
+ Error ("invalid number");
+ end if;
+
+ if Is_Token_Sep then
+ -- Valid integer number
+
+ Kind := J_INTEGER;
+ return;
+ elsif Text (Pos.Index) /= '.'
+ and then Text (Pos.Index) /= 'e'
+ and then Text (Pos.Index) /= 'E'
+ then
+ Error ("invalid number");
+ end if;
+
+ -- Check for a fractional part
+
+ if Text (Pos.Index) = '.' then
+ Can_Be_Integer := False;
+ Token_End := Pos;
+ Next_Char;
+ if Pos.Index > Text'Last
+ or else Text (Pos.Index) not in '0' .. '9'
+ then
+ Error ("invalid number");
+ end if;
+
+ while Pos.Index <= Text'Last
+ and then Text (Pos.Index) in '0' .. '9'
+ loop
+ Token_End := Pos;
+ Next_Char;
+ end loop;
+
+ end if;
+
+ -- Check for exponent part
+
+ if Pos.Index <= Text'Last
+ and then (Text (Pos.Index) = 'e' or else Text (Pos.Index) = 'E')
+ then
+ Token_End := Pos;
+ Next_Char;
+ if Pos.Index > Text'Last then
+ Error ("invalid number");
+ end if;
+
+ if Text (Pos.Index) = '-' then
+ -- Also a few corner cases can lead to an integer, assume
+ -- that the number is not an integer.
+
+ Can_Be_Integer := False;
+ end if;
+
+ if Text (Pos.Index) = '-' or else Text (Pos.Index) = '+' then
+ Next_Char;
+ end if;
+
+ if Pos.Index > Text'Last
+ or else Text (Pos.Index) not in '0' .. '9'
+ then
+ Error ("invalid number");
+ end if;
+
+ while Pos.Index <= Text'Last
+ and then Text (Pos.Index) in '0' .. '9'
+ loop
+ Token_End := Pos;
+ Next_Char;
+ end loop;
+ end if;
+
+ if Is_Token_Sep then
+ -- Valid decimal number
+
+ if Can_Be_Integer then
+ Kind := J_INTEGER;
+ else
+ Kind := J_NUMBER;
+ end if;
+ return;
+ else
+ Error ("invalid number");
+ end if;
+ elsif CC = EOF then
+ Kind := J_EOF;
+ else
+ Error ("Unexpected character");
+ end if;
+ end Read_Token;
+
+ ----------------------------
+ -- Read_Token_And_Error --
+ ----------------------------
+
+ procedure Read_Token_And_Error
+ (TK : Token_Kind;
+ Token_Start : out Text_Position;
+ Token_End : out Text_Position)
+ is
+ Kind : Token_Kind;
+
+ begin
+ -- Read a token and errout out if not of the expected kind
+
+ Read_Token (Kind, Token_Start, Token_End);
+ if Kind /= TK then
+ Error ("specific token expected");
+ end if;
+ end Read_Token_And_Error;
+
+ -------------------------
+ -- Read_Variant_Part --
+ -------------------------
+
+ function Read_Variant_Part return Nat is
+ Next : Nat := 0;
+ TK : Token_Kind;
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+ Var : JSON_Variant_Node;
+
+ begin
+ -- Read a non-empty array of components
+
+ Read_Token_And_Error (J_ARRAY, Token_Start, Token_End);
+
+ loop
+ Read_Token_And_Error (J_OBJECT, Token_Start, Token_End);
+
+ Var.Variant := 0;
+
+ -- Read the members as string : value pairs
+
+ loop
+ case Read_String is
+ when Name_Present =>
+ Var.Present := Read_Numerical_Expr;
+ when Name_Record =>
+ Read_Record;
+ when Name_Variant =>
+ Var.Variant := Read_Variant_Part;
+ when others =>
+ Error ("invalid variant");
+ end case;
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_OBJECT_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+ end loop;
+
+ -- Chain the variant and store it into the table
+
+ Var.Next := Next;
+ JSON_Variant_Table.Append (Var);
+ Next := JSON_Variant_Table.Last;
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_ARRAY_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+ end loop;
+
+ return Next;
+ end Read_Variant_Part;
+
+ ------------------
+ -- Skip_Value --
+ ------------------
+
+ procedure Skip_Value is
+ Array_Depth : Natural := 0;
+ Object_Depth : Natural := 0;
+ TK : Token_Kind;
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+
+ begin
+ -- Read a value without recursing
+
+ loop
+ Read_Token (TK, Token_Start, Token_End);
+
+ case TK is
+ when J_STRING | J_INTEGER | J_NUMBER =>
+ null;
+ when J_ARRAY =>
+ Array_Depth := Array_Depth + 1;
+ when J_ARRAY_END =>
+ Array_Depth := Array_Depth - 1;
+ when J_OBJECT =>
+ Object_Depth := Object_Depth + 1;
+ when J_OBJECT_END =>
+ Object_Depth := Object_Depth - 1;
+ when J_COLON | J_COMMA =>
+ if Array_Depth = 0 and then Object_Depth = 0 then
+ Error ("value expected");
+ end if;
+ when others =>
+ Error ("value expected");
+ end case;
+
+ exit when Array_Depth = 0 and then Object_Depth = 0;
+ end loop;
+ end Skip_Value;
+
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+ TK : Token_Kind;
+ Is_First : Boolean := True;
+
+ -- Start of processing for Read_JSON_Stream
+
+ begin
+ -- Read a possibly empty array of entities
+
+ Read_Token_And_Error (J_ARRAY, Token_Start, Token_End);
+
+ loop
+ Read_Token (TK, Token_Start, Token_End);
+ if Is_First and then TK = J_ARRAY_END then
+ exit;
+ elsif TK /= J_OBJECT then
+ Error ("object expected");
+ end if;
+
+ Read_Entity;
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_ARRAY_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+
+ Is_First := False;
+ end loop;
+ end Read_JSON_Stream;
+
+end Repinfo.Input;
projects / gcc.git / commitdiff