gcc/ada/repinfo-input.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                         R E P I N F O - I N P U T                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2018-2023, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Alloc;
  27 with Csets;    use Csets;
  28 with Hostparm; use Hostparm;
  29 with Namet;    use Namet;
  30 with Output;   use Output;
  31 with Snames;   use Snames;
  32 with Table;
  33 with Ttypes;
  34
  35 package body Repinfo.Input is
  36
  37    SSU : Pos renames Ttypes.System_Storage_Unit;
  38    --  Value for Storage_Unit
  39
  40    type JSON_Entity_Kind is (JE_Record_Type, JE_Array_Type, JE_Other);
  41    --  Kind of an entity
  42
  43    type JSON_Entity_Node (Kind : JSON_Entity_Kind := JE_Other) is record
  44       Esize   : Node_Ref_Or_Val;
  45       RM_Size : Node_Ref_Or_Val;
  46       case Kind is
  47          when JE_Record_Type => Variant        : Nat;
  48          when JE_Array_Type  => Component_Size : Node_Ref_Or_Val;
  49          when JE_Other       => Dummy          : Boolean;
  50       end case;
  51    end record;
  52    pragma Unchecked_Union (JSON_Entity_Node);
  53    --  Record to represent an entity
  54
  55    package JSON_Entity_Table is new Table.Table (
  56       Table_Component_Type => JSON_Entity_Node,
  57       Table_Index_Type     => Nat,
  58       Table_Low_Bound      => 1,
  59       Table_Initial        => Alloc.Rep_JSON_Table_Initial,
  60       Table_Increment      => Alloc.Rep_JSON_Table_Increment,
  61       Table_Name           => "JSON_Entity_Table");
  62    --  Table of entities
  63
  64    type JSON_Component_Node is record
  65       Bit_Offset : Node_Ref_Or_Val;
  66       Esize      : Node_Ref_Or_Val;
  67    end record;
  68    --  Record to represent a component
  69
  70    package JSON_Component_Table is new Table.Table (
  71       Table_Component_Type => JSON_Component_Node,
  72       Table_Index_Type     => Nat,
  73       Table_Low_Bound      => 1,
  74       Table_Initial        => Alloc.Rep_JSON_Table_Initial,
  75       Table_Increment      => Alloc.Rep_JSON_Table_Increment,
  76       Table_Name           => "JSON_Component_Table");
  77    --  Table of components
  78
  79    type JSON_Variant_Node is record
  80       Present : Node_Ref_Or_Val;
  81       Variant : Nat;
  82       Next    : Nat;
  83    end record;
  84    --  Record to represent a variant
  85
  86    package JSON_Variant_Table is new Table.Table (
  87       Table_Component_Type => JSON_Variant_Node,
  88       Table_Index_Type     => Nat,
  89       Table_Low_Bound      => 1,
  90       Table_Initial        => Alloc.Rep_JSON_Table_Initial,
  91       Table_Increment      => Alloc.Rep_JSON_Table_Increment,
  92       Table_Name           => "JSON_Variant_Table");
  93    --  Table of variants
  94
  95    -------------------------------------
  96    --  Get_JSON_Component_Bit_Offset  --
  97    -------------------------------------
  98
  99    function Get_JSON_Component_Bit_Offset
 100      (Name        : String;
 101       Record_Name : String) return Node_Ref_Or_Val
 102    is
 103       Namid : constant Valid_Name_Id := Name_Find (Record_Name & '.' & Name);
 104       Index : constant Int := Get_Name_Table_Int (Namid);
 105
 106    begin
 107       --  Return No_Uint if no information is available for the component
 108
 109       if Index = 0 then
 110          return No_Uint;
 111       end if;
 112
 113       return JSON_Component_Table.Table (Index).Bit_Offset;
 114    end Get_JSON_Component_Bit_Offset;
 115
 116    -------------------------------
 117    --  Get_JSON_Component_Size  --
 118    -------------------------------
 119
 120    function Get_JSON_Component_Size (Name : String) return Node_Ref_Or_Val is
 121       Namid : constant Valid_Name_Id := Name_Find (Name);
 122       Index : constant Int := Get_Name_Table_Int (Namid);
 123
 124    begin
 125       --  Return No_Uint if no information is available for the component
 126
 127       if Index = 0 then
 128          return No_Uint;
 129       end if;
 130
 131       return JSON_Entity_Table.Table (Index).Component_Size;
 132    end Get_JSON_Component_Size;
 133
 134    ----------------------
 135    --  Get_JSON_Esize  --
 136    ----------------------
 137
 138    function Get_JSON_Esize (Name : String) return Node_Ref_Or_Val is
 139       Namid : constant Valid_Name_Id := Name_Find (Name);
 140       Index : constant Int := Get_Name_Table_Int (Namid);
 141
 142    begin
 143       --  Return No_Uint if no information is available for the entity
 144
 145       if Index = 0 then
 146          return No_Uint;
 147       end if;
 148
 149       return JSON_Entity_Table.Table (Index).Esize;
 150    end Get_JSON_Esize;
 151
 152    ----------------------
 153    --  Get_JSON_Esize  --
 154    ----------------------
 155
 156    function Get_JSON_Esize
 157      (Name        : String;
 158       Record_Name : String) return Node_Ref_Or_Val
 159    is
 160       Namid : constant Valid_Name_Id := Name_Find (Record_Name & '.' & Name);
 161       Index : constant Int := Get_Name_Table_Int (Namid);
 162
 163    begin
 164       --  Return No_Uint if no information is available for the entity
 165
 166       if Index = 0 then
 167          return No_Uint;
 168       end if;
 169
 170       return JSON_Component_Table.Table (Index).Esize;
 171    end Get_JSON_Esize;
 172
 173    ------------------------
 174    --  Get_JSON_RM_Size  --
 175    ------------------------
 176
 177    function Get_JSON_RM_Size (Name : String) return Node_Ref_Or_Val is
 178       Namid : constant Valid_Name_Id := Name_Find (Name);
 179       Index : constant Int := Get_Name_Table_Int (Namid);
 180
 181    begin
 182       --  Return No_Uint if no information is available for the entity
 183
 184       if Index = 0 then
 185          return No_Uint;
 186       end if;
 187
 188       return JSON_Entity_Table.Table (Index).RM_Size;
 189    end Get_JSON_RM_Size;
 190
 191    -----------------------
 192    --  Read_JSON_Stream --
 193    -----------------------
 194
 195    procedure Read_JSON_Stream (Text : Text_Buffer; File_Name : String) is
 196
 197       type Text_Position is record
 198          Index  : Text_Ptr := 0;
 199          Line   : Natural := 0;
 200          Column : Natural := 0;
 201       end record;
 202       --  Record to represent position in the text
 203
 204       type Token_Kind is
 205         (J_NULL,
 206          J_TRUE,
 207          J_FALSE,
 208          J_NUMBER,
 209          J_INTEGER,
 210          J_STRING,
 211          J_ARRAY,
 212          J_OBJECT,
 213          J_ARRAY_END,
 214          J_OBJECT_END,
 215          J_COMMA,
 216          J_COLON,
 217          J_EOF);
 218       --  JSON token kind. Note that in ECMA 404 there is no notion of integer.
 219       --  Only numbers are supported. In our implementation we return J_INTEGER
 220       --  if there is no decimal part in the number. The semantic is that this
 221       --  is a J_NUMBER token that might be represented as an integer. Special
 222       --  token J_EOF means that end of stream has been reached.
 223
 224       function Decode_Integer (Lo, Hi : Text_Ptr) return Uint;
 225       --  Decode and return the integer in Text (Lo .. Hi)
 226
 227       function Decode_Name (Lo, Hi : Text_Ptr) return Valid_Name_Id;
 228       --  Decode and return the name in Text (Lo .. Hi)
 229
 230       function Decode_Symbol (Lo, Hi : Text_Ptr) return TCode;
 231       --  Decode and return the expression symbol in Text (Lo .. Hi)
 232
 233       procedure Error (Msg : String);
 234       pragma No_Return (Error);
 235       --  Print an error message and raise an exception
 236
 237       procedure Read_Entity;
 238       --  Read an entity
 239
 240       function Read_Name return Valid_Name_Id;
 241       --  Read a name
 242
 243       function Read_Name_With_Prefix return Valid_Name_Id;
 244       --  Read a name and prepend a prefix
 245
 246       function Read_Number return Uint;
 247       --  Read a number
 248
 249       function Read_Numerical_Expr return Node_Ref_Or_Val;
 250       --  Read a numerical expression
 251
 252       procedure Read_Record;
 253       --  Read a record
 254
 255       function Read_String return Valid_Name_Id;
 256       --  Read a string
 257
 258       procedure Read_Token
 259         (Kind        : out Token_Kind;
 260          Token_Start : out Text_Position;
 261          Token_End   : out Text_Position);
 262       --  Read a token and return it (this is a standard JSON lexer)
 263
 264       procedure Read_Token_And_Error
 265         (TK          : Token_Kind;
 266          Token_Start : out Text_Position;
 267          Token_End   : out Text_Position);
 268       pragma Inline (Read_Token_And_Error);
 269       --  Read a specified token and error out on failure
 270
 271       function Read_Variant_Part return Nat;
 272       --  Read a variant part
 273
 274       procedure Skip_Value;
 275       --  Skip a value
 276
 277       Pos : Text_Position := (Text'First, 1, 1);
 278       --  The current position in the text buffer
 279
 280       Name_Buffer : Bounded_String (4 * Max_Name_Length);
 281       --  The buffer used to build full qualifed names
 282
 283       Prefix_Len : Natural := 0;
 284       --  The length of the prefix present in Name_Buffer
 285
 286       ----------------------
 287       --  Decode_Integer  --
 288       ----------------------
 289
 290       function Decode_Integer (Lo, Hi : Text_Ptr) return Uint is
 291          Len : constant Nat := Int (Hi) - Int (Lo) + 1;
 292
 293       begin
 294          --  Decode up to 9 characters manually, otherwise call into Uint
 295
 296          if Len < 10 then
 297             declare
 298                Val : Int := 0;
 299
 300             begin
 301                for J in Lo .. Hi loop
 302                   Val := Val * 10
 303                            + Character'Pos (Text (J)) - Character'Pos ('0');
 304                end loop;
 305                return UI_From_Int (Val);
 306             end;
 307
 308          else
 309             declare
 310                Val : Uint := Uint_0;
 311
 312             begin
 313                for J in Lo .. Hi loop
 314                   Val := Val * 10
 315                            + Character'Pos (Text (J)) - Character'Pos ('0');
 316                end loop;
 317                return Val;
 318             end;
 319          end if;
 320       end Decode_Integer;
 321
 322       -------------------
 323       --  Decode_Name  --
 324       -------------------
 325
 326       function Decode_Name (Lo, Hi : Text_Ptr) return Valid_Name_Id is
 327       begin
 328          --  Names are stored in lower case so fold them if need be
 329
 330          if Is_Upper_Case_Letter (Text (Lo)) then
 331             declare
 332                S : String (Integer (Lo) .. Integer (Hi));
 333
 334             begin
 335                for J in Lo .. Hi loop
 336                   S (Integer (J)) := Fold_Lower (Text (J));
 337                end loop;
 338
 339                return Name_Find (S);
 340             end;
 341
 342          else
 343             declare
 344                S : String (Integer (Lo) .. Integer (Hi));
 345                for S'Address use Text (Lo)'Address;
 346
 347             begin
 348                return Name_Find (S);
 349             end;
 350          end if;
 351       end Decode_Name;
 352
 353       ---------------------
 354       --  Decode_Symbol  --
 355       ---------------------
 356
 357       function Decode_Symbol (Lo, Hi : Text_Ptr) return TCode is
 358
 359          function Cmp12 (A, B : Character) return Boolean;
 360          pragma Inline (Cmp12);
 361          --  Compare Text (Lo + 1 .. Lo + 2) with A & B.
 362
 363          -------------
 364          --  Cmp12  --
 365          -------------
 366
 367          function Cmp12 (A, B : Character) return Boolean is
 368          begin
 369             return Text (Lo + 1) = A and then Text (Lo + 2) = B;
 370          end Cmp12;
 371
 372          Len : constant Nat := Int (Hi) - Int (Lo) + 1;
 373
 374       --  Start of processing for Decode_Symbol
 375
 376       begin
 377          case Len is
 378             when 1 =>
 379                case Text (Lo) is
 380                   when '+' =>
 381                      return Plus_Expr;
 382                   when '-' =>
 383                      return Minus_Expr; -- or Negate_Expr
 384                   when '*' =>
 385                      return Mult_Expr;
 386                   when '<' =>
 387                      return Lt_Expr;
 388                   when '>' =>
 389                      return Gt_Expr;
 390                   when '&' =>
 391                      return Bit_And_Expr;
 392                   when '#' =>
 393                      return Discrim_Val;
 394                   when others =>
 395                      null;
 396                end case;
 397             when 2 =>
 398                if Text (Lo) = '/' then
 399                   case Text (Lo + 1) is
 400                      when 't' =>
 401                         return Trunc_Div_Expr;
 402                      when 'c' =>
 403                         return Ceil_Div_Expr;
 404                      when 'f' =>
 405                         return Floor_Div_Expr;
 406                      when 'e' =>
 407                         return Exact_Div_Expr;
 408                      when others =>
 409                         null;
 410                   end case;
 411                elsif Text (Lo + 1) = '=' then
 412                   case Text (Lo) is
 413                      when '<' =>
 414                         return Le_Expr;
 415                      when '>' =>
 416                         return Ge_Expr;
 417                      when '=' =>
 418                         return Eq_Expr;
 419                      when '!' =>
 420                         return Ne_Expr;
 421                      when others =>
 422                         null;
 423                   end case;
 424                elsif Text (Lo) = 'o' and then Text (Lo + 1) = 'r' then
 425                   return Truth_Or_Expr;
 426                end if;
 427             when 3 =>
 428                case Text (Lo) is
 429                   when '?' =>
 430                      if Cmp12 ('<', '>') then
 431                         return Cond_Expr;
 432                      end if;
 433                   when 'a' =>
 434                      if Cmp12 ('b', 's') then
 435                         return Abs_Expr;
 436                      elsif Cmp12 ('n', 'd') then
 437                         return Truth_And_Expr;
 438                      end if;
 439                   when 'm' =>
 440                      if Cmp12 ('a', 'x') then
 441                         return Max_Expr;
 442                      elsif Cmp12 ('i', 'n') then
 443                         return Min_Expr;
 444                      end if;
 445                   when 'n' =>
 446                      if Cmp12 ('o', 't') then
 447                         return Truth_Not_Expr;
 448                      end if;
 449                   when 'x' =>
 450                      if Cmp12 ('o', 'r') then
 451                         return Truth_Xor_Expr;
 452                      end if;
 453                   when 'v' =>
 454                      if Cmp12 ('a', 'r') then
 455                         return Dynamic_Val;
 456                      end if;
 457                   when others =>
 458                      null;
 459                end case;
 460             when 4 =>
 461                if Text (Lo) = 'm'
 462                  and then Text (Lo + 1) = 'o'
 463                  and then Text (Lo + 2) = 'd'
 464                then
 465                   case Text (Lo + 3) is
 466                      when 't' =>
 467                         return Trunc_Mod_Expr;
 468                      when 'c' =>
 469                         return Ceil_Mod_Expr;
 470                      when 'f' =>
 471                         return Floor_Mod_Expr;
 472                      when others =>
 473                         null;
 474                   end case;
 475                end if;
 476
 477                pragma Annotate
 478                  (CodePeer, Intentional,
 479                   "condition predetermined", "Error called as defensive code");
 480
 481             when others =>
 482                null;
 483          end case;
 484
 485          Error ("unknown symbol");
 486       end Decode_Symbol;
 487
 488       -----------
 489       -- Error --
 490       -----------
 491
 492       procedure Error (Msg : String) is
 493          L : constant String := Pos.Line'Img;
 494          C : constant String := Pos.Column'Img;
 495
 496       begin
 497          Set_Standard_Error;
 498          Write_Eol;
 499          Write_Str (File_Name);
 500          Write_Char (':');
 501          Write_Str (L (L'First + 1 .. L'Last));
 502          Write_Char (':');
 503          Write_Str (C (C'First + 1 .. C'Last));
 504          Write_Char (':');
 505          Write_Line (Msg);
 506          raise Invalid_JSON_Stream;
 507       end Error;
 508
 509       ------------------
 510       --  Read_Entity --
 511       ------------------
 512
 513       procedure Read_Entity is
 514          Ent         : JSON_Entity_Node;
 515          Nam         : Name_Id := No_Name;
 516          Siz         : Node_Ref_Or_Val;
 517          Token_Start : Text_Position;
 518          Token_End   : Text_Position;
 519          TK          : Token_Kind;
 520
 521       begin
 522          Ent.Esize          := No_Uint;
 523          Ent.RM_Size        := No_Uint;
 524          Ent.Component_Size := No_Uint;
 525
 526          --  Read the members as string : value pairs
 527
 528          loop
 529             case Read_String is
 530                when Name_Name =>
 531                   Nam := Read_Name;
 532                when Name_Record =>
 533                   if Nam = No_Name then
 534                      Error ("name expected");
 535                   end if;
 536                   Ent.Variant := 0;
 537                   Prefix_Len := Natural (Length_Of_Name (Nam));
 538                   Name_Buffer.Chars (1 .. Prefix_Len) := Get_Name_String (Nam);
 539                   Read_Record;
 540                when Name_Variant =>
 541                   Ent.Variant := Read_Variant_Part;
 542                when Name_Size =>
 543                   Siz := Read_Numerical_Expr;
 544                   Ent.Esize := Siz;
 545                   Ent.RM_Size := Siz;
 546                when Name_Object_Size =>
 547                   Ent.Esize := Read_Numerical_Expr;
 548                when Name_Value_Size =>
 549                   Ent.RM_Size := Read_Numerical_Expr;
 550                when Name_Component_Size =>
 551                   Ent.Component_Size := Read_Numerical_Expr;
 552                when others =>
 553                   Skip_Value;
 554             end case;
 555
 556             Read_Token (TK, Token_Start, Token_End);
 557             if TK = J_OBJECT_END then
 558                exit;
 559             elsif TK /= J_COMMA then
 560                Error ("comma expected");
 561             end if;
 562          end loop;
 563
 564          --  Store the entity into the table
 565
 566          JSON_Entity_Table.Append (Ent);
 567
 568          --  Associate the name with the entity
 569
 570          if Nam = No_Name then
 571             Error ("name expected");
 572          end if;
 573
 574          Set_Name_Table_Int (Nam, JSON_Entity_Table.Last);
 575       end Read_Entity;
 576
 577       -----------------
 578       --  Read_Name  --
 579       -----------------
 580
 581       function Read_Name return Valid_Name_Id is
 582          Token_Start : Text_Position;
 583          Token_End   : Text_Position;
 584
 585       begin
 586          --  Read a single string
 587
 588          Read_Token_And_Error (J_STRING, Token_Start, Token_End);
 589
 590          return Decode_Name (Token_Start.Index + 1, Token_End.Index - 1);
 591       end Read_Name;
 592
 593       -----------------------------
 594       --  Read_Name_With_Prefix  --
 595       -----------------------------
 596
 597       function Read_Name_With_Prefix return Valid_Name_Id is
 598          Len         : Natural;
 599          Lo, Hi      : Text_Ptr;
 600          Token_Start : Text_Position;
 601          Token_End   : Text_Position;
 602
 603       begin
 604          --  Read a single string
 605
 606          Read_Token_And_Error (J_STRING, Token_Start, Token_End);
 607          Lo := Token_Start.Index + 1;
 608          Hi := Token_End.Index - 1;
 609
 610          --  Prepare for the concatenation with the prefix
 611
 612          Len := Integer (Hi) - Integer (Lo) + 1;
 613          if Prefix_Len + 1 + Len > Name_Buffer.Max_Length then
 614             Error ("Name buffer too small");
 615          end if;
 616
 617          Name_Buffer.Length := Prefix_Len + 1 + Len;
 618          Name_Buffer.Chars (Prefix_Len + 1) := '.';
 619
 620          --  Names are stored in lower case so fold them if need be
 621
 622          if Is_Upper_Case_Letter (Text (Lo)) then
 623             for J in Lo .. Hi loop
 624                Name_Buffer.Chars (Prefix_Len + 2 + Integer (J - Lo)) :=
 625                                                          Fold_Lower (Text (J));
 626             end loop;
 627
 628          else
 629             declare
 630                S : String (Integer (Lo) .. Integer (Hi));
 631                for S'Address use Text (Lo)'Address;
 632
 633             begin
 634                Name_Buffer.Chars (Prefix_Len + 2 .. Prefix_Len + 1 + Len) := S;
 635             end;
 636          end if;
 637
 638          return Name_Find (Name_Buffer);
 639       end Read_Name_With_Prefix;
 640
 641       ------------------
 642       --  Read_Number --
 643       ------------------
 644
 645       function Read_Number return Uint is
 646          Token_Start : Text_Position;
 647          Token_End   : Text_Position;
 648
 649       begin
 650          --  Only integers are to be expected here
 651
 652          Read_Token_And_Error (J_INTEGER, Token_Start, Token_End);
 653
 654          return Decode_Integer (Token_Start.Index, Token_End.Index);
 655       end Read_Number;
 656
 657       --------------------------
 658       --  Read_Numerical_Expr --
 659       --------------------------
 660
 661       function Read_Numerical_Expr return Node_Ref_Or_Val is
 662          Code        : TCode;
 663          Nop         : Integer;
 664          Ops         : array (1 .. 3) of Node_Ref_Or_Val;
 665          TK          : Token_Kind;
 666          Token_Start : Text_Position;
 667          Token_End   : Text_Position;
 668
 669       begin
 670          --  Read either an integer or an expression
 671
 672          Read_Token (TK, Token_Start, Token_End);
 673          if TK = J_INTEGER then
 674             return Decode_Integer (Token_Start.Index, Token_End.Index);
 675
 676          elsif TK = J_OBJECT then
 677             --  Read the code of the expression and decode it
 678
 679             if Read_String /= Name_Code then
 680                Error ("name expected");
 681             end if;
 682
 683             Read_Token_And_Error (J_STRING, Token_Start, Token_End);
 684             Code := Decode_Symbol (Token_Start.Index + 1, Token_End.Index - 1);
 685             Read_Token_And_Error (J_COMMA, Token_Start, Token_End);
 686
 687             --  Read the array of operands
 688
 689             if Read_String /= Name_Operands then
 690                Error ("operands expected");
 691             end if;
 692
 693             Read_Token_And_Error (J_ARRAY, Token_Start, Token_End);
 694
 695             Nop := 0;
 696             Ops := (others => No_Uint);
 697             loop
 698                Nop := Nop + 1;
 699                Ops (Nop) := Read_Numerical_Expr;
 700                Read_Token (TK, Token_Start, Token_End);
 701                if TK = J_ARRAY_END then
 702                   exit;
 703                elsif TK /= J_COMMA then
 704                   Error ("comma expected");
 705                end if;
 706             end loop;
 707
 708             Read_Token_And_Error (J_OBJECT_END, Token_Start, Token_End);
 709
 710             --  Resolve the ambiguity for '-' now
 711
 712             if Code = Minus_Expr and then Nop = 1 then
 713                Code := Negate_Expr;
 714             end if;
 715
 716             return Create_Node (Code, Ops (1), Ops (2), Ops (3));
 717
 718          else
 719             Error ("numerical expression expected");
 720          end if;
 721       end Read_Numerical_Expr;
 722
 723       -------------------
 724       --  Read_Record  --
 725       -------------------
 726
 727       procedure Read_Record is
 728          Comp        : JSON_Component_Node;
 729          First_Bit   : Node_Ref_Or_Val := No_Uint;
 730          Is_First    : Boolean := True;
 731          Nam         : Name_Id := No_Name;
 732          Position    : Node_Ref_Or_Val := No_Uint;
 733          TK          : Token_Kind;
 734          Token_Start : Text_Position;
 735          Token_End   : Text_Position;
 736
 737       begin
 738          --  Read a possibly empty array of components
 739
 740          Read_Token_And_Error (J_ARRAY, Token_Start, Token_End);
 741
 742          loop
 743             Read_Token (TK, Token_Start, Token_End);
 744             if Is_First and then TK = J_ARRAY_END then
 745                exit;
 746             elsif TK /= J_OBJECT then
 747                Error ("object expected");
 748             end if;
 749
 750             --  Read the members as string : value pairs
 751
 752             loop
 753                case Read_String is
 754                   when Name_Name =>
 755                      Nam := Read_Name_With_Prefix;
 756                   when Name_Discriminant =>
 757                      Skip_Value;
 758                   when Name_Position =>
 759                      Position := Read_Numerical_Expr;
 760                   when Name_First_Bit =>
 761                      First_Bit := Read_Number;
 762                   when Name_Size =>
 763                      Comp.Esize := Read_Numerical_Expr;
 764                   when others =>
 765                      Error ("invalid component");
 766                end case;
 767
 768                Read_Token (TK, Token_Start, Token_End);
 769                if TK = J_OBJECT_END then
 770                   exit;
 771                elsif TK /= J_COMMA then
 772                   Error ("comma expected");
 773                end if;
 774             end loop;
 775
 776             --  Compute Component_Bit_Offset from Position and First_Bit,
 777             --  either symbolically or literally depending on Position.
 778
 779             if No (Position) or else No (First_Bit) then
 780                Error ("bit offset expected");
 781             end if;
 782
 783             if Position < Uint_0 then
 784                declare
 785                   Bit_Position : constant Node_Ref_Or_Val :=
 786                           Create_Node (Mult_Expr, Position, UI_From_Int (SSU));
 787                begin
 788                   if First_Bit = Uint_0 then
 789                      Comp.Bit_Offset := Bit_Position;
 790                   else
 791                      Comp.Bit_Offset :=
 792                               Create_Node (Plus_Expr, Bit_Position, First_Bit);
 793                   end if;
 794                end;
 795             else
 796                Comp.Bit_Offset := Position * SSU + First_Bit;
 797             end if;
 798
 799             --  Store the component into the table
 800
 801             JSON_Component_Table.Append (Comp);
 802
 803             --  Associate the name with the component
 804
 805             if Nam = No_Name then
 806                Error ("name expected");
 807             end if;
 808
 809             Set_Name_Table_Int (Nam, JSON_Component_Table.Last);
 810
 811             Read_Token (TK, Token_Start, Token_End);
 812             if TK = J_ARRAY_END then
 813                exit;
 814             elsif TK /= J_COMMA then
 815                Error ("comma expected");
 816             end if;
 817
 818             Is_First := False;
 819          end loop;
 820       end Read_Record;
 821
 822       ------------------
 823       --  Read_String --
 824       ------------------
 825
 826       function Read_String return Valid_Name_Id is
 827          Token_Start : Text_Position;
 828          Token_End   : Text_Position;
 829          Nam         : Valid_Name_Id;
 830
 831       begin
 832          --  Read the string and the following colon
 833
 834          Read_Token_And_Error (J_STRING, Token_Start, Token_End);
 835          Nam := Decode_Name (Token_Start.Index + 1, Token_End.Index - 1);
 836          Read_Token_And_Error (J_COLON, Token_Start, Token_End);
 837
 838          return Nam;
 839       end Read_String;
 840
 841       ------------------
 842       --  Read_Token  --
 843       ------------------
 844
 845       procedure Read_Token
 846         (Kind        : out Token_Kind;
 847          Token_Start : out Text_Position;
 848          Token_End   : out Text_Position)
 849       is
 850          procedure Next_Char;
 851          --  Update Pos to point to next char
 852
 853          function Is_Whitespace return Boolean;
 854          pragma Inline (Is_Whitespace);
 855          --  Return True of current character is a whitespace
 856
 857          function Is_Structural_Token return Boolean;
 858          pragma Inline (Is_Structural_Token);
 859          --  Return True if current character is one of the structural tokens
 860
 861          function Is_Token_Sep return Boolean;
 862          pragma Inline (Is_Token_Sep);
 863          --  Return True if current character is a token separator
 864
 865          procedure Delimit_Keyword (Kw : String);
 866          --  Helper function to parse tokens such as null, false and true
 867
 868          ---------------
 869          -- Next_Char --
 870          ---------------
 871
 872          procedure Next_Char is
 873          begin
 874             if Pos.Index > Text'Last then
 875                Pos.Column := Pos.Column + 1;
 876             elsif Text (Pos.Index) = ASCII.LF then
 877                Pos.Column := 1;
 878                Pos.Line := Pos.Line + 1;
 879             else
 880                Pos.Column := Pos.Column + 1;
 881             end if;
 882             Pos.Index := Pos.Index + 1;
 883          end Next_Char;
 884
 885          -------------------
 886          -- Is_Whitespace --
 887          -------------------
 888
 889          function Is_Whitespace return Boolean is
 890          begin
 891             return
 892               Pos.Index <= Text'Last
 893                 and then
 894               (Text (Pos.Index) = ASCII.LF
 895                  or else
 896                Text (Pos.Index) = ASCII.CR
 897                  or else
 898                Text (Pos.Index) = ASCII.HT
 899                  or else
 900                Text (Pos.Index) = ' ');
 901          end Is_Whitespace;
 902
 903          -------------------------
 904          -- Is_Structural_Token --
 905          -------------------------
 906
 907          function Is_Structural_Token return Boolean is
 908          begin
 909             return
 910               Pos.Index <= Text'Last
 911                 and then
 912               (Text (Pos.Index) = '['
 913                  or else
 914                Text (Pos.Index) = ']'
 915                  or else
 916                Text (Pos.Index) = '{'
 917                  or else
 918                Text (Pos.Index) = '}'
 919                  or else
 920                Text (Pos.Index) = ','
 921                  or else
 922                Text (Pos.Index) = ':');
 923          end Is_Structural_Token;
 924
 925          ------------------
 926          -- Is_Token_Sep --
 927          ------------------
 928
 929          function Is_Token_Sep return Boolean is
 930          begin
 931             return
 932               Pos.Index > Text'Last
 933                 or else
 934               Is_Whitespace
 935                 or else
 936               Is_Structural_Token;
 937          end Is_Token_Sep;
 938
 939          ---------------------
 940          -- Delimit_Keyword --
 941          ---------------------
 942
 943          procedure Delimit_Keyword (Kw : String) is
 944             pragma Unreferenced (Kw);
 945          begin
 946             while not Is_Token_Sep loop
 947                Token_End := Pos;
 948                Next_Char;
 949             end loop;
 950          end Delimit_Keyword;
 951
 952          CC             : Character;
 953          Can_Be_Integer : Boolean := True;
 954
 955       --  Start of processing for Read_Token
 956
 957       begin
 958          --  Skip leading whitespaces
 959
 960          while Is_Whitespace loop
 961             Next_Char;
 962          end loop;
 963
 964          --  Initialize token delimiters
 965
 966          Token_Start := Pos;
 967          Token_End   := Pos;
 968
 969          --  End of stream reached
 970
 971          if Pos.Index > Text'Last then
 972             Kind := J_EOF;
 973             return;
 974          end if;
 975
 976          CC := Text (Pos.Index);
 977
 978          if CC = '[' then
 979             Next_Char;
 980             Kind := J_ARRAY;
 981             return;
 982          elsif CC = ']' then
 983             Next_Char;
 984             Kind := J_ARRAY_END;
 985             return;
 986          elsif CC = '{' then
 987             Next_Char;
 988             Kind := J_OBJECT;
 989             return;
 990          elsif CC = '}' then
 991             Next_Char;
 992             Kind := J_OBJECT_END;
 993             return;
 994          elsif CC = ',' then
 995             Next_Char;
 996             Kind := J_COMMA;
 997             return;
 998          elsif CC = ':' then
 999             Next_Char;
1000             Kind := J_COLON;
1001             return;
1002          elsif CC = 'n' then
1003             Delimit_Keyword ("null");
1004             Kind := J_NULL;
1005             return;
1006          elsif CC = 'f' then
1007             Delimit_Keyword ("false");
1008             Kind := J_FALSE;
1009             return;
1010          elsif CC = 't' then
1011             Delimit_Keyword ("true");
1012             Kind := J_TRUE;
1013             return;
1014          elsif CC = '"' then
1015             --  We expect a string
1016             --  Just scan till the end the of the string but do not attempt
1017             --  to decode it. This means that even if we get a string token
1018             --  it might not be a valid string from the ECMA 404 point of
1019             --  view.
1020
1021             Next_Char;
1022             while Pos.Index <= Text'Last and then Text (Pos.Index) /= '"' loop
1023                if Text (Pos.Index) in ASCII.NUL .. ASCII.US then
1024                   Error ("control character not allowed in string");
1025                end if;
1026
1027                if Text (Pos.Index) = '\' then
1028                   Next_Char;
1029                   if Pos.Index > Text'Last then
1030                      Error ("non terminated string token");
1031                   end if;
1032
1033                   case Text (Pos.Index) is
1034                      when 'u' =>
1035                         for Idx in 1 .. 4 loop
1036                            Next_Char;
1037                            if Pos.Index > Text'Last
1038                              or else (Text (Pos.Index) not in 'a' .. 'f'
1039                                         and then
1040                                       Text (Pos.Index) not in 'A' .. 'F'
1041                                         and then
1042                                       Text (Pos.Index) not in '0' .. '9')
1043                            then
1044                               Error ("invalid unicode escape sequence");
1045                            end if;
1046                         end loop;
1047                      when '\' | '/' | '"' | 'b' | 'f' | 'n' | 'r' | 't' =>
1048                         null;
1049                      when others =>
1050                         Error ("invalid escape sequence");
1051                   end case;
1052                end if;
1053                Next_Char;
1054             end loop;
1055
1056             --  No quote found report and error
1057
1058             if Pos.Index > Text'Last then
1059                Error ("non terminated string token");
1060             end if;
1061
1062             Token_End := Pos;
1063
1064             --  Go to next char and ensure that this is separator. Indeed
1065             --  construction such as "string1""string2" are not allowed
1066
1067             Next_Char;
1068             if not Is_Token_Sep then
1069                Error ("invalid syntax");
1070             end if;
1071             Kind := J_STRING;
1072             return;
1073          elsif CC = '-' or else CC in '0' .. '9' then
1074             --  We expect a number
1075             if CC = '-' then
1076                Next_Char;
1077             end if;
1078
1079             if Pos.Index > Text'Last then
1080                Error ("invalid number");
1081             end if;
1082
1083             --  Parse integer part of a number. Superfluous leading zeros are
1084             --  not allowed.
1085
1086             if Text (Pos.Index) = '0' then
1087                Token_End := Pos;
1088                Next_Char;
1089             elsif Text (Pos.Index) in '1' .. '9' then
1090                Token_End := Pos;
1091                Next_Char;
1092                while Pos.Index <= Text'Last
1093                  and then Text (Pos.Index) in '0' .. '9'
1094                loop
1095                   Token_End := Pos;
1096                   Next_Char;
1097                end loop;
1098             else
1099                Error ("invalid number");
1100             end if;
1101
1102             if Is_Token_Sep then
1103                --  Valid integer number
1104
1105                Kind := J_INTEGER;
1106                return;
1107             elsif Text (Pos.Index) /= '.'
1108               and then Text (Pos.Index) /= 'e'
1109               and then Text (Pos.Index) /= 'E'
1110             then
1111                Error ("invalid number");
1112             end if;
1113
1114             --  Check for a fractional part
1115
1116             if Text (Pos.Index) = '.' then
1117                Can_Be_Integer := False;
1118                Token_End := Pos;
1119                Next_Char;
1120                if Pos.Index > Text'Last
1121                  or else Text (Pos.Index) not in '0' .. '9'
1122                then
1123                   Error ("invalid number");
1124                end if;
1125
1126                while Pos.Index <= Text'Last
1127                  and then Text (Pos.Index) in '0' .. '9'
1128                loop
1129                   Token_End := Pos;
1130                   Next_Char;
1131                end loop;
1132
1133             end if;
1134
1135             --  Check for exponent part
1136
1137             if Pos.Index <= Text'Last
1138               and then (Text (Pos.Index) = 'e' or else Text (Pos.Index) = 'E')
1139             then
1140                Token_End := Pos;
1141                Next_Char;
1142                if Pos.Index > Text'Last then
1143                   Error ("invalid number");
1144                end if;
1145
1146                if Text (Pos.Index) = '-' then
1147                   --  Also a few corner cases can lead to an integer, assume
1148                   --  that the number is not an integer.
1149
1150                   Can_Be_Integer := False;
1151                end if;
1152
1153                if Text (Pos.Index) = '-' or else Text (Pos.Index) = '+' then
1154                   Next_Char;
1155                end if;
1156
1157                if Pos.Index > Text'Last
1158                  or else Text (Pos.Index) not in '0' .. '9'
1159                then
1160                   Error ("invalid number");
1161                end if;
1162
1163                while Pos.Index <= Text'Last
1164                  and then Text (Pos.Index) in '0' .. '9'
1165                loop
1166                   Token_End := Pos;
1167                   Next_Char;
1168                end loop;
1169             end if;
1170
1171             if Is_Token_Sep then
1172                --  Valid decimal number
1173
1174                if Can_Be_Integer then
1175                   Kind := J_INTEGER;
1176                else
1177                   Kind := J_NUMBER;
1178                end if;
1179                return;
1180             else
1181                Error ("invalid number");
1182             end if;
1183          elsif CC = EOF then
1184             Kind := J_EOF;
1185          else
1186             Error ("Unexpected character");
1187          end if;
1188       end Read_Token;
1189
1190       ----------------------------
1191       --  Read_Token_And_Error  --
1192       ----------------------------
1193
1194       procedure Read_Token_And_Error
1195         (TK          : Token_Kind;
1196          Token_Start : out Text_Position;
1197          Token_End   : out Text_Position)
1198       is
1199          Kind : Token_Kind;
1200
1201       begin
1202          --  Read a token and errout out if not of the expected kind
1203
1204          Read_Token (Kind, Token_Start, Token_End);
1205          if Kind /= TK then
1206             Error ("specific token expected");
1207          end if;
1208       end Read_Token_And_Error;
1209
1210       -------------------------
1211       --  Read_Variant_Part  --
1212       -------------------------
1213
1214       function Read_Variant_Part return Nat is
1215          Next        : Nat := 0;
1216          TK          : Token_Kind;
1217          Token_Start : Text_Position;
1218          Token_End   : Text_Position;
1219          Var         : JSON_Variant_Node;
1220
1221       begin
1222          --  Read a nonempty array of components
1223
1224          Read_Token_And_Error (J_ARRAY, Token_Start, Token_End);
1225
1226          loop
1227             Read_Token_And_Error (J_OBJECT, Token_Start, Token_End);
1228
1229             Var.Variant := 0;
1230
1231             --  Read the members as string : value pairs
1232
1233             loop
1234                case Read_String is
1235                   when Name_Present =>
1236                      Var.Present := Read_Numerical_Expr;
1237                   when Name_Record =>
1238                      Read_Record;
1239                   when Name_Variant =>
1240                      Var.Variant := Read_Variant_Part;
1241                   when others =>
1242                      Error ("invalid variant");
1243                end case;
1244
1245                Read_Token (TK, Token_Start, Token_End);
1246                if TK = J_OBJECT_END then
1247                   exit;
1248                elsif TK /= J_COMMA then
1249                   Error ("comma expected");
1250                end if;
1251             end loop;
1252
1253             --  Chain the variant and store it into the table
1254
1255             Var.Next := Next;
1256             JSON_Variant_Table.Append (Var);
1257             Next := JSON_Variant_Table.Last;
1258
1259             Read_Token (TK, Token_Start, Token_End);
1260             if TK = J_ARRAY_END then
1261                exit;
1262             elsif TK /= J_COMMA then
1263                Error ("comma expected");
1264             end if;
1265          end loop;
1266
1267          return Next;
1268       end Read_Variant_Part;
1269
1270       ------------------
1271       --  Skip_Value  --
1272       ------------------
1273
1274       procedure Skip_Value is
1275          Array_Depth  : Natural := 0;
1276          Object_Depth : Natural := 0;
1277          TK           : Token_Kind;
1278          Token_Start  : Text_Position;
1279          Token_End    : Text_Position;
1280
1281       begin
1282          --  Read a value without recursing
1283
1284          loop
1285             Read_Token (TK, Token_Start, Token_End);
1286
1287             case TK is
1288                when J_STRING | J_INTEGER | J_NUMBER =>
1289                   null;
1290                when J_ARRAY =>
1291                   Array_Depth := Array_Depth + 1;
1292                when J_ARRAY_END =>
1293                   Array_Depth := Array_Depth - 1;
1294                when J_OBJECT =>
1295                   Object_Depth := Object_Depth + 1;
1296                when J_OBJECT_END =>
1297                   Object_Depth := Object_Depth - 1;
1298                when J_COLON | J_COMMA =>
1299                   if Array_Depth = 0 and then Object_Depth = 0 then
1300                      Error ("value expected");
1301                   end if;
1302                when others =>
1303                   Error ("value expected");
1304             end case;
1305
1306             exit when Array_Depth = 0 and then Object_Depth = 0;
1307          end loop;
1308       end Skip_Value;
1309
1310       Token_Start : Text_Position;
1311       Token_End   : Text_Position;
1312       TK          : Token_Kind;
1313       Is_First    : Boolean := True;
1314
1315    --  Start of processing for Read_JSON_Stream
1316
1317    begin
1318       --  Read a possibly empty array of entities
1319
1320       Read_Token_And_Error (J_ARRAY, Token_Start, Token_End);
1321
1322       loop
1323          Read_Token (TK, Token_Start, Token_End);
1324          if Is_First and then TK = J_ARRAY_END then
1325             exit;
1326          elsif TK /= J_OBJECT then
1327             Error ("object expected");
1328          end if;
1329
1330          Read_Entity;
1331
1332          Read_Token (TK, Token_Start, Token_End);
1333          if TK = J_ARRAY_END then
1334             exit;
1335          elsif TK /= J_COMMA then
1336             Error ("comma expected");
1337          end if;
1338
1339          Is_First := False;
1340       end loop;
1341    end Read_JSON_Stream;
1342
1343 end Repinfo.Input;