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