Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/repinfo-input.adb @ 145:1830386684a0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-9.2.0
author anatofuz
date Thu, 13 Feb 2020 11:34:05 +0900
parents
children
comparison
equal deleted inserted replaced
131:84e7813d76e9 145:1830386684a0
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
32 with Alloc;
33 with Csets; use Csets;
34 with Hostparm; use Hostparm;
35 with Namet; use Namet;
36 with Output; use Output;
37 with Snames; use Snames;
38 with Table;
39
40 package 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
1350 end Repinfo.Input;