1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- R E P I N F O - I N P U T --
9 -- Copyright (C) 2018-2023, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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
;
35 package body Repinfo
.Input
is
37 SSU
: Pos
renames Ttypes
.System_Storage_Unit
;
38 -- Value for Storage_Unit
40 type JSON_Entity_Kind
is (JE_Record_Type
, JE_Array_Type
, JE_Other
);
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
;
47 when JE_Record_Type
=> Variant
: Nat
;
48 when JE_Array_Type
=> Component_Size
: Node_Ref_Or_Val
;
49 when JE_Other
=> Dummy
: Boolean;
52 pragma Unchecked_Union
(JSON_Entity_Node
);
53 -- Record to represent an entity
55 package JSON_Entity_Table
is new Table
.Table
(
56 Table_Component_Type
=> JSON_Entity_Node
,
57 Table_Index_Type
=> Nat
,
59 Table_Initial
=> Alloc
.Rep_JSON_Table_Initial
,
60 Table_Increment
=> Alloc
.Rep_JSON_Table_Increment
,
61 Table_Name
=> "JSON_Entity_Table");
64 type JSON_Component_Node
is record
65 Bit_Offset
: Node_Ref_Or_Val
;
66 Esize
: Node_Ref_Or_Val
;
68 -- Record to represent a component
70 package JSON_Component_Table
is new Table
.Table
(
71 Table_Component_Type
=> JSON_Component_Node
,
72 Table_Index_Type
=> Nat
,
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
79 type JSON_Variant_Node
is record
80 Present
: Node_Ref_Or_Val
;
84 -- Record to represent a variant
86 package JSON_Variant_Table
is new Table
.Table
(
87 Table_Component_Type
=> JSON_Variant_Node
,
88 Table_Index_Type
=> Nat
,
90 Table_Initial
=> Alloc
.Rep_JSON_Table_Initial
,
91 Table_Increment
=> Alloc
.Rep_JSON_Table_Increment
,
92 Table_Name
=> "JSON_Variant_Table");
95 -------------------------------------
96 -- Get_JSON_Component_Bit_Offset --
97 -------------------------------------
99 function Get_JSON_Component_Bit_Offset
101 Record_Name
: String) return Node_Ref_Or_Val
103 Namid
: constant Valid_Name_Id
:= Name_Find
(Record_Name
& '.' & Name
);
104 Index
: constant Int
:= Get_Name_Table_Int
(Namid
);
107 -- Return No_Uint if no information is available for the component
113 return JSON_Component_Table
.Table
(Index
).Bit_Offset
;
114 end Get_JSON_Component_Bit_Offset
;
116 -------------------------------
117 -- Get_JSON_Component_Size --
118 -------------------------------
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
);
125 -- Return No_Uint if no information is available for the component
131 return JSON_Entity_Table
.Table
(Index
).Component_Size
;
132 end Get_JSON_Component_Size
;
134 ----------------------
136 ----------------------
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
);
143 -- Return No_Uint if no information is available for the entity
149 return JSON_Entity_Table
.Table
(Index
).Esize
;
152 ----------------------
154 ----------------------
156 function Get_JSON_Esize
158 Record_Name
: String) return Node_Ref_Or_Val
160 Namid
: constant Valid_Name_Id
:= Name_Find
(Record_Name
& '.' & Name
);
161 Index
: constant Int
:= Get_Name_Table_Int
(Namid
);
164 -- Return No_Uint if no information is available for the entity
170 return JSON_Component_Table
.Table
(Index
).Esize
;
173 ------------------------
174 -- Get_JSON_RM_Size --
175 ------------------------
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
);
182 -- Return No_Uint if no information is available for the entity
188 return JSON_Entity_Table
.Table
(Index
).RM_Size
;
189 end Get_JSON_RM_Size
;
191 -----------------------
192 -- Read_JSON_Stream --
193 -----------------------
195 procedure Read_JSON_Stream
(Text
: Text_Buffer
; File_Name
: String) is
197 type Text_Position
is record
198 Index
: Text_Ptr
:= 0;
200 Column
: Natural := 0;
202 -- Record to represent position in the text
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.
224 function Decode_Integer
(Lo
, Hi
: Text_Ptr
) return Uint
;
225 -- Decode and return the integer in Text (Lo .. Hi)
227 function Decode_Name
(Lo
, Hi
: Text_Ptr
) return Valid_Name_Id
;
228 -- Decode and return the name in Text (Lo .. Hi)
230 function Decode_Symbol
(Lo
, Hi
: Text_Ptr
) return TCode
;
231 -- Decode and return the expression symbol in Text (Lo .. Hi)
233 procedure Error
(Msg
: String);
234 pragma No_Return
(Error
);
235 -- Print an error message and raise an exception
237 procedure Read_Entity
;
240 function Read_Name
return Valid_Name_Id
;
243 function Read_Name_With_Prefix
return Valid_Name_Id
;
244 -- Read a name and prepend a prefix
246 function Read_Number
return Uint
;
249 function Read_Numerical_Expr
return Node_Ref_Or_Val
;
250 -- Read a numerical expression
252 procedure Read_Record
;
255 function Read_String
return Valid_Name_Id
;
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)
264 procedure Read_Token_And_Error
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
271 function Read_Variant_Part
return Nat
;
272 -- Read a variant part
274 procedure Skip_Value
;
277 Pos
: Text_Position
:= (Text
'First, 1, 1);
278 -- The current position in the text buffer
280 Name_Buffer
: Bounded_String
(4 * Max_Name_Length
);
281 -- The buffer used to build full qualifed names
283 Prefix_Len
: Natural := 0;
284 -- The length of the prefix present in Name_Buffer
286 ----------------------
288 ----------------------
290 function Decode_Integer
(Lo
, Hi
: Text_Ptr
) return Uint
is
291 Len
: constant Nat
:= Int
(Hi
) - Int
(Lo
) + 1;
294 -- Decode up to 9 characters manually, otherwise call into Uint
301 for J
in Lo
.. Hi
loop
303 + Character'Pos (Text
(J
)) - Character'Pos ('0');
305 return UI_From_Int
(Val
);
310 Val
: Uint
:= Uint_0
;
313 for J
in Lo
.. Hi
loop
315 + Character'Pos (Text
(J
)) - Character'Pos ('0');
326 function Decode_Name
(Lo
, Hi
: Text_Ptr
) return Valid_Name_Id
is
328 -- Names are stored in lower case so fold them if need be
330 if Is_Upper_Case_Letter
(Text
(Lo
)) then
332 S
: String (Integer (Lo
) .. Integer (Hi
));
335 for J
in Lo
.. Hi
loop
336 S
(Integer (J
)) := Fold_Lower
(Text
(J
));
339 return Name_Find
(S
);
344 S
: String (Integer (Lo
) .. Integer (Hi
));
345 for S
'Address use Text
(Lo
)'Address;
348 return Name_Find
(S
);
353 ---------------------
355 ---------------------
357 function Decode_Symbol
(Lo
, Hi
: Text_Ptr
) return TCode
is
359 function Cmp12
(A
, B
: Character) return Boolean;
360 pragma Inline
(Cmp12
);
361 -- Compare Text (Lo + 1 .. Lo + 2) with A & B.
367 function Cmp12
(A
, B
: Character) return Boolean is
369 return Text
(Lo
+ 1) = A
and then Text
(Lo
+ 2) = B
;
372 Len
: constant Nat
:= Int
(Hi
) - Int
(Lo
) + 1;
374 -- Start of processing for Decode_Symbol
383 return Minus_Expr
; -- or Negate_Expr
398 if Text
(Lo
) = '/' then
399 case Text
(Lo
+ 1) is
401 return Trunc_Div_Expr
;
403 return Ceil_Div_Expr
;
405 return Floor_Div_Expr
;
407 return Exact_Div_Expr
;
411 elsif Text
(Lo
+ 1) = '=' then
424 elsif Text
(Lo
) = 'o' and then Text
(Lo
+ 1) = 'r' then
425 return Truth_Or_Expr
;
430 if Cmp12
('<', '>') then
434 if Cmp12
('b', 's') then
436 elsif Cmp12
('n', 'd') then
437 return Truth_And_Expr
;
440 if Cmp12
('a', 'x') then
442 elsif Cmp12
('i', 'n') then
446 if Cmp12
('o', 't') then
447 return Truth_Not_Expr
;
450 if Cmp12
('o', 'r') then
451 return Truth_Xor_Expr
;
454 if Cmp12
('a', 'r') then
462 and then Text
(Lo
+ 1) = 'o'
463 and then Text
(Lo
+ 2) = 'd'
465 case Text
(Lo
+ 3) is
467 return Trunc_Mod_Expr
;
469 return Ceil_Mod_Expr
;
471 return Floor_Mod_Expr
;
478 (CodePeer
, Intentional
,
479 "condition predetermined", "Error called as defensive code");
485 Error
("unknown symbol");
492 procedure Error
(Msg
: String) is
493 L
: constant String := Pos
.Line
'Img;
494 C
: constant String := Pos
.Column
'Img;
499 Write_Str
(File_Name
);
501 Write_Str
(L
(L
'First + 1 .. L
'Last));
503 Write_Str
(C
(C
'First + 1 .. C
'Last));
506 raise Invalid_JSON_Stream
;
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
;
522 Ent
.Esize
:= No_Uint
;
523 Ent
.RM_Size
:= No_Uint
;
524 Ent
.Component_Size
:= No_Uint
;
526 -- Read the members as string : value pairs
533 if Nam
= No_Name
then
534 Error
("name expected");
537 Prefix_Len
:= Natural (Length_Of_Name
(Nam
));
538 Name_Buffer
.Chars
(1 .. Prefix_Len
) := Get_Name_String
(Nam
);
541 Ent
.Variant
:= Read_Variant_Part
;
543 Siz
:= Read_Numerical_Expr
;
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
;
556 Read_Token
(TK
, Token_Start
, Token_End
);
557 if TK
= J_OBJECT_END
then
559 elsif TK
/= J_COMMA
then
560 Error
("comma expected");
564 -- Store the entity into the table
566 JSON_Entity_Table
.Append
(Ent
);
568 -- Associate the name with the entity
570 if Nam
= No_Name
then
571 Error
("name expected");
574 Set_Name_Table_Int
(Nam
, JSON_Entity_Table
.Last
);
581 function Read_Name
return Valid_Name_Id
is
582 Token_Start
: Text_Position
;
583 Token_End
: Text_Position
;
586 -- Read a single string
588 Read_Token_And_Error
(J_STRING
, Token_Start
, Token_End
);
590 return Decode_Name
(Token_Start
.Index
+ 1, Token_End
.Index
- 1);
593 -----------------------------
594 -- Read_Name_With_Prefix --
595 -----------------------------
597 function Read_Name_With_Prefix
return Valid_Name_Id
is
600 Token_Start
: Text_Position
;
601 Token_End
: Text_Position
;
604 -- Read a single string
606 Read_Token_And_Error
(J_STRING
, Token_Start
, Token_End
);
607 Lo
:= Token_Start
.Index
+ 1;
608 Hi
:= Token_End
.Index
- 1;
610 -- Prepare for the concatenation with the prefix
612 Len
:= Integer (Hi
) - Integer (Lo
) + 1;
613 if Prefix_Len
+ 1 + Len
> Name_Buffer
.Max_Length
then
614 Error
("Name buffer too small");
617 Name_Buffer
.Length
:= Prefix_Len
+ 1 + Len
;
618 Name_Buffer
.Chars
(Prefix_Len
+ 1) := '.';
620 -- Names are stored in lower case so fold them if need be
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
));
630 S
: String (Integer (Lo
) .. Integer (Hi
));
631 for S
'Address use Text
(Lo
)'Address;
634 Name_Buffer
.Chars
(Prefix_Len
+ 2 .. Prefix_Len
+ 1 + Len
) := S
;
638 return Name_Find
(Name_Buffer
);
639 end Read_Name_With_Prefix
;
645 function Read_Number
return Uint
is
646 Token_Start
: Text_Position
;
647 Token_End
: Text_Position
;
650 -- Only integers are to be expected here
652 Read_Token_And_Error
(J_INTEGER
, Token_Start
, Token_End
);
654 return Decode_Integer
(Token_Start
.Index
, Token_End
.Index
);
657 --------------------------
658 -- Read_Numerical_Expr --
659 --------------------------
661 function Read_Numerical_Expr
return Node_Ref_Or_Val
is
664 Ops
: array (1 .. 3) of Node_Ref_Or_Val
;
666 Token_Start
: Text_Position
;
667 Token_End
: Text_Position
;
670 -- Read either an integer or an expression
672 Read_Token
(TK
, Token_Start
, Token_End
);
673 if TK
= J_INTEGER
then
674 return Decode_Integer
(Token_Start
.Index
, Token_End
.Index
);
676 elsif TK
= J_OBJECT
then
677 -- Read the code of the expression and decode it
679 if Read_String
/= Name_Code
then
680 Error
("name expected");
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
);
687 -- Read the array of operands
689 if Read_String
/= Name_Operands
then
690 Error
("operands expected");
693 Read_Token_And_Error
(J_ARRAY
, Token_Start
, Token_End
);
696 Ops
:= (others => No_Uint
);
699 Ops
(Nop
) := Read_Numerical_Expr
;
700 Read_Token
(TK
, Token_Start
, Token_End
);
701 if TK
= J_ARRAY_END
then
703 elsif TK
/= J_COMMA
then
704 Error
("comma expected");
708 Read_Token_And_Error
(J_OBJECT_END
, Token_Start
, Token_End
);
710 -- Resolve the ambiguity for '-' now
712 if Code
= Minus_Expr
and then Nop
= 1 then
716 return Create_Node
(Code
, Ops
(1), Ops
(2), Ops
(3));
719 Error
("numerical expression expected");
721 end Read_Numerical_Expr
;
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
;
734 Token_Start
: Text_Position
;
735 Token_End
: Text_Position
;
738 -- Read a possibly empty array of components
740 Read_Token_And_Error
(J_ARRAY
, Token_Start
, Token_End
);
743 Read_Token
(TK
, Token_Start
, Token_End
);
744 if Is_First
and then TK
= J_ARRAY_END
then
746 elsif TK
/= J_OBJECT
then
747 Error
("object expected");
750 -- Read the members as string : value pairs
755 Nam
:= Read_Name_With_Prefix
;
756 when Name_Discriminant
=>
758 when Name_Position
=>
759 Position
:= Read_Numerical_Expr
;
760 when Name_First_Bit
=>
761 First_Bit
:= Read_Number
;
763 Comp
.Esize
:= Read_Numerical_Expr
;
765 Error
("invalid component");
768 Read_Token
(TK
, Token_Start
, Token_End
);
769 if TK
= J_OBJECT_END
then
771 elsif TK
/= J_COMMA
then
772 Error
("comma expected");
776 -- Compute Component_Bit_Offset from Position and First_Bit,
777 -- either symbolically or literally depending on Position.
779 if No
(Position
) or else No
(First_Bit
) then
780 Error
("bit offset expected");
783 if Position
< Uint_0
then
785 Bit_Position
: constant Node_Ref_Or_Val
:=
786 Create_Node
(Mult_Expr
, Position
, UI_From_Int
(SSU
));
788 if First_Bit
= Uint_0
then
789 Comp
.Bit_Offset
:= Bit_Position
;
792 Create_Node
(Plus_Expr
, Bit_Position
, First_Bit
);
796 Comp
.Bit_Offset
:= Position
* SSU
+ First_Bit
;
799 -- Store the component into the table
801 JSON_Component_Table
.Append
(Comp
);
803 -- Associate the name with the component
805 if Nam
= No_Name
then
806 Error
("name expected");
809 Set_Name_Table_Int
(Nam
, JSON_Component_Table
.Last
);
811 Read_Token
(TK
, Token_Start
, Token_End
);
812 if TK
= J_ARRAY_END
then
814 elsif TK
/= J_COMMA
then
815 Error
("comma expected");
826 function Read_String
return Valid_Name_Id
is
827 Token_Start
: Text_Position
;
828 Token_End
: Text_Position
;
832 -- Read the string and the following colon
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
);
846 (Kind
: out Token_Kind
;
847 Token_Start
: out Text_Position
;
848 Token_End
: out Text_Position
)
851 -- Update Pos to point to next char
853 function Is_Whitespace
return Boolean;
854 pragma Inline
(Is_Whitespace
);
855 -- Return True of current character is a whitespace
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
861 function Is_Token_Sep
return Boolean;
862 pragma Inline
(Is_Token_Sep
);
863 -- Return True if current character is a token separator
865 procedure Delimit_Keyword
(Kw
: String);
866 -- Helper function to parse tokens such as null, false and true
872 procedure Next_Char
is
874 if Pos
.Index
> Text
'Last then
875 Pos
.Column
:= Pos
.Column
+ 1;
876 elsif Text
(Pos
.Index
) = ASCII
.LF
then
878 Pos
.Line
:= Pos
.Line
+ 1;
880 Pos
.Column
:= Pos
.Column
+ 1;
882 Pos
.Index
:= Pos
.Index
+ 1;
889 function Is_Whitespace
return Boolean is
892 Pos
.Index
<= Text
'Last
894 (Text
(Pos
.Index
) = ASCII
.LF
896 Text
(Pos
.Index
) = ASCII
.CR
898 Text
(Pos
.Index
) = ASCII
.HT
900 Text
(Pos
.Index
) = ' ');
903 -------------------------
904 -- Is_Structural_Token --
905 -------------------------
907 function Is_Structural_Token
return Boolean is
910 Pos
.Index
<= Text
'Last
912 (Text
(Pos
.Index
) = '['
914 Text
(Pos
.Index
) = ']'
916 Text
(Pos
.Index
) = '{'
918 Text
(Pos
.Index
) = '}'
920 Text
(Pos
.Index
) = ','
922 Text
(Pos
.Index
) = ':');
923 end Is_Structural_Token
;
929 function Is_Token_Sep
return Boolean is
932 Pos
.Index
> Text
'Last
939 ---------------------
940 -- Delimit_Keyword --
941 ---------------------
943 procedure Delimit_Keyword
(Kw
: String) is
944 pragma Unreferenced
(Kw
);
946 while not Is_Token_Sep
loop
953 Can_Be_Integer
: Boolean := True;
955 -- Start of processing for Read_Token
958 -- Skip leading whitespaces
960 while Is_Whitespace
loop
964 -- Initialize token delimiters
969 -- End of stream reached
971 if Pos
.Index
> Text
'Last then
976 CC
:= Text
(Pos
.Index
);
992 Kind
:= J_OBJECT_END
;
1003 Delimit_Keyword
("null");
1007 Delimit_Keyword
("false");
1011 Delimit_Keyword
("true");
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
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");
1027 if Text
(Pos
.Index
) = '\' then
1029 if Pos
.Index
> Text
'Last then
1030 Error
("non terminated string token");
1033 case Text
(Pos
.Index
) is
1035 for Idx
in 1 .. 4 loop
1037 if Pos
.Index
> Text
'Last
1038 or else (Text
(Pos
.Index
) not in 'a' .. 'f'
1040 Text
(Pos
.Index
) not in 'A' .. 'F'
1042 Text
(Pos
.Index
) not in '0' .. '9')
1044 Error
("invalid unicode escape sequence");
1047 when '\' |
'/' |
'"' |
'b' |
'f' |
'n' |
'r' |
't' =>
1050 Error
("invalid escape sequence");
1056 -- No quote found report and error
1058 if Pos
.Index
> Text
'Last then
1059 Error
("non terminated string token");
1064 -- Go to next char and ensure that this is separator. Indeed
1065 -- construction such as "string1""string2" are not allowed
1068 if not Is_Token_Sep
then
1069 Error
("invalid syntax");
1073 elsif CC
= '-' or else CC
in '0' .. '9' then
1074 -- We expect a number
1079 if Pos
.Index
> Text
'Last then
1080 Error
("invalid number");
1083 -- Parse integer part of a number. Superfluous leading zeros are
1086 if Text
(Pos
.Index
) = '0' then
1089 elsif Text
(Pos
.Index
) in '1' .. '9' then
1092 while Pos
.Index
<= Text
'Last
1093 and then Text
(Pos
.Index
) in '0' .. '9'
1099 Error
("invalid number");
1102 if Is_Token_Sep
then
1103 -- Valid integer number
1107 elsif Text
(Pos
.Index
) /= '.'
1108 and then Text
(Pos
.Index
) /= 'e'
1109 and then Text
(Pos
.Index
) /= 'E'
1111 Error
("invalid number");
1114 -- Check for a fractional part
1116 if Text
(Pos
.Index
) = '.' then
1117 Can_Be_Integer
:= False;
1120 if Pos
.Index
> Text
'Last
1121 or else Text
(Pos
.Index
) not in '0' .. '9'
1123 Error
("invalid number");
1126 while Pos
.Index
<= Text
'Last
1127 and then Text
(Pos
.Index
) in '0' .. '9'
1135 -- Check for exponent part
1137 if Pos
.Index
<= Text
'Last
1138 and then (Text
(Pos
.Index
) = 'e' or else Text
(Pos
.Index
) = 'E')
1142 if Pos
.Index
> Text
'Last then
1143 Error
("invalid number");
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.
1150 Can_Be_Integer
:= False;
1153 if Text
(Pos
.Index
) = '-' or else Text
(Pos
.Index
) = '+' then
1157 if Pos
.Index
> Text
'Last
1158 or else Text
(Pos
.Index
) not in '0' .. '9'
1160 Error
("invalid number");
1163 while Pos
.Index
<= Text
'Last
1164 and then Text
(Pos
.Index
) in '0' .. '9'
1171 if Is_Token_Sep
then
1172 -- Valid decimal number
1174 if Can_Be_Integer
then
1181 Error
("invalid number");
1186 Error
("Unexpected character");
1190 ----------------------------
1191 -- Read_Token_And_Error --
1192 ----------------------------
1194 procedure Read_Token_And_Error
1196 Token_Start
: out Text_Position
;
1197 Token_End
: out Text_Position
)
1202 -- Read a token and errout out if not of the expected kind
1204 Read_Token
(Kind
, Token_Start
, Token_End
);
1206 Error
("specific token expected");
1208 end Read_Token_And_Error
;
1210 -------------------------
1211 -- Read_Variant_Part --
1212 -------------------------
1214 function Read_Variant_Part
return Nat
is
1217 Token_Start
: Text_Position
;
1218 Token_End
: Text_Position
;
1219 Var
: JSON_Variant_Node
;
1222 -- Read a nonempty array of components
1224 Read_Token_And_Error
(J_ARRAY
, Token_Start
, Token_End
);
1227 Read_Token_And_Error
(J_OBJECT
, Token_Start
, Token_End
);
1231 -- Read the members as string : value pairs
1235 when Name_Present
=>
1236 Var
.Present
:= Read_Numerical_Expr
;
1239 when Name_Variant
=>
1240 Var
.Variant
:= Read_Variant_Part
;
1242 Error
("invalid variant");
1245 Read_Token
(TK
, Token_Start
, Token_End
);
1246 if TK
= J_OBJECT_END
then
1248 elsif TK
/= J_COMMA
then
1249 Error
("comma expected");
1253 -- Chain the variant and store it into the table
1256 JSON_Variant_Table
.Append
(Var
);
1257 Next
:= JSON_Variant_Table
.Last
;
1259 Read_Token
(TK
, Token_Start
, Token_End
);
1260 if TK
= J_ARRAY_END
then
1262 elsif TK
/= J_COMMA
then
1263 Error
("comma expected");
1268 end Read_Variant_Part
;
1274 procedure Skip_Value
is
1275 Array_Depth
: Natural := 0;
1276 Object_Depth
: Natural := 0;
1278 Token_Start
: Text_Position
;
1279 Token_End
: Text_Position
;
1282 -- Read a value without recursing
1285 Read_Token
(TK
, Token_Start
, Token_End
);
1288 when J_STRING | J_INTEGER | J_NUMBER
=>
1291 Array_Depth
:= Array_Depth
+ 1;
1293 Array_Depth
:= Array_Depth
- 1;
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");
1303 Error
("value expected");
1306 exit when Array_Depth
= 0 and then Object_Depth
= 0;
1310 Token_Start
: Text_Position
;
1311 Token_End
: Text_Position
;
1313 Is_First
: Boolean := True;
1315 -- Start of processing for Read_JSON_Stream
1318 -- Read a possibly empty array of entities
1320 Read_Token_And_Error
(J_ARRAY
, Token_Start
, Token_End
);
1323 Read_Token
(TK
, Token_Start
, Token_End
);
1324 if Is_First
and then TK
= J_ARRAY_END
then
1326 elsif TK
/= J_OBJECT
then
1327 Error
("object expected");
1332 Read_Token
(TK
, Token_Start
, Token_End
);
1333 if TK
= J_ARRAY_END
then
1335 elsif TK
/= J_COMMA
then
1336 Error
("comma expected");
1341 end Read_JSON_Stream
;