Description: [Ada] New Repinfo.Input unit to read back JSON representation info.
ASIS/GPL-2019 depends on repinfo-input.ad[bs] from gnat_util/GPL-2019.
gnat_utils/GPL-2019 duplicates sources from GCC/GPL-2019.
.
In Debian, we avoid code duplication and build gnat_util directly
from GCC-9 sources (under the name gnatvsn for historical reasons).
.
repinfo-input exists in GCC/GPL-2019 but not yet in GCC/9,
so we cherry-pick the upstream commit introducing it.
Origin: https://gcc.gnu.org/git/?p=gcc.git;a=commitdiff;h=5dc190e5b8095871578958225d5c4ad515417576
--- a/src/gcc/ada/alloc.ads
+++ b/src/gcc/ada/alloc.ads
@@ -116,6 +116,9 @@
Rep_Table_Initial : constant := 1000; -- Repinfo
Rep_Table_Increment : constant := 200;
+ Rep_JSON_Table_Initial : constant := 10; -- Repinfo
+ Rep_JSON_Table_Increment : constant := 200;
+
Scope_Stack_Initial : constant := 10; -- Sem
Scope_Stack_Increment : constant := 200;
--- a/src/gcc/ada/debug.adb
+++ b/src/gcc/ada/debug.adb
@@ -154,7 +154,7 @@
-- d_g
-- d_h
-- d_i Ignore activations and calls to instances for elaboration
- -- d_j
+ -- d_j Read JSON files and populate Repinfo tables (opposite of -gnatRjs)
-- d_k
-- d_l
-- d_m
@@ -988,6 +988,10 @@
-- subprogram or task type defined in an external instance for both
-- the static and dynamic elaboration models.
+ -- d_j The compiler reads JSON files that would be generated by the same
+ -- compilation session if -gnatRjs was passed, in order to populate
+ -- the internal tables of the Repinfo unit from them.
+
-- d_p The compiler ignores calls to subprograms which verify the run-time
-- semantics of invariants and postconditions in both the static and
-- dynamic elaboration models.
--- a/src/gcc/ada/gcc-interface/Make-lang.in
+++ b/src/gcc/ada/gcc-interface/Make-lang.in
@@ -355,6 +355,7 @@
ada/prep.o \
ada/prepcomp.o \
ada/put_scos.o \
+ ada/repinfo-input.o \
ada/repinfo.o \
ada/restrict.o \
ada/rident.o \
--- a/src/gcc/ada/gnat1drv.adb
+++ b/src/gcc/ada/gnat1drv.adb
@@ -51,6 +51,7 @@
with Par_SCO;
with Prepcomp;
with Repinfo;
+with Repinfo.Input;
with Restrict;
with Rident; use Rident;
with Rtsfind;
@@ -66,6 +67,7 @@
with Sem_Type;
with Set_Targ;
with Sinfo; use Sinfo;
+with Sinput; use Sinput;
with Sinput.L; use Sinput.L;
with Snames; use Snames;
with Sprint; use Sprint;
@@ -114,6 +116,12 @@
-- the information provided by the back end in back annotation of declared
-- entities (e.g. actual size and alignment values chosen by the back end).
+ procedure Read_JSON_Files_For_Repinfo;
+ -- This procedure exercises the JSON parser of Repinfo by reading back the
+ -- JSON files generated by -gnatRjs in a previous compilation session. It
+ -- is intended to make sure that the JSON generator and the JSON parser are
+ -- kept synchronized when the JSON format evolves.
+
----------------------------
-- Adjust_Global_Switches --
----------------------------
@@ -1037,6 +1045,38 @@ procedure Gnat1drv is
-- end if;
end Post_Compilation_Validation_Checks;
+ -----------------------------------
+ -- Read_JSON_Files_For_Repinfo --
+ -----------------------------------
+
+ procedure Read_JSON_Files_For_Repinfo is
+ begin
+ -- This is the same loop construct as in Repinfo.List_Rep_Info
+
+ for U in Main_Unit .. Last_Unit loop
+ if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
+ declare
+ Nam : constant String :=
+ Get_Name_String (File_Name (Source_Index (U))) & ".json";
+ Namid : constant File_Name_Type := Name_Enter (Nam);
+ Index : constant Source_File_Index := Load_Config_File (Namid);
+
+ begin
+ if Index = No_Source_File then
+ Write_Str ("cannot locate ");
+ Write_Line (Nam);
+ raise Unrecoverable_Error;
+ end if;
+
+ Repinfo.Input.Read_JSON_Stream (Source_Text (Index).all, Nam);
+ exception
+ when Repinfo.Input.Invalid_JSON_Stream =>
+ raise Unrecoverable_Error;
+ end;
+ end if;
+ end loop;
+ end Read_JSON_Files_For_Repinfo;
+
-- Local variables
Back_End_Mode : Back_End.Back_End_Mode_Type;
@@ -1103,7 +1143,6 @@ begin
-- Acquire target parameters from system.ads (package System source)
Targparm_Acquire : declare
- use Sinput;
S : Source_File_Index;
N : File_Name_Type;
@@ -1571,6 +1610,12 @@ begin
Par_SCO.SCO_Record_Filtered;
end if;
+ -- If -gnatd_j is specified, exercise the JSON parser of Repinfo
+
+ if Debug_Flag_Underscore_J then
+ Read_JSON_Files_For_Repinfo;
+ end if;
+
-- Back end needs to explicitly unlock tables it needs to touch
Atree.Lock;
--- /dev/null
+++ b/src/gcc/ada/repinfo-input.adb
@@ -0,0 +1,1350 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- R E P I N F O - I N P U T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- . --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Alloc;
+with Csets; use Csets;
+with Hostparm; use Hostparm;
+with Namet; use Namet;
+with Output; use Output;
+with Snames; use Snames;
+with Table;
+
+package body Repinfo.Input is
+
+ SSU : constant := 8;
+ -- Value for Storage_Unit, we do not want to get this from TTypes, since
+ -- this introduces problematic dependencies in ASIS, and in any case this
+ -- value is assumed to be 8 for the implementation of the DDA.
+
+ type JSON_Entity_Kind is (JE_Record_Type, JE_Array_Type, JE_Other);
+ -- Kind of an entiy
+
+ type JSON_Entity_Node (Kind : JSON_Entity_Kind := JE_Other) is record
+ Esize : Node_Ref_Or_Val;
+ RM_Size : Node_Ref_Or_Val;
+ case Kind is
+ when JE_Record_Type => Variant : Nat;
+ when JE_Array_Type => Component_Size : Node_Ref_Or_Val;
+ when JE_Other => Dummy : Boolean;
+ end case;
+ end record;
+ pragma Unchecked_Union (JSON_Entity_Node);
+ -- Record to represent an entity
+
+ package JSON_Entity_Table is new Table.Table (
+ Table_Component_Type => JSON_Entity_Node,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => Alloc.Rep_JSON_Table_Initial,
+ Table_Increment => Alloc.Rep_JSON_Table_Increment,
+ Table_Name => "JSON_Entity_Table");
+ -- Table of entities
+
+ type JSON_Component_Node is record
+ Bit_Offset : Node_Ref_Or_Val;
+ Esize : Node_Ref_Or_Val;
+ end record;
+ -- Record to represent a component
+
+ package JSON_Component_Table is new Table.Table (
+ Table_Component_Type => JSON_Component_Node,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => Alloc.Rep_JSON_Table_Initial,
+ Table_Increment => Alloc.Rep_JSON_Table_Increment,
+ Table_Name => "JSON_Component_Table");
+ -- Table of components
+
+ type JSON_Variant_Node is record
+ Present : Node_Ref_Or_Val;
+ Variant : Nat;
+ Next : Nat;
+ end record;
+ -- Record to represent a variant
+
+ package JSON_Variant_Table is new Table.Table (
+ Table_Component_Type => JSON_Variant_Node,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => Alloc.Rep_JSON_Table_Initial,
+ Table_Increment => Alloc.Rep_JSON_Table_Increment,
+ Table_Name => "JSON_Variant_Table");
+ -- Table of variants
+
+ -------------------------------------
+ -- Get_JSON_Component_Bit_Offset --
+ -------------------------------------
+
+ function Get_JSON_Component_Bit_Offset
+ (Name : String;
+ Record_Name : String) return Node_Ref_Or_Val
+ is
+ Namid : constant Valid_Name_Id := Name_Find (Record_Name & '.' & Name);
+ Index : constant Int := Get_Name_Table_Int (Namid);
+
+ begin
+ -- Return No_Uint if no information is available for the component
+
+ if Index = 0 then
+ return No_Uint;
+ end if;
+
+ return JSON_Component_Table.Table (Index).Bit_Offset;
+ end Get_JSON_Component_Bit_Offset;
+
+ -------------------------------
+ -- Get_JSON_Component_Size --
+ -------------------------------
+
+ function Get_JSON_Component_Size (Name : String) return Node_Ref_Or_Val is
+ Namid : constant Valid_Name_Id := Name_Find (Name);
+ Index : constant Int := Get_Name_Table_Int (Namid);
+
+ begin
+ -- Return No_Uint if no information is available for the component
+
+ if Index = 0 then
+ return No_Uint;
+ end if;
+
+ return JSON_Entity_Table.Table (Index).Component_Size;
+ end Get_JSON_Component_Size;
+
+ ----------------------
+ -- Get_JSON_Esize --
+ ----------------------
+
+ function Get_JSON_Esize (Name : String) return Node_Ref_Or_Val is
+ Namid : constant Valid_Name_Id := Name_Find (Name);
+ Index : constant Int := Get_Name_Table_Int (Namid);
+
+ begin
+ -- Return No_Uint if no information is available for the entity
+
+ if Index = 0 then
+ return No_Uint;
+ end if;
+
+ return JSON_Entity_Table.Table (Index).Esize;
+ end Get_JSON_Esize;
+
+ ----------------------
+ -- Get_JSON_Esize --
+ ----------------------
+
+ function Get_JSON_Esize
+ (Name : String;
+ Record_Name : String) return Node_Ref_Or_Val
+ is
+ Namid : constant Valid_Name_Id := Name_Find (Record_Name & '.' & Name);
+ Index : constant Int := Get_Name_Table_Int (Namid);
+
+ begin
+ -- Return No_Uint if no information is available for the entity
+
+ if Index = 0 then
+ return No_Uint;
+ end if;
+
+ return JSON_Component_Table.Table (Index).Esize;
+ end Get_JSON_Esize;
+
+ ------------------------
+ -- Get_JSON_RM_Size --
+ ------------------------
+
+ function Get_JSON_RM_Size (Name : String) return Node_Ref_Or_Val is
+ Namid : constant Valid_Name_Id := Name_Find (Name);
+ Index : constant Int := Get_Name_Table_Int (Namid);
+
+ begin
+ -- Return No_Uint if no information is available for the entity
+
+ if Index = 0 then
+ return No_Uint;
+ end if;
+
+ return JSON_Entity_Table.Table (Index).RM_Size;
+ end Get_JSON_RM_Size;
+
+ -----------------------
+ -- Read_JSON_Stream --
+ -----------------------
+
+ procedure Read_JSON_Stream (Text : Text_Buffer; File_Name : String) is
+
+ type Text_Position is record
+ Index : Text_Ptr := 0;
+ Line : Natural := 0;
+ Column : Natural := 0;
+ end record;
+ -- Record to represent position in the text
+
+ type Token_Kind is
+ (J_NULL,
+ J_TRUE,
+ J_FALSE,
+ J_NUMBER,
+ J_INTEGER,
+ J_STRING,
+ J_ARRAY,
+ J_OBJECT,
+ J_ARRAY_END,
+ J_OBJECT_END,
+ J_COMMA,
+ J_COLON,
+ J_EOF);
+ -- JSON Token kind. Note that in ECMA 404 there is no notion of integer.
+ -- Only numbers are supported. In our implementation we return J_INTEGER
+ -- if there is no decimal part in the number. The semantic is that this
+ -- is a J_NUMBER token that might be represented as an integer. Special
+ -- token J_EOF means that end of stream has been reached.
+
+ function Decode_Integer (Lo, Hi : Text_Ptr) return Uint;
+ -- Decode and return the integer in Text (Lo .. Hi)
+
+ function Decode_Name (Lo, Hi : Text_Ptr) return Valid_Name_Id;
+ -- Decode and return the name in Text (Lo .. Hi)
+
+ function Decode_Symbol (Lo, Hi : Text_Ptr) return TCode;
+ -- Decode and return the expression symbol in Text (Lo .. Hi)
+
+ procedure Error (Msg : String);
+ pragma No_Return (Error);
+ -- Print an error message and raise an exception
+
+ procedure Read_Entity;
+ -- Read an entity
+
+ function Read_Name return Valid_Name_Id;
+ -- Read a name
+
+ function Read_Name_With_Prefix return Valid_Name_Id;
+ -- Read a name and prepend a prefix
+
+ function Read_Number return Uint;
+ -- Read a number
+
+ function Read_Numerical_Expr return Node_Ref_Or_Val;
+ -- Read a numerical expression
+
+ procedure Read_Record;
+ -- Read a record
+
+ function Read_String return Valid_Name_Id;
+ -- Read a string
+
+ procedure Read_Token
+ (Kind : out Token_Kind;
+ Token_Start : out Text_Position;
+ Token_End : out Text_Position);
+ -- Read a token and return it (this is a standard JSON lexer)
+
+ procedure Read_Token_And_Error
+ (TK : Token_Kind;
+ Token_Start : out Text_Position;
+ Token_End : out Text_Position);
+ pragma Inline (Read_Token_And_Error);
+ -- Read a specified token and error out on failure
+
+ function Read_Variant_Part return Nat;
+ -- Read a variant part
+
+ procedure Skip_Value;
+ -- Skip a value
+
+ Pos : Text_Position := (Text'First, 1, 1);
+ -- The current position in the text buffer
+
+ Name_Buffer : Bounded_String (4 * Max_Name_Length);
+ -- The buffer used to build full qualifed names
+
+ Prefix_Len : Natural := 0;
+ -- The length of the prefix present in Name_Buffer
+
+ ----------------------
+ -- Decode_Integer --
+ ----------------------
+
+ function Decode_Integer (Lo, Hi : Text_Ptr) return Uint is
+ Len : constant Nat := Int (Hi) - Int (Lo) + 1;
+
+ begin
+ -- Decode up to 9 characters manually, otherwise call into Uint
+
+ if Len < 10 then
+ declare
+ Val : Int := 0;
+
+ begin
+ for J in Lo .. Hi loop
+ Val := Val * 10
+ + Character'Pos (Text (J)) - Character'Pos ('0');
+ end loop;
+ return UI_From_Int (Val);
+ end;
+
+ else
+ declare
+ Val : Uint := Uint_0;
+
+ begin
+ for J in Lo .. Hi loop
+ Val := Val * 10
+ + Character'Pos (Text (J)) - Character'Pos ('0');
+ end loop;
+ return Val;
+ end;
+ end if;
+ end Decode_Integer;
+
+ -------------------
+ -- Decode_Name --
+ -------------------
+
+ function Decode_Name (Lo, Hi : Text_Ptr) return Valid_Name_Id is
+ begin
+ -- Names are stored in lower case so fold them if need be
+
+ if Is_Upper_Case_Letter (Text (Lo)) then
+ declare
+ S : String (Integer (Lo) .. Integer (Hi));
+
+ begin
+ for J in Lo .. Hi loop
+ S (Integer (J)) := Fold_Lower (Text (J));
+ end loop;
+
+ return Name_Find (S);
+ end;
+
+ else
+ declare
+ S : String (Integer (Lo) .. Integer (Hi));
+ for S'Address use Text (Lo)'Address;
+
+ begin
+ return Name_Find (S);
+ end;
+ end if;
+ end Decode_Name;
+
+ ---------------------
+ -- Decode_Symbol --
+ ---------------------
+
+ function Decode_Symbol (Lo, Hi : Text_Ptr) return TCode is
+
+ function Cmp12 (A, B : Character) return Boolean;
+ pragma Inline (Cmp12);
+ -- Compare Text (Lo + 1 .. Lo + 2) with A & B.
+
+ -------------
+ -- Cmp12 --
+ -------------
+
+ function Cmp12 (A, B : Character) return Boolean is
+ begin
+ return Text (Lo + 1) = A and then Text (Lo + 2) = B;
+ end Cmp12;
+
+ Len : constant Nat := Int (Hi) - Int (Lo) + 1;
+
+ -- Start of processing for Decode_Symbol
+
+ begin
+ case Len is
+ when 1 =>
+ case Text (Lo) is
+ when '+' =>
+ return Plus_Expr;
+ when '-' =>
+ return Minus_Expr; -- or Negate_Expr
+ when '*' =>
+ return Mult_Expr;
+ when '<' =>
+ return Lt_Expr;
+ when '>' =>
+ return Gt_Expr;
+ when '&' =>
+ return Bit_And_Expr;
+ when '#' =>
+ return Discrim_Val;
+ when others =>
+ null;
+ end case;
+ when 2 =>
+ if Text (Lo) = '/' then
+ case Text (Lo + 1) is
+ when 't' =>
+ return Trunc_Div_Expr;
+ when 'c' =>
+ return Ceil_Div_Expr;
+ when 'f' =>
+ return Floor_Div_Expr;
+ when 'e' =>
+ return Exact_Div_Expr;
+ when others =>
+ null;
+ end case;
+ elsif Text (Lo + 1) = '=' then
+ case Text (Lo) is
+ when '<' =>
+ return Le_Expr;
+ when '>' =>
+ return Ge_Expr;
+ when '=' =>
+ return Eq_Expr;
+ when '!' =>
+ return Ne_Expr;
+ when others =>
+ null;
+ end case;
+ elsif Text (Lo) = 'o' and then Text (Lo + 1) = 'r' then
+ return Truth_Or_Expr;
+ end if;
+ when 3 =>
+ case Text (Lo) is
+ when '?' =>
+ if Cmp12 ('<', '>') then
+ return Cond_Expr;
+ end if;
+ when 'a' =>
+ if Cmp12 ('b', 's') then
+ return Abs_Expr;
+ elsif Cmp12 ('n', 'd') then
+ return Truth_And_Expr;
+ end if;
+ when 'm' =>
+ if Cmp12 ('a', 'x') then
+ return Max_Expr;
+ elsif Cmp12 ('i', 'n') then
+ return Min_Expr;
+ end if;
+ when 'n' =>
+ if Cmp12 ('o', 't') then
+ return Truth_Not_Expr;
+ end if;
+ when 'x' =>
+ if Cmp12 ('o', 'r') then
+ return Truth_Xor_Expr;
+ end if;
+ when 'v' =>
+ if Cmp12 ('a', 'r') then
+ return Dynamic_Val;
+ end if;
+ when others =>
+ null;
+ end case;
+ when 4 =>
+ if Text (Lo) = 'm'
+ and then Text (Lo + 1) = 'o'
+ and then Text (Lo + 2) = 'd'
+ then
+ case Text (Lo + 3) is
+ when 't' =>
+ return Trunc_Mod_Expr;
+ when 'c' =>
+ return Ceil_Mod_Expr;
+ when 'f' =>
+ return Floor_Mod_Expr;
+ when others =>
+ null;
+ end case;
+ end if;
+
+ pragma Annotate
+ (CodePeer, Intentional,
+ "condition predetermined", "Error called as defensive code");
+
+ when others =>
+ null;
+ end case;
+
+ Error ("unknown symbol");
+ end Decode_Symbol;
+
+ -----------
+ -- Error --
+ -----------
+
+ procedure Error (Msg : String) is
+ L : constant String := Pos.Line'Img;
+ C : constant String := Pos.Column'Img;
+
+ begin
+ Set_Standard_Error;
+ Write_Eol;
+ Write_Str (File_Name);
+ Write_Char (':');
+ Write_Str (L (L'First + 1 .. L'Last));
+ Write_Char (':');
+ Write_Str (C (C'First + 1 .. C'Last));
+ Write_Char (':');
+ Write_Line (Msg);
+ raise Invalid_JSON_Stream;
+ end Error;
+
+ ------------------
+ -- Read_Entity --
+ ------------------
+
+ procedure Read_Entity is
+ Ent : JSON_Entity_Node;
+ Nam : Name_Id := No_Name;
+ Siz : Node_Ref_Or_Val;
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+ TK : Token_Kind;
+
+ begin
+ Ent.Esize := No_Uint;
+ Ent.RM_Size := No_Uint;
+ Ent.Component_Size := No_Uint;
+
+ -- Read the members as string : value pairs
+
+ loop
+ case Read_String is
+ when Name_Name =>
+ Nam := Read_Name;
+ when Name_Record =>
+ if Nam = No_Name then
+ Error ("name expected");
+ end if;
+ Ent.Variant := 0;
+ Prefix_Len := Natural (Length_Of_Name (Nam));
+ Name_Buffer.Chars (1 .. Prefix_Len) := Get_Name_String (Nam);
+ Read_Record;
+ when Name_Variant =>
+ Ent.Variant := Read_Variant_Part;
+ when Name_Size =>
+ Siz := Read_Numerical_Expr;
+ Ent.Esize := Siz;
+ Ent.RM_Size := Siz;
+ when Name_Object_Size =>
+ Ent.Esize := Read_Numerical_Expr;
+ when Name_Value_Size =>
+ Ent.RM_Size := Read_Numerical_Expr;
+ when Name_Component_Size =>
+ Ent.Component_Size := Read_Numerical_Expr;
+ when others =>
+ Skip_Value;
+ end case;
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_OBJECT_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+ end loop;
+
+ -- Store the entity into the table
+
+ JSON_Entity_Table.Append (Ent);
+
+ -- Associate the name with the entity
+
+ if Nam = No_Name then
+ Error ("name expected");
+ end if;
+
+ Set_Name_Table_Int (Nam, JSON_Entity_Table.Last);
+ end Read_Entity;
+
+ -----------------
+ -- Read_Name --
+ -----------------
+
+ function Read_Name return Valid_Name_Id is
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+
+ begin
+ -- Read a single string
+
+ Read_Token_And_Error (J_STRING, Token_Start, Token_End);
+
+ return Decode_Name (Token_Start.Index + 1, Token_End.Index - 1);
+ end Read_Name;
+
+ -----------------------------
+ -- Read_Name_With_Prefix --
+ -----------------------------
+
+ function Read_Name_With_Prefix return Valid_Name_Id is
+ Len : Natural;
+ Lo, Hi : Text_Ptr;
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+
+ begin
+ -- Read a single string
+
+ Read_Token_And_Error (J_STRING, Token_Start, Token_End);
+ Lo := Token_Start.Index + 1;
+ Hi := Token_End.Index - 1;
+
+ -- Prepare for the concatenation with the prefix
+
+ Len := Integer (Hi) - Integer (Lo) + 1;
+ if Prefix_Len + 1 + Len > Name_Buffer.Max_Length then
+ Error ("Name buffer too small");
+ end if;
+
+ Name_Buffer.Length := Prefix_Len + 1 + Len;
+ Name_Buffer.Chars (Prefix_Len + 1) := '.';
+
+ -- Names are stored in lower case so fold them if need be
+
+ if Is_Upper_Case_Letter (Text (Lo)) then
+ for J in Lo .. Hi loop
+ Name_Buffer.Chars (Prefix_Len + 2 + Integer (J - Lo)) :=
+ Fold_Lower (Text (J));
+ end loop;
+
+ else
+ declare
+ S : String (Integer (Lo) .. Integer (Hi));
+ for S'Address use Text (Lo)'Address;
+
+ begin
+ Name_Buffer.Chars (Prefix_Len + 2 .. Prefix_Len + 1 + Len) := S;
+ end;
+ end if;
+
+ return Name_Find (Name_Buffer);
+ end Read_Name_With_Prefix;
+
+ ------------------
+ -- Read_Number --
+ ------------------
+
+ function Read_Number return Uint is
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+
+ begin
+ -- Only integers are to be expected here
+
+ Read_Token_And_Error (J_INTEGER, Token_Start, Token_End);
+
+ return Decode_Integer (Token_Start.Index, Token_End.Index);
+ end Read_Number;
+
+ --------------------------
+ -- Read_Numerical_Expr --
+ --------------------------
+
+ function Read_Numerical_Expr return Node_Ref_Or_Val is
+ Code : TCode;
+ Nop : Integer;
+ Ops : array (1 .. 3) of Node_Ref_Or_Val;
+ TK : Token_Kind;
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+
+ begin
+ -- Read either an integer or an expression
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_INTEGER then
+ return Decode_Integer (Token_Start.Index, Token_End.Index);
+
+ elsif TK = J_OBJECT then
+ -- Read the code of the expression and decode it
+
+ if Read_String /= Name_Code then
+ Error ("name expected");
+ end if;
+
+ Read_Token_And_Error (J_STRING, Token_Start, Token_End);
+ Code := Decode_Symbol (Token_Start.Index + 1, Token_End.Index - 1);
+ Read_Token_And_Error (J_COMMA, Token_Start, Token_End);
+
+ -- Read the array of operands
+
+ if Read_String /= Name_Operands then
+ Error ("operands expected");
+ end if;
+
+ Read_Token_And_Error (J_ARRAY, Token_Start, Token_End);
+
+ Nop := 0;
+ Ops := (others => No_Uint);
+ loop
+ Nop := Nop + 1;
+ Ops (Nop) := Read_Numerical_Expr;
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_ARRAY_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+ end loop;
+
+ Read_Token_And_Error (J_OBJECT_END, Token_Start, Token_End);
+
+ -- Resolve the ambiguity for '-' now
+
+ if Code = Minus_Expr and then Nop = 1 then
+ Code := Negate_Expr;
+ end if;
+
+ return Create_Node (Code, Ops (1), Ops (2), Ops (3));
+
+ else
+ Error ("numerical expression expected");
+ end if;
+ end Read_Numerical_Expr;
+
+ -------------------
+ -- Read_Record --
+ -------------------
+
+ procedure Read_Record is
+ Comp : JSON_Component_Node;
+ First_Bit : Node_Ref_Or_Val := No_Uint;
+ Is_First : Boolean := True;
+ Nam : Name_Id := No_Name;
+ Position : Node_Ref_Or_Val := No_Uint;
+ TK : Token_Kind;
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+
+ begin
+ -- Read a possibly empty array of components
+
+ Read_Token_And_Error (J_ARRAY, Token_Start, Token_End);
+
+ loop
+ Read_Token (TK, Token_Start, Token_End);
+ if Is_First and then TK = J_ARRAY_END then
+ exit;
+ elsif TK /= J_OBJECT then
+ Error ("object expected");
+ end if;
+
+ -- Read the members as string : value pairs
+
+ loop
+ case Read_String is
+ when Name_Name =>
+ Nam := Read_Name_With_Prefix;
+ when Name_Discriminant =>
+ Skip_Value;
+ when Name_Position =>
+ Position := Read_Numerical_Expr;
+ when Name_First_Bit =>
+ First_Bit := Read_Number;
+ when Name_Size =>
+ Comp.Esize := Read_Numerical_Expr;
+ when others =>
+ Error ("invalid component");
+ end case;
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_OBJECT_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+ end loop;
+
+ -- Compute Component_Bit_Offset from Position and First_Bit,
+ -- either symbolically or literally depending on Position.
+
+ if Position = No_Uint or else First_Bit = No_Uint then
+ Error ("bit offset expected");
+ end if;
+
+ if Position < Uint_0 then
+ declare
+ Bit_Position : constant Node_Ref_Or_Val :=
+ Create_Node (Mult_Expr, Position, UI_From_Int (SSU));
+ begin
+ if First_Bit = Uint_0 then
+ Comp.Bit_Offset := Bit_Position;
+ else
+ Comp.Bit_Offset :=
+ Create_Node (Plus_Expr, Bit_Position, First_Bit);
+ end if;
+ end;
+ else
+ Comp.Bit_Offset := Position * SSU + First_Bit;
+ end if;
+
+ -- Store the component into the table
+
+ JSON_Component_Table.Append (Comp);
+
+ -- Associate the name with the component
+
+ if Nam = No_Name then
+ Error ("name expected");
+ end if;
+
+ Set_Name_Table_Int (Nam, JSON_Component_Table.Last);
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_ARRAY_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+
+ Is_First := False;
+ end loop;
+ end Read_Record;
+
+ ------------------
+ -- Read_String --
+ ------------------
+
+ function Read_String return Valid_Name_Id is
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+ Nam : Valid_Name_Id;
+
+ begin
+ -- Read the string and the following colon
+
+ Read_Token_And_Error (J_STRING, Token_Start, Token_End);
+ Nam := Decode_Name (Token_Start.Index + 1, Token_End.Index - 1);
+ Read_Token_And_Error (J_COLON, Token_Start, Token_End);
+
+ return Nam;
+ end Read_String;
+
+ ------------------
+ -- Read_Token --
+ ------------------
+
+ procedure Read_Token
+ (Kind : out Token_Kind;
+ Token_Start : out Text_Position;
+ Token_End : out Text_Position)
+ is
+ procedure Next_Char;
+ -- Update Pos to point to next char
+
+ function Is_Whitespace return Boolean;
+ pragma Inline (Is_Whitespace);
+ -- Return True of current character is a whitespace
+
+ function Is_Structural_Token return Boolean;
+ pragma Inline (Is_Structural_Token);
+ -- Return True if current character is one of the structural tokens
+
+ function Is_Token_Sep return Boolean;
+ pragma Inline (Is_Token_Sep);
+ -- Return True if current character is a token separator
+
+ procedure Delimit_Keyword (Kw : String);
+ -- Helper function to parse tokens such as null, false and true
+
+ ---------------
+ -- Next_Char --
+ ---------------
+
+ procedure Next_Char is
+ begin
+ if Pos.Index > Text'Last then
+ Pos.Column := Pos.Column + 1;
+ elsif Text (Pos.Index) = ASCII.LF then
+ Pos.Column := 1;
+ Pos.Line := Pos.Line + 1;
+ else
+ Pos.Column := Pos.Column + 1;
+ end if;
+ Pos.Index := Pos.Index + 1;
+ end Next_Char;
+
+ -------------------
+ -- Is_Whitespace --
+ -------------------
+
+ function Is_Whitespace return Boolean is
+ begin
+ return
+ Pos.Index <= Text'Last
+ and then
+ (Text (Pos.Index) = ASCII.LF
+ or else
+ Text (Pos.Index) = ASCII.CR
+ or else
+ Text (Pos.Index) = ASCII.HT
+ or else
+ Text (Pos.Index) = ' ');
+ end Is_Whitespace;
+
+ -------------------------
+ -- Is_Structural_Token --
+ -------------------------
+
+ function Is_Structural_Token return Boolean is
+ begin
+ return
+ Pos.Index <= Text'Last
+ and then
+ (Text (Pos.Index) = '['
+ or else
+ Text (Pos.Index) = ']'
+ or else
+ Text (Pos.Index) = '{'
+ or else
+ Text (Pos.Index) = '}'
+ or else
+ Text (Pos.Index) = ','
+ or else
+ Text (Pos.Index) = ':');
+ end Is_Structural_Token;
+
+ ------------------
+ -- Is_Token_Sep --
+ ------------------
+
+ function Is_Token_Sep return Boolean is
+ begin
+ return
+ Pos.Index > Text'Last
+ or else
+ Is_Whitespace
+ or else
+ Is_Structural_Token;
+ end Is_Token_Sep;
+
+ ---------------------
+ -- Delimit_Keyword --
+ ---------------------
+
+ procedure Delimit_Keyword (Kw : String) is
+ pragma Unreferenced (Kw);
+ begin
+ while not Is_Token_Sep loop
+ Token_End := Pos;
+ Next_Char;
+ end loop;
+ end Delimit_Keyword;
+
+ CC : Character;
+ Can_Be_Integer : Boolean := True;
+
+ -- Start of processing for Read_Token
+
+ begin
+ -- Skip leading whitespaces
+
+ while Is_Whitespace loop
+ Next_Char;
+ end loop;
+
+ -- Initialize token delimiters
+
+ Token_Start := Pos;
+ Token_End := Pos;
+
+ -- End of stream reached
+
+ if Pos.Index > Text'Last then
+ Kind := J_EOF;
+ return;
+ end if;
+
+ CC := Text (Pos.Index);
+
+ if CC = '[' then
+ Next_Char;
+ Kind := J_ARRAY;
+ return;
+ elsif CC = ']' then
+ Next_Char;
+ Kind := J_ARRAY_END;
+ return;
+ elsif CC = '{' then
+ Next_Char;
+ Kind := J_OBJECT;
+ return;
+ elsif CC = '}' then
+ Next_Char;
+ Kind := J_OBJECT_END;
+ return;
+ elsif CC = ',' then
+ Next_Char;
+ Kind := J_COMMA;
+ return;
+ elsif CC = ':' then
+ Next_Char;
+ Kind := J_COLON;
+ return;
+ elsif CC = 'n' then
+ Delimit_Keyword ("null");
+ Kind := J_NULL;
+ return;
+ elsif CC = 'f' then
+ Delimit_Keyword ("false");
+ Kind := J_FALSE;
+ return;
+ elsif CC = 't' then
+ Delimit_Keyword ("true");
+ Kind := J_TRUE;
+ return;
+ elsif CC = '"' then
+ -- We expect a string
+ -- Just scan till the end the of the string but do not attempt
+ -- to decode it. This means that even if we get a string token
+ -- it might not be a valid string from the ECMA 404 point of
+ -- view.
+
+ Next_Char;
+ while Pos.Index <= Text'Last and then Text (Pos.Index) /= '"' loop
+ if Text (Pos.Index) in ASCII.NUL .. ASCII.US then
+ Error ("control character not allowed in string");
+ end if;
+
+ if Text (Pos.Index) = '\' then
+ Next_Char;
+ if Pos.Index > Text'Last then
+ Error ("non terminated string token");
+ end if;
+
+ case Text (Pos.Index) is
+ when 'u' =>
+ for Idx in 1 .. 4 loop
+ Next_Char;
+ if Pos.Index > Text'Last
+ or else (Text (Pos.Index) not in 'a' .. 'f'
+ and then
+ Text (Pos.Index) not in 'A' .. 'F'
+ and then
+ Text (Pos.Index) not in '0' .. '9')
+ then
+ Error ("invalid unicode escape sequence");
+ end if;
+ end loop;
+ when '\' | '/' | '"' | 'b' | 'f' | 'n' | 'r' | 't' =>
+ null;
+ when others =>
+ Error ("invalid escape sequence");
+ end case;
+ end if;
+ Next_Char;
+ end loop;
+
+ -- No quote found report and error
+
+ if Pos.Index > Text'Last then
+ Error ("non terminated string token");
+ end if;
+
+ Token_End := Pos;
+
+ -- Go to next char and ensure that this is separator. Indeed
+ -- construction such as "string1""string2" are not allowed
+
+ Next_Char;
+ if not Is_Token_Sep then
+ Error ("invalid syntax");
+ end if;
+ Kind := J_STRING;
+ return;
+ elsif CC = '-' or else CC in '0' .. '9' then
+ -- We expect a number
+ if CC = '-' then
+ Next_Char;
+ end if;
+
+ if Pos.Index > Text'Last then
+ Error ("invalid number");
+ end if;
+
+ -- Parse integer part of a number. Superfluous leading zeros are
+ -- not allowed.
+
+ if Text (Pos.Index) = '0' then
+ Token_End := Pos;
+ Next_Char;
+ elsif Text (Pos.Index) in '1' .. '9' then
+ Token_End := Pos;
+ Next_Char;
+ while Pos.Index <= Text'Last
+ and then Text (Pos.Index) in '0' .. '9'
+ loop
+ Token_End := Pos;
+ Next_Char;
+ end loop;
+ else
+ Error ("invalid number");
+ end if;
+
+ if Is_Token_Sep then
+ -- Valid integer number
+
+ Kind := J_INTEGER;
+ return;
+ elsif Text (Pos.Index) /= '.'
+ and then Text (Pos.Index) /= 'e'
+ and then Text (Pos.Index) /= 'E'
+ then
+ Error ("invalid number");
+ end if;
+
+ -- Check for a fractional part
+
+ if Text (Pos.Index) = '.' then
+ Can_Be_Integer := False;
+ Token_End := Pos;
+ Next_Char;
+ if Pos.Index > Text'Last
+ or else Text (Pos.Index) not in '0' .. '9'
+ then
+ Error ("invalid number");
+ end if;
+
+ while Pos.Index <= Text'Last
+ and then Text (Pos.Index) in '0' .. '9'
+ loop
+ Token_End := Pos;
+ Next_Char;
+ end loop;
+
+ end if;
+
+ -- Check for exponent part
+
+ if Pos.Index <= Text'Last
+ and then (Text (Pos.Index) = 'e' or else Text (Pos.Index) = 'E')
+ then
+ Token_End := Pos;
+ Next_Char;
+ if Pos.Index > Text'Last then
+ Error ("invalid number");
+ end if;
+
+ if Text (Pos.Index) = '-' then
+ -- Also a few corner cases can lead to an integer, assume
+ -- that the number is not an integer.
+
+ Can_Be_Integer := False;
+ end if;
+
+ if Text (Pos.Index) = '-' or else Text (Pos.Index) = '+' then
+ Next_Char;
+ end if;
+
+ if Pos.Index > Text'Last
+ or else Text (Pos.Index) not in '0' .. '9'
+ then
+ Error ("invalid number");
+ end if;
+
+ while Pos.Index <= Text'Last
+ and then Text (Pos.Index) in '0' .. '9'
+ loop
+ Token_End := Pos;
+ Next_Char;
+ end loop;
+ end if;
+
+ if Is_Token_Sep then
+ -- Valid decimal number
+
+ if Can_Be_Integer then
+ Kind := J_INTEGER;
+ else
+ Kind := J_NUMBER;
+ end if;
+ return;
+ else
+ Error ("invalid number");
+ end if;
+ elsif CC = EOF then
+ Kind := J_EOF;
+ else
+ Error ("Unexpected character");
+ end if;
+ end Read_Token;
+
+ ----------------------------
+ -- Read_Token_And_Error --
+ ----------------------------
+
+ procedure Read_Token_And_Error
+ (TK : Token_Kind;
+ Token_Start : out Text_Position;
+ Token_End : out Text_Position)
+ is
+ Kind : Token_Kind;
+
+ begin
+ -- Read a token and errout out if not of the expected kind
+
+ Read_Token (Kind, Token_Start, Token_End);
+ if Kind /= TK then
+ Error ("specific token expected");
+ end if;
+ end Read_Token_And_Error;
+
+ -------------------------
+ -- Read_Variant_Part --
+ -------------------------
+
+ function Read_Variant_Part return Nat is
+ Next : Nat := 0;
+ TK : Token_Kind;
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+ Var : JSON_Variant_Node;
+
+ begin
+ -- Read a non-empty array of components
+
+ Read_Token_And_Error (J_ARRAY, Token_Start, Token_End);
+
+ loop
+ Read_Token_And_Error (J_OBJECT, Token_Start, Token_End);
+
+ Var.Variant := 0;
+
+ -- Read the members as string : value pairs
+
+ loop
+ case Read_String is
+ when Name_Present =>
+ Var.Present := Read_Numerical_Expr;
+ when Name_Record =>
+ Read_Record;
+ when Name_Variant =>
+ Var.Variant := Read_Variant_Part;
+ when others =>
+ Error ("invalid variant");
+ end case;
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_OBJECT_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+ end loop;
+
+ -- Chain the variant and store it into the table
+
+ Var.Next := Next;
+ JSON_Variant_Table.Append (Var);
+ Next := JSON_Variant_Table.Last;
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_ARRAY_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+ end loop;
+
+ return Next;
+ end Read_Variant_Part;
+
+ ------------------
+ -- Skip_Value --
+ ------------------
+
+ procedure Skip_Value is
+ Array_Depth : Natural := 0;
+ Object_Depth : Natural := 0;
+ TK : Token_Kind;
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+
+ begin
+ -- Read a value without recursing
+
+ loop
+ Read_Token (TK, Token_Start, Token_End);
+
+ case TK is
+ when J_STRING | J_INTEGER | J_NUMBER =>
+ null;
+ when J_ARRAY =>
+ Array_Depth := Array_Depth + 1;
+ when J_ARRAY_END =>
+ Array_Depth := Array_Depth - 1;
+ when J_OBJECT =>
+ Object_Depth := Object_Depth + 1;
+ when J_OBJECT_END =>
+ Object_Depth := Object_Depth - 1;
+ when J_COLON | J_COMMA =>
+ if Array_Depth = 0 and then Object_Depth = 0 then
+ Error ("value expected");
+ end if;
+ when others =>
+ Error ("value expected");
+ end case;
+
+ exit when Array_Depth = 0 and then Object_Depth = 0;
+ end loop;
+ end Skip_Value;
+
+ Token_Start : Text_Position;
+ Token_End : Text_Position;
+ TK : Token_Kind;
+ Is_First : Boolean := True;
+
+ -- Start of processing for Read_JSON_Stream
+
+ begin
+ -- Read a possibly empty array of entities
+
+ Read_Token_And_Error (J_ARRAY, Token_Start, Token_End);
+
+ loop
+ Read_Token (TK, Token_Start, Token_End);
+ if Is_First and then TK = J_ARRAY_END then
+ exit;
+ elsif TK /= J_OBJECT then
+ Error ("object expected");
+ end if;
+
+ Read_Entity;
+
+ Read_Token (TK, Token_Start, Token_End);
+ if TK = J_ARRAY_END then
+ exit;
+ elsif TK /= J_COMMA then
+ Error ("comma expected");
+ end if;
+
+ Is_First := False;
+ end loop;
+ end Read_JSON_Stream;
+
+end Repinfo.Input;
--- /dev/null
+++ b/src/gcc/ada/repinfo-input.ads
@@ -0,0 +1,78 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- R E P I N F O - I N P U T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2018-2019, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- . --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides an alternate way of populating the internal tables
+-- of Repinfo from a JSON input rather than the binary blob of the tree file.
+-- Note that this is an additive mechanism, i.e. nothing is destroyed in the
+-- internal state of the unit when it is used.
+
+-- The first step is to feed the unit with a JSON stream of a specified format
+-- (see the spec of Repinfo for its description) by means of Read_JSON_Stream.
+-- Then, for each entity whose representation information is present in the
+-- JSON stream, the appropriate Get_JSON_* routines can be invoked to override
+-- the eponymous fields of the entity in the tree.
+
+package Repinfo.Input is
+
+ function Get_JSON_Esize (Name : String) return Node_Ref_Or_Val;
+ -- Returns the Esize value of the entity specified by Name, which is not
+ -- the component of a record type, or else No_Uint if no representation
+ -- information was supplied for the entity. Name is the full qualified name
+ -- of the entity in lower case letters.
+
+ function Get_JSON_RM_Size (Name : String) return Node_Ref_Or_Val;
+ -- Likewise for the RM_Size
+
+ function Get_JSON_Component_Size (Name : String) return Node_Ref_Or_Val;
+ -- Likewise for the Component_Size of an array type
+
+ function Get_JSON_Component_Bit_Offset
+ (Name : String;
+ Record_Name : String) return Node_Ref_Or_Val;
+ -- Returns the Component_Bit_Offset of the component specified by Name,
+ -- which is declared in the record type specified by Record_Name, or else
+ -- No_Uint if no representation information was supplied for the component.
+ -- Name is the unqualified name of the component whereas Record_Name is the
+ -- full qualified name of the record type, both in lower case letters.
+
+ function Get_JSON_Esize
+ (Name : String;
+ Record_Name : String) return Node_Ref_Or_Val;
+ -- Likewise for the Esize
+
+ Invalid_JSON_Stream : exception;
+ -- Raised if a format error is detected in the JSON stream
+
+ procedure Read_JSON_Stream (Text : Text_Buffer; File_Name : String);
+ -- Reads a JSON stream and populates internal tables from it. File_Name is
+ -- only used in error messages issued by the JSON parser.
+
+end Repinfo.Input;
--- a/src/gcc/ada/snames.ads-tmpl
+++ b/src/gcc/ada/snames.ads-tmpl
@@ -1511,6 +1511,11 @@
Name_Runtime_Library_Dir : constant Name_Id := N + $;
Name_Runtime_Source_Dir : constant Name_Id := N + $;
+ -- Additional names used by the Repinfo unit
+
+ Name_Discriminant : constant Name_Id := N + $;
+ Name_Operands : constant Name_Id := N + $;
+
-- Other miscellaneous names used in front end
Name_Unaligned_Valid : constant Name_Id := N + $;