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-2021, 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 26with Alloc; 27with Csets; use Csets; 28with Hostparm; use Hostparm; 29with Namet; use Namet; 30with Output; use Output; 31with Snames; use Snames; 32with Table; 33with Ttypes; 34 35package 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 1343end Repinfo.Input; 1344