blob: 845da1247403a5d4e71e93bc1cedddb2501a78f7 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- R E P I N F O - I N P U T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2018-2022, 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. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- 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;
with Ttypes;
package body Repinfo.Input is
SSU : Pos renames Ttypes.System_Storage_Unit;
-- Value for Storage_Unit
type JSON_Entity_Kind is (JE_Record_Type, JE_Array_Type, JE_Other);
-- Kind of an entity
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 No (Position) or else No (First_Bit) 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 nonempty 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;