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