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