mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-28 11:30:19 +00:00
1344 lines
41 KiB
Ada
1344 lines
41 KiB
Ada
|
------------------------------------------------------------------------------
|
||
|
-- --
|
||
|
-- 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;
|