?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
ada: Fix renaming of predefined equality operator for unchecked union types
[official-gcc.git] / gcc / ada / repinfo.adb
blob6a30bc7898b9cf473afeb2931b5076eca0702b03
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- R E P I N F O --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1999-2023, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Alloc;
27 with Atree; use Atree;
28 with Casing; use Casing;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Einfo.Entities; use Einfo.Entities;
32 with Einfo.Utils; use Einfo.Utils;
33 with Lib; use Lib;
34 with Namet; use Namet;
35 with Nlists; use Nlists;
36 with Opt; use Opt;
37 with Output; use Output;
38 with Osint.C; use Osint.C;
39 with Sem_Aux; use Sem_Aux;
40 with Sem_Eval; use Sem_Eval;
41 with Sem_Util;
42 with Sinfo; use Sinfo;
43 with Sinfo.Nodes; use Sinfo.Nodes;
44 with Sinfo.Utils; use Sinfo.Utils;
45 with Sinput; use Sinput;
46 with Snames; use Snames;
47 with Stand; use Stand;
48 with Stringt; use Stringt;
49 with Table;
50 with Ttypes;
51 with Uname; use Uname;
52 with Urealp; use Urealp;
53
54 with Ada.Unchecked_Conversion;
55
56 with GNAT.HTable;
57
58 package body Repinfo is
59
60 SSU : Pos renames Ttypes.System_Storage_Unit;
61 -- Value for Storage_Unit
62
63 ---------------------------------------
64 -- Representation of GCC Expressions --
65 ---------------------------------------
66
67 -- A table internal to this unit is used to hold the values of back
68 -- annotated expressions.
69
70 -- Node values are stored as Uint values using the negative of the node
71 -- index in this table. Constants appear as non-negative Uint values.
72
73 type Exp_Node is record
74 Expr : TCode;
75 Op1 : Node_Ref_Or_Val;
76 Op2 : Node_Ref_Or_Val;
77 Op3 : Node_Ref_Or_Val;
78 end record;
79
80 -- The following representation clause ensures that the above record
81 -- has no holes. We do this so that when instances of this record are
82 -- written, we do not write uninitialized values to the file.
83
84 for Exp_Node use record
85 Expr at 0 range 0 .. 31;
86 Op1 at 4 range 0 .. 31;
87 Op2 at 8 range 0 .. 31;
88 Op3 at 12 range 0 .. 31;
89 end record;
90
91 for Exp_Node'Size use 16 * 8;
92 -- This ensures that we did not leave out any fields
93
94 package Rep_Table is new Table.Table (
95 Table_Component_Type => Exp_Node,
96 Table_Index_Type => Nat,
97 Table_Low_Bound => 1,
98 Table_Initial => Alloc.Rep_Table_Initial,
99 Table_Increment => Alloc.Rep_Table_Increment,
100 Table_Name => "BE_Rep_Table");
101
102 --------------------------------------------------------------
103 -- Representation of Front-End Dynamic Size/Offset Entities --
104 --------------------------------------------------------------
105
106 package Dynamic_SO_Entity_Table is new Table.Table (
107 Table_Component_Type => Entity_Id,
108 Table_Index_Type => Nat,
109 Table_Low_Bound => 1,
110 Table_Initial => Alloc.Rep_Table_Initial,
111 Table_Increment => Alloc.Rep_Table_Increment,
112 Table_Name => "FE_Rep_Table");
113
114 Unit_Casing : Casing_Type;
115 -- Identifier casing for current unit. This is set by List_Rep_Info for
116 -- each unit, before calling subprograms which may read it.
117
118 Need_Separator : Boolean;
119 -- Set True if a separator is needed before outputting any information for
120 -- the current entity.
121
122 ------------------------------
123 -- Set of Relevant Entities --
124 ------------------------------
125
126 Relevant_Entities_Size : constant := 4093;
127 -- Number of headers in hash table
128
129 subtype Entity_Header_Num is Integer range 0 .. Relevant_Entities_Size - 1;
130 -- Range of headers in hash table
131
132 function Entity_Hash (Id : Entity_Id) return Entity_Header_Num;
133 -- Simple hash function for Entity_Ids
134
135 package Relevant_Entities is new GNAT.Htable.Simple_HTable
136 (Header_Num => Entity_Header_Num,
137 Element => Boolean,
138 No_Element => False,
139 Key => Entity_Id,
140 Hash => Entity_Hash,
141 Equal => "=");
142 -- Hash table to record which compiler-generated entities are relevant
143
144 -----------------------
145 -- Local Subprograms --
146 -----------------------
147
148 procedure List_Entities
149 (Ent : Entity_Id;
150 Bytes_Big_Endian : Boolean;
151 In_Subprogram : Boolean := False);
152 -- This procedure lists the entities associated with the entity E, starting
153 -- with the First_Entity and using the Next_Entity link. If a nested
154 -- package is found, entities within the package are recursively processed.
155 -- When recursing within a subprogram body, Is_Subprogram suppresses
156 -- duplicate information about signature.
157
158 procedure List_Name (Ent : Entity_Id);
159 -- List name of entity Ent in appropriate case. The name is listed with
160 -- full qualification up to but not including the compilation unit name.
161
162 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
163 -- List representation info for array type Ent
164
165 procedure List_Common_Type_Info (Ent : Entity_Id);
166 -- List common type info (name, size, alignment) for type Ent
167
168 procedure List_Linker_Section (Ent : Entity_Id);
169 -- List linker section for Ent (caller has checked that Ent is an entity
170 -- for which the Linker_Section_Pragma field is defined).
171
172 procedure List_Location (Ent : Entity_Id);
173 -- List location information for Ent
174
175 procedure List_Object_Info (Ent : Entity_Id);
176 -- List representation info for object Ent
177
178 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
179 -- List representation info for record type Ent
180
181 procedure List_Scalar_Storage_Order
182 (Ent : Entity_Id;
183 Bytes_Big_Endian : Boolean);
184 -- List scalar storage order information for record or array type Ent.
185 -- Also includes bit order information for record types, if necessary.
186
187 procedure List_Subprogram_Info (Ent : Entity_Id);
188 -- List subprogram info for subprogram Ent
189
190 procedure List_Type_Info (Ent : Entity_Id);
191 -- List type info for type Ent
192
193 function Compile_Time_Known_Rep (Val : Node_Ref_Or_Val) return Boolean;
194 -- Returns True if Val represents a representation value that is known at
195 -- compile time.
196
197 procedure Spaces (N : Natural);
198 -- Output given number of spaces
199
200 procedure Write_Info_Line (S : String);
201 -- Routine to write a line to Repinfo output file. This routine is passed
202 -- as a special output procedure to Output.Set_Special_Output. Note that
203 -- Write_Info_Line is called with an EOL character at the end of each line,
204 -- as per the Output spec, but the internal call to the appropriate routine
205 -- in Osint requires that the end of line sequence be stripped off.
206
207 procedure Write_Mechanism (M : Mechanism_Type);
208 -- Writes symbolic string for mechanism represented by M
209
210 procedure Write_Separator;
211 -- Called before outputting anything for an entity. Ensures that
212 -- a separator precedes the output for a particular entity.
213
214 procedure Write_Unknown_Val;
215 -- Writes symbolic string for an unknown or non-representable value
216
217 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
218 -- Given a representation value, write it out. No_Uint values or values
219 -- dependent on discriminants are written as two question marks. If the
220 -- flag Paren is set, then the output is surrounded in parentheses if it is
221 -- other than a simple value.
222
223 ------------------------
224 -- Create_Discrim_Ref --
225 ------------------------
226
227 function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref is
228 begin
229 return Create_Node
230 (Expr => Discrim_Val,
231 Op1 => Discriminant_Number (Discr));
232 end Create_Discrim_Ref;
233
234 ---------------------------
235 -- Create_Dynamic_SO_Ref --
236 ---------------------------
237
238 function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is
239 begin
240 Dynamic_SO_Entity_Table.Append (E);
241 return UI_From_Int (-Dynamic_SO_Entity_Table.Last);
242 end Create_Dynamic_SO_Ref;
243
244 -----------------
245 -- Create_Node --
246 -----------------
247
248 function Create_Node
249 (Expr : TCode;
250 Op1 : Node_Ref_Or_Val;
251 Op2 : Node_Ref_Or_Val := No_Uint;
252 Op3 : Node_Ref_Or_Val := No_Uint) return Node_Ref
253 is
254 begin
255 Rep_Table.Append (
256 (Expr => Expr,
257 Op1 => Op1,
258 Op2 => Op2,
259 Op3 => Op3));
260 return UI_From_Int (-Rep_Table.Last);
261 end Create_Node;
262
263 -----------------
264 -- Entity_Hash --
265 -----------------
266
267 function Entity_Hash (Id : Entity_Id) return Entity_Header_Num is
268 begin
269 return Entity_Header_Num (Id mod Relevant_Entities_Size);
270 end Entity_Hash;
271
272 ---------------------------
273 -- Get_Dynamic_SO_Entity --
274 ---------------------------
275
276 function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id is
277 begin
278 return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U));
279 end Get_Dynamic_SO_Entity;
280
281 -----------------------
282 -- Is_Dynamic_SO_Ref --
283 -----------------------
284
285 function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is
286 begin
287 return U < Uint_0;
288 end Is_Dynamic_SO_Ref;
289
290 ----------------------
291 -- Is_Static_SO_Ref --
292 ----------------------
293
294 function Is_Static_SO_Ref (U : SO_Ref) return Boolean is
295 begin
296 return U >= Uint_0;
297 end Is_Static_SO_Ref;
298
299 ---------
300 -- lgx --
301 ---------
302
303 procedure lgx (U : Node_Ref_Or_Val) is
304 begin
305 List_GCC_Expression (U);
306 Write_Eol;
307 end lgx;
308
309 ----------------------
310 -- List_Array_Info --
311 ----------------------
312
313 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
314 begin
315 Write_Separator;
316
317 if List_Representation_Info_To_JSON then
318 Write_Line ("{");
319 end if;
320
321 List_Common_Type_Info (Ent);
322
323 if List_Representation_Info_To_JSON then
324 Write_Line (",");
325 Write_Str (" ""Component_Size"": ");
326 Write_Val (Component_Size (Ent));
327 else
328 Write_Str ("for ");
329 List_Name (Ent);
330 Write_Str ("'Component_Size use ");
331 Write_Val (Component_Size (Ent));
332 Write_Line (";");
333 end if;
334
335 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
336
337 List_Linker_Section (Ent);
338
339 if List_Representation_Info_To_JSON then
340 Write_Eol;
341 Write_Line ("}");
342 end if;
343
344 -- The component type is relevant for an array
345
346 if List_Representation_Info = 4
347 and then Is_Itype (Component_Type (Base_Type (Ent)))
348 then
349 Relevant_Entities.Set (Component_Type (Base_Type (Ent)), True);
350 end if;
351 end List_Array_Info;
352
353 ---------------------------
354 -- List_Common_Type_Info --
355 ---------------------------
356
357 procedure List_Common_Type_Info (Ent : Entity_Id) is
358 begin
359 if List_Representation_Info_To_JSON then
360 Write_Str (" ""name"": """);
361 List_Name (Ent);
362 Write_Line (""",");
363 List_Location (Ent);
364 end if;
365
366 -- Do not list size info for unconstrained arrays, not meaningful
367
368 if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then
369 null;
370
371 else
372 if Known_Esize (Ent) and then Known_RM_Size (Ent) then
373 -- If Esize and RM_Size are the same, list as Size. This is a
374 -- common case, which we may as well list in simple form.
375
376 if Esize (Ent) = RM_Size (Ent) then
377 if List_Representation_Info_To_JSON then
378 Write_Str (" ""Size"": ");
379 Write_Val (Esize (Ent));
380 Write_Line (",");
381 else
382 Write_Str ("for ");
383 List_Name (Ent);
384 Write_Str ("'Size use ");
385 Write_Val (Esize (Ent));
386 Write_Line (";");
387 end if;
388
389 -- Otherwise list size values separately
390
391 else
392 if List_Representation_Info_To_JSON then
393 Write_Str (" ""Object_Size"": ");
394 Write_Val (Esize (Ent));
395 Write_Line (",");
396
397 Write_Str (" ""Value_Size"": ");
398 Write_Val (RM_Size (Ent));
399 Write_Line (",");
400
401 else
402 Write_Str ("for ");
403 List_Name (Ent);
404 Write_Str ("'Object_Size use ");
405 Write_Val (Esize (Ent));
406 Write_Line (";");
407
408 Write_Str ("for ");
409 List_Name (Ent);
410 Write_Str ("'Value_Size use ");
411 Write_Val (RM_Size (Ent));
412 Write_Line (";");
413 end if;
414 end if;
415 end if;
416 end if;
417
418 if Known_Alignment (Ent) then
419 if List_Representation_Info_To_JSON then
420 Write_Str (" ""Alignment"": ");
421 Write_Val (Alignment (Ent));
422 else
423 Write_Str ("for ");
424 List_Name (Ent);
425 Write_Str ("'Alignment use ");
426 Write_Val (Alignment (Ent));
427 Write_Line (";");
428 end if;
429
430 -- Alignment is not always set for task, protected, and class-wide
431 -- types. Representation aspects are not computed for types in a
432 -- generic unit.
433
434 else
435 pragma Assert
436 (Is_Concurrent_Type (Ent) or else
437 Is_Class_Wide_Type (Ent) or else
438 Sem_Util.In_Generic_Scope (Ent));
439 end if;
440 end List_Common_Type_Info;
441
442 -------------------
443 -- List_Entities --
444 -------------------
445
446 procedure List_Entities
447 (Ent : Entity_Id;
448 Bytes_Big_Endian : Boolean;
449 In_Subprogram : Boolean := False)
450 is
451 Body_E : Entity_Id;
452 E : Entity_Id;
453
454 function Find_Declaration (E : Entity_Id) return Node_Id;
455 -- Utility to retrieve declaration node for entity in the
456 -- case of package bodies and subprograms.
457
458 ----------------------
459 -- Find_Declaration --
460 ----------------------
461
462 function Find_Declaration (E : Entity_Id) return Node_Id is
463 Decl : Node_Id;
464
465 begin
466 Decl := Parent (E);
467 while Present (Decl)
468 and then Nkind (Decl) /= N_Package_Body
469 and then Nkind (Decl) /= N_Subprogram_Declaration
470 and then Nkind (Decl) /= N_Subprogram_Body
471 loop
472 Decl := Parent (Decl);
473 end loop;
474
475 return Decl;
476 end Find_Declaration;
477
478 -- Start of processing for List_Entities
479
480 begin
481 -- List entity if we have one, and it is not a renaming declaration.
482 -- For renamings, we don't get proper information, and really it makes
483 -- sense to restrict the output to the renamed entity.
484
485 if Present (Ent)
486 and then Nkind (Declaration_Node (Ent)) not in N_Renaming_Declaration
487 and then not Is_Ignored_Ghost_Entity (Ent)
488 then
489 -- If entity is a subprogram and we are listing mechanisms,
490 -- then we need to list mechanisms for this entity. We skip this
491 -- if it is a nested subprogram, as the information has already
492 -- been produced when listing the enclosing scope.
493
494 if List_Representation_Info_Mechanisms
495 and then Is_Subprogram_Or_Entry (Ent)
496 and then not In_Subprogram
497 then
498 List_Subprogram_Info (Ent);
499 end if;
500
501 E := First_Entity (Ent);
502 while Present (E) loop
503 -- We list entities that come from source (excluding private or
504 -- incomplete types or deferred constants, for which we will list
505 -- the information for the full view). If requested, we also list
506 -- relevant entities that have been generated when processing the
507 -- original entities coming from source. But if debug flag A is
508 -- set, then all entities are listed.
509
510 if ((Comes_From_Source (E)
511 or else (Ekind (E) = E_Block
512 and then
513 Nkind (Parent (E)) = N_Implicit_Label_Declaration
514 and then
515 Comes_From_Source (Label_Construct (Parent (E)))))
516 and then not Is_Incomplete_Or_Private_Type (E)
517 and then not (Ekind (E) = E_Constant
518 and then Present (Full_View (E))))
519 or else (List_Representation_Info = 4
520 and then Relevant_Entities.Get (E))
521 or else Debug_Flag_AA
522 then
523 if Is_Subprogram (E) then
524 if List_Representation_Info_Mechanisms then
525 List_Subprogram_Info (E);
526 end if;
527
528 -- Recurse into entities local to subprogram
529
530 List_Entities (E, Bytes_Big_Endian, True);
531
532 elsif Ekind (E) in E_Entry
533 | E_Entry_Family
534 | E_Subprogram_Type
535 then
536 if List_Representation_Info_Mechanisms then
537 List_Subprogram_Info (E);
538 end if;
539
540 elsif Is_Record_Type (E) then
541 if List_Representation_Info >= 1 then
542 List_Record_Info (E, Bytes_Big_Endian);
543
544 -- Recurse into entities local to a record type
545
546 if List_Representation_Info = 4 then
547 List_Entities (E, Bytes_Big_Endian, False);
548 end if;
549 end if;
550
551 elsif Is_Array_Type (E) then
552 if List_Representation_Info >= 1 then
553 List_Array_Info (E, Bytes_Big_Endian);
554 end if;
555
556 elsif Is_Type (E) then
557 if List_Representation_Info >= 2 then
558 List_Type_Info (E);
559 end if;
560
561 -- Note that formals are not annotated so we skip them here
562
563 elsif Ekind (E) in E_Constant
564 | E_Loop_Parameter
565 | E_Variable
566 then
567 if List_Representation_Info >= 2 then
568 List_Object_Info (E);
569 end if;
570 end if;
571
572 -- Recurse into nested package, but not child packages, and not
573 -- nested package renamings (in particular renamings of the
574 -- enclosing package, as for some Java bindings and for generic
575 -- instances).
576
577 if Ekind (E) = E_Package then
578 if No (Renamed_Entity (E)) and then not Is_Child_Unit (E)
579 then
580 List_Entities (E, Bytes_Big_Endian);
581 end if;
582
583 -- Recurse into bodies
584
585 elsif Ekind (E) in E_Package_Body
586 | E_Protected_Body
587 | E_Protected_Type
588 | E_Subprogram_Body
589 | E_Task_Body
590 | E_Task_Type
591 then
592 List_Entities (E, Bytes_Big_Endian);
593
594 -- Recurse into blocks
595
596 elsif Ekind (E) = E_Block then
597 List_Entities (E, Bytes_Big_Endian);
598 end if;
599 end if;
600
601 Next_Entity (E);
602 end loop;
603
604 -- For a package body, the entities of the visible subprograms are
605 -- declared in the corresponding spec. Iterate over its entities in
606 -- order to handle properly the subprogram bodies. Skip bodies in
607 -- subunits, which are listed independently.
608
609 if Ekind (Ent) = E_Package_Body
610 and then Present (Corresponding_Spec (Find_Declaration (Ent)))
611 then
612 E := First_Entity (Corresponding_Spec (Find_Declaration (Ent)));
613 while Present (E) loop
614 if Is_Subprogram (E)
615 and then
616 Nkind (Find_Declaration (E)) = N_Subprogram_Declaration
617 then
618 Body_E := Corresponding_Body (Find_Declaration (E));
619
620 if Present (Body_E)
621 and then
622 Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit
623 then
624 List_Entities (Body_E, Bytes_Big_Endian);
625 end if;
626 end if;
627
628 Next_Entity (E);
629 end loop;
630 end if;
631 end if;
632 end List_Entities;
633
634 -------------------------
635 -- List_GCC_Expression --
636 -------------------------
637
638 procedure List_GCC_Expression (U : Node_Ref_Or_Val) is
639
640 procedure Print_Expr (Val : Node_Ref_Or_Val);
641 -- Internal recursive procedure to print expression
642
643 ----------------
644 -- Print_Expr --
645 ----------------
646
647 procedure Print_Expr (Val : Node_Ref_Or_Val) is
648 begin
649 if Val >= 0 then
650 UI_Write (Val, Decimal);
651
652 else
653 declare
654 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
655
656 procedure Unop (S : String);
657 -- Output text for unary operator with S being operator name
658
659 procedure Binop (S : String);
660 -- Output text for binary operator with S being operator name
661
662 ----------
663 -- Unop --
664 ----------
665
666 procedure Unop (S : String) is
667 begin
668 if List_Representation_Info_To_JSON then
669 Write_Str ("{ ""code"": """);
670 if S (S'Last) = ' ' then
671 Write_Str (S (S'First .. S'Last - 1));
672 else
673 Write_Str (S);
674 end if;
675 Write_Str (""", ""operands"": [ ");
676 Print_Expr (Node.Op1);
677 Write_Str (" ] }");
678 else
679 Write_Str (S);
680 Print_Expr (Node.Op1);
681 end if;
682 end Unop;
683
684 -----------
685 -- Binop --
686 -----------
687
688 procedure Binop (S : String) is
689 begin
690 if List_Representation_Info_To_JSON then
691 Write_Str ("{ ""code"": """);
692 Write_Str (S (S'First + 1 .. S'Last - 1));
693 Write_Str (""", ""operands"": [ ");
694 Print_Expr (Node.Op1);
695 Write_Str (", ");
696 Print_Expr (Node.Op2);
697 Write_Str (" ] }");
698 else
699 Write_Char ('(');
700 Print_Expr (Node.Op1);
701 Write_Str (S);
702 Print_Expr (Node.Op2);
703 Write_Char (')');
704 end if;
705 end Binop;
706
707 -- Start of processing for Print_Expr
708
709 begin
710 case Node.Expr is
711 when Cond_Expr =>
712 if List_Representation_Info_To_JSON then
713 Write_Str ("{ ""code"": ""?<>""");
714 Write_Str (", ""operands"": [ ");
715 Print_Expr (Node.Op1);
716 Write_Str (", ");
717 Print_Expr (Node.Op2);
718 Write_Str (", ");
719 Print_Expr (Node.Op3);
720 Write_Str (" ] }");
721 else
722 Write_Str ("(if ");
723 Print_Expr (Node.Op1);
724 Write_Str (" then ");
725 Print_Expr (Node.Op2);
726 Write_Str (" else ");
727 Print_Expr (Node.Op3);
728 Write_Str (" end)");
729 end if;
730
731 when Plus_Expr =>
732 Binop (" + ");
733
734 when Minus_Expr =>
735 Binop (" - ");
736
737 when Mult_Expr =>
738 Binop (" * ");
739
740 when Trunc_Div_Expr =>
741 Binop (" /t ");
742
743 when Ceil_Div_Expr =>
744 Binop (" /c ");
745
746 when Floor_Div_Expr =>
747 Binop (" /f ");
748
749 when Trunc_Mod_Expr =>
750 Binop (" modt ");
751
752 when Ceil_Mod_Expr =>
753 Binop (" modc ");
754
755 when Floor_Mod_Expr =>
756 Binop (" modf ");
757
758 when Exact_Div_Expr =>
759 Binop (" /e ");
760
761 when Negate_Expr =>
762 Unop ("-");
763
764 when Min_Expr =>
765 Binop (" min ");
766
767 when Max_Expr =>
768 Binop (" max ");
769
770 when Abs_Expr =>
771 Unop ("abs ");
772
773 when Truth_And_Expr =>
774 Binop (" and ");
775
776 when Truth_Or_Expr =>
777 Binop (" or ");
778
779 when Truth_Xor_Expr =>
780 Binop (" xor ");
781
782 when Truth_Not_Expr =>
783 Unop ("not ");
784
785 when Lt_Expr =>
786 Binop (" < ");
787
788 when Le_Expr =>
789 Binop (" <= ");
790
791 when Gt_Expr =>
792 Binop (" > ");
793
794 when Ge_Expr =>
795 Binop (" >= ");
796
797 when Eq_Expr =>
798 Binop (" == ");
799
800 when Ne_Expr =>
801 Binop (" != ");
802
803 when Bit_And_Expr =>
804 Binop (" & ");
805
806 when Discrim_Val =>
807 Unop ("#");
808
809 when Dynamic_Val =>
810 Unop ("var");
811 end case;
812 end;
813 end if;
814 end Print_Expr;
815
816 -- Start of processing for List_GCC_Expression
817
818 begin
819 if No (U) then
820 Write_Unknown_Val;
821 else
822 Print_Expr (U);
823 end if;
824 end List_GCC_Expression;
825
826 -------------------------
827 -- List_Linker_Section --
828 -------------------------
829
830 procedure List_Linker_Section (Ent : Entity_Id) is
831 Args : List_Id;
832 Sect : Node_Id;
833
834 begin
835 if Present (Linker_Section_Pragma (Ent)) then
836 Args := Pragma_Argument_Associations (Linker_Section_Pragma (Ent));
837 Sect := Expr_Value_S (Get_Pragma_Arg (Last (Args)));
838
839 if List_Representation_Info_To_JSON then
840 Write_Line (",");
841 Write_Str (" ""Linker_Section"": """);
842 else
843 Write_Str ("pragma Linker_Section (");
844 List_Name (Ent);
845 Write_Str (", """);
846 end if;
847
848 pragma Assert (Nkind (Sect) = N_String_Literal);
849 String_To_Name_Buffer (Strval (Sect));
850 Write_Str (Name_Buffer (1 .. Name_Len));
851 Write_Str ("""");
852 if not List_Representation_Info_To_JSON then
853 Write_Line (");");
854 end if;
855 end if;
856 end List_Linker_Section;
857
858 -------------------
859 -- List_Location --
860 -------------------
861
862 procedure List_Location (Ent : Entity_Id) is
863 begin
864 pragma Assert (List_Representation_Info_To_JSON);
865 Write_Str (" ""location"": """);
866 Write_Location (Sloc (Ent));
867 Write_Line (""",");
868 end List_Location;
869
870 ---------------
871 -- List_Name --
872 ---------------
873
874 procedure List_Name (Ent : Entity_Id) is
875 C : Character;
876
877 begin
878 -- In JSON mode, we recurse up to Standard. This is also valid in
879 -- default mode where we recurse up to the first compilation unit and
880 -- should not get to Standard.
881
882 if Scope (Ent) = Standard_Standard then
883 null;
884 elsif not Is_Compilation_Unit (Scope (Ent))
885 or else List_Representation_Info_To_JSON
886 then
887 List_Name (Scope (Ent));
888 Write_Char ('.');
889 end if;
890
891 Get_Unqualified_Decoded_Name_String (Chars (Ent));
892 Set_Casing (Unit_Casing);
893
894 -- The name of operators needs to be properly escaped for JSON
895
896 for J in 1 .. Name_Len loop
897 C := Name_Buffer (J);
898 if C = '"' and then List_Representation_Info_To_JSON then
899 Write_Char ('\');
900 end if;
901 Write_Char (C);
902 end loop;
903 end List_Name;
904
905 ---------------------
906 -- List_Object_Info --
907 ---------------------
908
909 procedure List_Object_Info (Ent : Entity_Id) is
910 begin
911 -- If size and alignment have not been computed (e.g. if we are in a
912 -- generic unit, or if the back end is not being run), don't try to
913 -- print them.
914
915 pragma Assert (Known_Esize (Ent) = Known_Alignment (Ent));
916 if not Known_Alignment (Ent) then
917 return;
918 end if;
919
920 Write_Separator;
921
922 if List_Representation_Info_To_JSON then
923 Write_Line ("{");
924
925 Write_Str (" ""name"": """);
926 List_Name (Ent);
927 Write_Line (""",");
928 List_Location (Ent);
929
930 Write_Str (" ""Size"": ");
931 Write_Val (Esize (Ent));
932 Write_Line (",");
933
934 Write_Str (" ""Alignment"": ");
935 Write_Val (Alignment (Ent));
936
937 List_Linker_Section (Ent);
938
939 Write_Eol;
940 Write_Line ("}");
941 else
942 Write_Str ("for ");
943 List_Name (Ent);
944 Write_Str ("'Size use ");
945 Write_Val (Esize (Ent));
946 Write_Line (";");
947
948 Write_Str ("for ");
949 List_Name (Ent);
950 Write_Str ("'Alignment use ");
951 Write_Val (Alignment (Ent));
952 Write_Line (";");
953
954 List_Linker_Section (Ent);
955 end if;
956
957 -- The type is relevant for an object
958
959 if List_Representation_Info = 4 and then Is_Itype (Etype (Ent)) then
960 Relevant_Entities.Set (Etype (Ent), True);
961 end if;
962 end List_Object_Info;
963
964 ----------------------
965 -- List_Record_Info --
966 ----------------------
967
968 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
969 procedure Compute_Max_Length
970 (Ent : Entity_Id;
971 Starting_Position : Uint := Uint_0;
972 Starting_First_Bit : Uint := Uint_0;
973 Prefix_Length : Natural := 0);
974 -- Internal recursive procedure to compute the max length
975
976 procedure List_Component_Layout
977 (Ent : Entity_Id;
978 Starting_Position : Uint := Uint_0;
979 Starting_First_Bit : Uint := Uint_0;
980 Prefix : String := "";
981 Indent : Natural := 0);
982 -- Procedure to display the layout of a single component
983
984 procedure List_Record_Layout
985 (Ent : Entity_Id;
986 Starting_Position : Uint := Uint_0;
987 Starting_First_Bit : Uint := Uint_0;
988 Prefix : String := "");
989 -- Internal recursive procedure to display the layout
990
991 procedure List_Structural_Record_Layout
992 (Ent : Entity_Id;
993 Ext_Ent : Entity_Id;
994 Ext_Level : Integer := 0;
995 Variant : Node_Id := Empty;
996 Indent : Natural := 0);
997 -- Internal recursive procedure to display the structural layout.
998 -- If Ext_Ent is not equal to Ent, it is an extension of Ent and
999 -- Ext_Level is the number of successive extensions between them,
1000 -- with the convention that this number is positive when we are
1001 -- called from the fixed part of Ext_Ent and negative when we are
1002 -- called from the variant part of Ext_Ent, if any; this is needed
1003 -- because the fixed and variant parts of a parent of an extension
1004 -- cannot be listed contiguously from this extension's viewpoint.
1005 -- If Variant is present, it's for a variant in the variant part
1006 -- instead of the common part of Ent. Indent is the indentation.
1007
1008 Incomplete_Layout : exception;
1009 -- Exception raised if the layout is incomplete in -gnatc mode
1010
1011 Not_In_Extended_Main : exception;
1012 -- Exception raised when an ancestor is not declared in the main unit
1013
1014 Max_Name_Length : Natural := 0;
1015 Max_Spos_Length : Natural := 0;
1016
1017 ------------------------
1018 -- Compute_Max_Length --
1019 ------------------------
1020
1021 procedure Compute_Max_Length
1022 (Ent : Entity_Id;
1023 Starting_Position : Uint := Uint_0;
1024 Starting_First_Bit : Uint := Uint_0;
1025 Prefix_Length : Natural := 0)
1026 is
1027 Comp : Entity_Id;
1028
1029 begin
1030 Comp := First_Component_Or_Discriminant (Ent);
1031 while Present (Comp) loop
1032
1033 -- Skip a completely hidden discriminant or a discriminant in an
1034 -- unchecked union (since it is not there).
1035
1036 if Ekind (Comp) = E_Discriminant
1037 and then (Is_Completely_Hidden (Comp)
1038 or else Is_Unchecked_Union (Ent))
1039 then
1040 goto Continue;
1041 end if;
1042
1043 -- Skip _Parent component in extension (to avoid overlap)
1044
1045 if Chars (Comp) = Name_uParent then
1046 goto Continue;
1047 end if;
1048
1049 -- All other cases
1050
1051 declare
1052 Ctyp : constant Entity_Id := Underlying_Type (Etype (Comp));
1053 Bofs : constant Uint := Component_Bit_Offset (Comp);
1054 Npos : Uint;
1055 Fbit : Uint;
1056 Spos : Uint;
1057 Sbit : Uint;
1058
1059 Name_Length : Natural;
1060
1061 begin
1062 Get_Decoded_Name_String (Chars (Comp));
1063 Name_Length := Prefix_Length + Name_Len;
1064
1065 if Compile_Time_Known_Rep (Bofs) then
1066 Npos := Bofs / SSU;
1067 Fbit := Bofs mod SSU;
1068
1069 -- Complete annotation in case not done
1070
1071 if not Known_Normalized_First_Bit (Comp) then
1072 Set_Normalized_Position (Comp, Npos);
1073 Set_Normalized_First_Bit (Comp, Fbit);
1074 end if;
1075
1076 Spos := Starting_Position + Npos;
1077 Sbit := Starting_First_Bit + Fbit;
1078
1079 if Sbit >= SSU then
1080 Spos := Spos + 1;
1081 Sbit := Sbit - SSU;
1082 end if;
1083
1084 -- If extended information is requested, recurse fully into
1085 -- record components, i.e. skip the outer level.
1086
1087 if List_Representation_Info_Extended
1088 and then Is_Record_Type (Ctyp)
1089 then
1090 Compute_Max_Length (Ctyp, Spos, Sbit, Name_Length + 1);
1091 goto Continue;
1092 end if;
1093
1094 UI_Image (Spos);
1095 else
1096 -- If the record is not packed, then we know that all fields
1097 -- whose position is not specified have starting normalized
1098 -- bit position of zero.
1099
1100 if not Known_Normalized_First_Bit (Comp)
1101 and then not Is_Packed (Ent)
1102 then
1103 Set_Normalized_First_Bit (Comp, Uint_0);
1104 end if;
1105
1106 UI_Image_Length := 2; -- For "??" marker
1107 end if;
1108
1109 Max_Name_Length := Natural'Max (Max_Name_Length, Name_Length);
1110 Max_Spos_Length :=
1111 Natural'Max (Max_Spos_Length, UI_Image_Length);
1112 end;
1113
1114 <<Continue>>
1115 Next_Component_Or_Discriminant (Comp);
1116 end loop;
1117 end Compute_Max_Length;
1118
1119 ---------------------------
1120 -- List_Component_Layout --
1121 ---------------------------
1122
1123 procedure List_Component_Layout
1124 (Ent : Entity_Id;
1125 Starting_Position : Uint := Uint_0;
1126 Starting_First_Bit : Uint := Uint_0;
1127 Prefix : String := "";
1128 Indent : Natural := 0)
1129 is
1130 Esiz : constant Uint := Esize (Ent);
1131 Npos : constant Uint := Normalized_Position (Ent);
1132 Fbit : constant Uint := Normalized_First_Bit (Ent);
1133 Spos : Uint;
1134 Sbit : Uint := No_Uint;
1135 Lbit : Uint;
1136
1137 begin
1138 if List_Representation_Info_To_JSON then
1139 Spaces (Indent);
1140 Write_Line (" {");
1141 Spaces (Indent);
1142 Write_Str (" ""name"": """);
1143 Write_Str (Prefix);
1144 Write_Str (Name_Buffer (1 .. Name_Len));
1145 Write_Line (""",");
1146 if Ekind (Ent) = E_Discriminant then
1147 Spaces (Indent);
1148 Write_Str (" ""discriminant"": ");
1149 UI_Write (Discriminant_Number (Ent), Decimal);
1150 Write_Line (",");
1151 end if;
1152 Spaces (Indent);
1153 Write_Str (" ""Position"": ");
1154 else
1155 Write_Str (" ");
1156 Write_Str (Prefix);
1157 Write_Str (Name_Buffer (1 .. Name_Len));
1158 Spaces (Max_Name_Length - Prefix'Length - Name_Len);
1159 Write_Str (" at ");
1160 end if;
1161
1162 if Known_Static_Normalized_Position (Ent) then
1163 Spos := Starting_Position + Npos;
1164 Sbit := Starting_First_Bit + Fbit;
1165
1166 if Sbit >= SSU then
1167 Spos := Spos + 1;
1168 end if;
1169
1170 UI_Image (Spos);
1171 Spaces (Max_Spos_Length - UI_Image_Length);
1172 Write_Str (UI_Image_Buffer (1 .. UI_Image_Length));
1173
1174 elsif Known_Normalized_Position (Ent)
1175 and then List_Representation_Info >= 3
1176 then
1177 Spaces (Max_Spos_Length - 2);
1178
1179 if Starting_Position /= Uint_0 then
1180 UI_Write (Starting_Position, Decimal);
1181 Write_Str (" + ");
1182 end if;
1183
1184 Write_Val (Npos);
1185
1186 else
1187 Write_Unknown_Val;
1188 end if;
1189
1190 if List_Representation_Info_To_JSON then
1191 Write_Line (",");
1192 Spaces (Indent);
1193 Write_Str (" ""First_Bit"": ");
1194 else
1195 Write_Str (" range ");
1196 end if;
1197
1198 if Known_Static_Normalized_First_Bit (Ent) then
1199 Sbit := Starting_First_Bit + Fbit;
1200
1201 if Sbit >= SSU then
1202 Sbit := Sbit - SSU;
1203 end if;
1204
1205 UI_Write (Sbit, Decimal);
1206 else
1207 Write_Unknown_Val;
1208 end if;
1209
1210 if List_Representation_Info_To_JSON then
1211 Write_Line (", ");
1212 Spaces (Indent);
1213 Write_Str (" ""Size"": ");
1214 else
1215 Write_Str (" .. ");
1216 end if;
1217
1218 if Known_Static_Esize (Ent)
1219 and then Known_Static_Normalized_First_Bit (Ent)
1220 then
1221 Lbit := Sbit + Esiz - 1;
1222
1223 if List_Representation_Info_To_JSON then
1224 UI_Write (Esiz, Decimal);
1225 else
1226 if Lbit >= 0 and then Lbit < 10 then
1227 Write_Char (' ');
1228 end if;
1229
1230 UI_Write (Lbit, Decimal);
1231 end if;
1232
1233 elsif List_Representation_Info < 3 or else not Known_Esize (Ent) then
1234 Write_Unknown_Val;
1235
1236 -- List_Representation >= 3 and Known_Esize (Ent)
1237
1238 else
1239 Write_Val (Esiz, Paren => not List_Representation_Info_To_JSON);
1240
1241 -- Add appropriate first bit offset
1242
1243 if not List_Representation_Info_To_JSON then
1244 if Sbit = 0 then
1245 Write_Str (" - 1");
1246
1247 elsif Sbit = 1 then
1248 null;
1249
1250 else
1251 Write_Str (" + ");
1252 Write_Int (UI_To_Int (Sbit) - 1);
1253 end if;
1254 end if;
1255 end if;
1256
1257 if List_Representation_Info_To_JSON then
1258 Write_Eol;
1259 Spaces (Indent);
1260 Write_Str (" }");
1261 else
1262 Write_Line (";");
1263 end if;
1264
1265 -- The type is relevant for a component
1266
1267 if List_Representation_Info = 4 and then Is_Itype (Etype (Ent)) then
1268 Relevant_Entities.Set (Etype (Ent), True);
1269 end if;
1270 end List_Component_Layout;
1271
1272 ------------------------
1273 -- List_Record_Layout --
1274 ------------------------
1275
1276 procedure List_Record_Layout
1277 (Ent : Entity_Id;
1278 Starting_Position : Uint := Uint_0;
1279 Starting_First_Bit : Uint := Uint_0;
1280 Prefix : String := "")
1281 is
1282 Comp : Entity_Id;
1283 First : Boolean := True;
1284
1285 begin
1286 Comp := First_Component_Or_Discriminant (Ent);
1287 while Present (Comp) loop
1288
1289 -- Skip a completely hidden discriminant or a discriminant in an
1290 -- unchecked union (since it is not there).
1291
1292 if Ekind (Comp) = E_Discriminant
1293 and then (Is_Completely_Hidden (Comp)
1294 or else Is_Unchecked_Union (Ent))
1295 then
1296 goto Continue;
1297 end if;
1298
1299 -- Skip _Parent component in extension (to avoid overlap)
1300
1301 if Chars (Comp) = Name_uParent then
1302 goto Continue;
1303 end if;
1304
1305 -- All other cases
1306
1307 declare
1308 Ctyp : constant Entity_Id := Underlying_Type (Etype (Comp));
1309 Npos : constant Uint := Normalized_Position (Comp);
1310 Fbit : constant Uint := Normalized_First_Bit (Comp);
1311 Spos : Uint;
1312 Sbit : Uint;
1313
1314 begin
1315 Get_Decoded_Name_String (Chars (Comp));
1316 Set_Casing (Unit_Casing);
1317
1318 -- If extended information is requested, recurse fully into
1319 -- record components, i.e. skip the outer level.
1320
1321 if List_Representation_Info_Extended
1322 and then Is_Record_Type (Ctyp)
1323 and then Known_Static_Normalized_Position (Comp)
1324 and then Known_Static_Normalized_First_Bit (Comp)
1325 then
1326 Spos := Starting_Position + Npos;
1327 Sbit := Starting_First_Bit + Fbit;
1328
1329 if Sbit >= SSU then
1330 Spos := Spos + 1;
1331 Sbit := Sbit - SSU;
1332 end if;
1333
1334 List_Record_Layout (Ctyp,
1335 Spos, Sbit, Prefix & Name_Buffer (1 .. Name_Len) & ".");
1336
1337 goto Continue;
1338 end if;
1339
1340 if List_Representation_Info_To_JSON then
1341 if First then
1342 Write_Eol;
1343 First := False;
1344 else
1345 Write_Line (",");
1346 end if;
1347 end if;
1348
1349 -- The Parent_Subtype in an extension is not back-annotated
1350
1351 List_Component_Layout (
1352 (if Known_Normalized_Position (Comp)
1353 then Comp
1354 else Original_Record_Component (Comp)),
1355 Starting_Position, Starting_First_Bit, Prefix);
1356 end;
1357
1358 <<Continue>>
1359 Next_Component_Or_Discriminant (Comp);
1360 end loop;
1361 end List_Record_Layout;
1362
1363 -----------------------------------
1364 -- List_Structural_Record_Layout --
1365 -----------------------------------
1366
1367 procedure List_Structural_Record_Layout
1368 (Ent : Entity_Id;
1369 Ext_Ent : Entity_Id;
1370 Ext_Level : Integer := 0;
1371 Variant : Node_Id := Empty;
1372 Indent : Natural := 0)
1373 is
1374 function Derived_Discriminant (Disc : Entity_Id) return Entity_Id;
1375 -- This function assumes that Ext_Ent is an extension of Ent.
1376 -- Disc is a discriminant of Ent that does not itself constrain a
1377 -- discriminant of the parent type of Ent. Return the discriminant
1378 -- of Ext_Ent that ultimately constrains Disc, if any.
1379
1380 ----------------------------
1381 -- Derived_Discriminant --
1382 ----------------------------
1383
1384 function Derived_Discriminant (Disc : Entity_Id) return Entity_Id is
1385 Corr_Disc : Entity_Id;
1386 Derived_Disc : Entity_Id;
1387
1388 begin
1389 -- Deal with an extension of a type with unknown discriminants
1390
1391 if Has_Unknown_Discriminants (Ext_Ent)
1392 and then Present (Underlying_Record_View (Ext_Ent))
1393 then
1394 Derived_Disc :=
1395 First_Discriminant (Underlying_Record_View (Ext_Ent));
1396 else
1397 Derived_Disc := First_Discriminant (Ext_Ent);
1398 end if;
1399
1400 -- Loop over the discriminants of the extension
1401
1402 while Present (Derived_Disc) loop
1403
1404 -- Check if this discriminant constrains another discriminant.
1405 -- If so, find the ultimately constrained discriminant and
1406 -- compare with the original components in the base type.
1407
1408 if Present (Corresponding_Discriminant (Derived_Disc)) then
1409 Corr_Disc := Corresponding_Discriminant (Derived_Disc);
1410
1411 while Present (Corresponding_Discriminant (Corr_Disc)) loop
1412 Corr_Disc := Corresponding_Discriminant (Corr_Disc);
1413 end loop;
1414
1415 if Original_Record_Component (Corr_Disc) =
1416 Original_Record_Component (Disc)
1417 then
1418 return Derived_Disc;
1419 end if;
1420 end if;
1421
1422 Next_Discriminant (Derived_Disc);
1423 end loop;
1424
1425 -- Disc is not constrained by a discriminant of Ext_Ent
1426
1427 return Empty;
1428 end Derived_Discriminant;
1429
1430 -- Local declarations
1431
1432 Comp : Node_Id;
1433 Comp_List : Node_Id;
1434 First : Boolean := True;
1435 Parent_Ent : Entity_Id := Empty;
1436 Var : Node_Id;
1437
1438 -- Start of processing for List_Structural_Record_Layout
1439
1440 begin
1441 -- If we are dealing with a variant, just process the components
1442
1443 if Present (Variant) then
1444 Comp_List := Component_List (Variant);
1445
1446 -- Otherwise, we are dealing with the full record and need to get
1447 -- to its definition in order to retrieve its structural layout.
1448
1449 else
1450 declare
1451 Definition : Node_Id :=
1452 Type_Definition (Declaration_Node (Ent));
1453
1454 Is_Extension : constant Boolean :=
1455 Is_Tagged_Type (Ent)
1456 and then Nkind (Definition) =
1457 N_Derived_Type_Definition;
1458
1459 Disc : Entity_Id;
1460 Listed_Disc : Entity_Id;
1461 Parent_Type : Entity_Id;
1462
1463 begin
1464 -- If this is an extension, first list the layout of the parent
1465 -- and then proceed to the extension part, if any.
1466
1467 if Is_Extension then
1468 Parent_Type := Parent_Subtype (Ent);
1469 if No (Parent_Type) then
1470 raise Incomplete_Layout;
1471 end if;
1472
1473 if Is_Private_Type (Parent_Type) then
1474 Parent_Type := Full_View (Parent_Type);
1475 pragma Assert (Present (Parent_Type));
1476 end if;
1477
1478 -- Do not list variants if one of them has been selected
1479
1480 if Has_Static_Discriminants (Parent_Type) then
1481 List_Record_Layout (Parent_Type);
1482
1483 else
1484 Parent_Type := Base_Type (Parent_Type);
1485 if not In_Extended_Main_Source_Unit (Parent_Type) then
1486 raise Not_In_Extended_Main;
1487 end if;
1488
1489 Parent_Ent := Parent_Type;
1490 if Ext_Level >= 0 then
1491 List_Structural_Record_Layout
1492 (Parent_Ent, Ext_Ent, Ext_Level + 1);
1493 end if;
1494 end if;
1495
1496 First := False;
1497
1498 if Present (Record_Extension_Part (Definition)) then
1499 Definition := Record_Extension_Part (Definition);
1500 end if;
1501 end if;
1502
1503 -- If the record has discriminants and is not an unchecked
1504 -- union, then display them now. Note that, even if this is
1505 -- a structural layout, we list the visible discriminants.
1506
1507 if Has_Discriminants (Ent)
1508 and then not Is_Unchecked_Union (Ent)
1509 and then Ext_Level >= 0
1510 then
1511 Disc := First_Discriminant (Ent);
1512 while Present (Disc) loop
1513
1514 -- If this is a record extension and the discriminant is
1515 -- the renaming of another discriminant, skip it.
1516
1517 if Is_Extension
1518 and then Present (Corresponding_Discriminant (Disc))
1519 then
1520 goto Continue_Disc;
1521 end if;
1522
1523 -- If this is the parent type of an extension, retrieve
1524 -- the derived discriminant from the extension, if any.
1525
1526 if Ent /= Ext_Ent then
1527 Listed_Disc := Derived_Discriminant (Disc);
1528
1529 if No (Listed_Disc) then
1530 goto Continue_Disc;
1531
1532 elsif not Known_Normalized_Position (Listed_Disc) then
1533 Listed_Disc :=
1534 Original_Record_Component (Listed_Disc);
1535 end if;
1536
1537 else
1538 Listed_Disc := Disc;
1539 end if;
1540
1541 Get_Decoded_Name_String (Chars (Listed_Disc));
1542 Set_Casing (Unit_Casing);
1543
1544 if First then
1545 Write_Eol;
1546 First := False;
1547 else
1548 Write_Line (",");
1549 end if;
1550
1551 List_Component_Layout (Listed_Disc, Indent => Indent);
1552
1553 <<Continue_Disc>>
1554 Next_Discriminant (Disc);
1555 end loop;
1556 end if;
1557
1558 Comp_List := Component_List (Definition);
1559 end;
1560 end if;
1561
1562 -- Bail out for the null record
1563
1564 if No (Comp_List) then
1565 return;
1566 end if;
1567
1568 -- Now deal with the regular components, if any
1569
1570 if Present (Component_Items (Comp_List))
1571 and then (Present (Variant) or else Ext_Level >= 0)
1572 then
1573 Comp := First_Non_Pragma (Component_Items (Comp_List));
1574 while Present (Comp) loop
1575
1576 -- Skip _Parent component in extension (to avoid overlap)
1577
1578 if Chars (Defining_Identifier (Comp)) = Name_uParent then
1579 goto Continue_Comp;
1580 end if;
1581
1582 Get_Decoded_Name_String (Chars (Defining_Identifier (Comp)));
1583 Set_Casing (Unit_Casing);
1584
1585 if First then
1586 Write_Eol;
1587 First := False;
1588 else
1589 Write_Line (",");
1590 end if;
1591
1592 List_Component_Layout
1593 (Defining_Identifier (Comp), Indent => Indent);
1594
1595 <<Continue_Comp>>
1596 Next_Non_Pragma (Comp);
1597 end loop;
1598 end if;
1599
1600 -- Stop there if we are called from the fixed part of Ext_Ent,
1601 -- we'll do the variant part when called from its variant part.
1602
1603 if Ext_Level > 0 then
1604 return;
1605 end if;
1606
1607 -- List the layout of the variant part of the parent, if any
1608
1609 if Present (Parent_Ent) then
1610 List_Structural_Record_Layout
1611 (Parent_Ent, Ext_Ent, Ext_Level - 1);
1612 end if;
1613
1614 -- We are done if there is no variant part
1615
1616 if No (Variant_Part (Comp_List)) then
1617 return;
1618 end if;
1619
1620 Write_Eol;
1621 Spaces (Indent);
1622 Write_Line (" ],");
1623 Spaces (Indent);
1624 Write_Str (" """);
1625 for J in Ext_Level .. -1 loop
1626 Write_Str ("parent_");
1627 end loop;
1628 Write_Str ("variant"" : [");
1629
1630 -- Otherwise we recurse on each variant
1631
1632 Var := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
1633 First := True;
1634 while Present (Var) loop
1635 if First then
1636 Write_Eol;
1637 First := False;
1638 else
1639 Write_Line (",");
1640 end if;
1641
1642 Spaces (Indent);
1643 Write_Line (" {");
1644 Spaces (Indent);
1645 Write_Str (" ""present"": ");
1646 Write_Val (Present_Expr (Var));
1647 Write_Line (",");
1648 Spaces (Indent);
1649 Write_Str (" ""record"": [");
1650
1651 List_Structural_Record_Layout
1652 (Ent, Ext_Ent, Ext_Level, Var, Indent + 4);
1653
1654 Write_Eol;
1655 Spaces (Indent);
1656 Write_Line (" ]");
1657 Spaces (Indent);
1658 Write_Str (" }");
1659 Next_Non_Pragma (Var);
1660 end loop;
1661 end List_Structural_Record_Layout;
1662
1663 -- Start of processing for List_Record_Info
1664
1665 begin
1666 Write_Separator;
1667
1668 if List_Representation_Info_To_JSON then
1669 Write_Line ("{");
1670 end if;
1671
1672 List_Common_Type_Info (Ent);
1673
1674 -- First find out max line length and max starting position
1675 -- length, for the purpose of lining things up nicely.
1676
1677 Compute_Max_Length (Ent);
1678
1679 -- Then do actual output based on those values
1680
1681 if List_Representation_Info_To_JSON then
1682 Write_Line (",");
1683 Write_Str (" ""record"": [");
1684
1685 -- ??? We can output structural layout only for base types fully
1686 -- declared in the extended main source unit for the time being,
1687 -- because otherwise declarations might not be processed at all.
1688
1689 if Is_Base_Type (Ent) then
1690 begin
1691 List_Structural_Record_Layout (Ent, Ent);
1692
1693 exception
1694 when Incomplete_Layout
1695 | Not_In_Extended_Main
1696 =>
1697 List_Record_Layout (Ent);
1698
1699 when others =>
1700 raise Program_Error;
1701 end;
1702 else
1703 List_Record_Layout (Ent);
1704 end if;
1705
1706 Write_Eol;
1707 Write_Str (" ]");
1708 else
1709 Write_Str ("for ");
1710 List_Name (Ent);
1711 Write_Line (" use record");
1712
1713 List_Record_Layout (Ent);
1714
1715 Write_Line ("end record;");
1716 end if;
1717
1718 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
1719
1720 List_Linker_Section (Ent);
1721
1722 if List_Representation_Info_To_JSON then
1723 Write_Eol;
1724 Write_Line ("}");
1725 end if;
1726
1727 -- The type is relevant for a record subtype
1728
1729 if List_Representation_Info = 4
1730 and then not Is_Base_Type (Ent)
1731 and then Is_Itype (Etype (Ent))
1732 then
1733 Relevant_Entities.Set (Etype (Ent), True);
1734 end if;
1735 end List_Record_Info;
1736
1737 -------------------
1738 -- List_Rep_Info --
1739 -------------------
1740
1741 procedure List_Rep_Info (Bytes_Big_Endian : Boolean) is
1742 Col : Nat;
1743
1744 begin
1745 if List_Representation_Info /= 0
1746 or else List_Representation_Info_Mechanisms
1747 then
1748 -- For the normal case, we output a single JSON stream
1749
1750 if not List_Representation_Info_To_File
1751 and then List_Representation_Info_To_JSON
1752 then
1753 Write_Line ("[");
1754 Need_Separator := False;
1755 end if;
1756
1757 for U in Main_Unit .. Last_Unit loop
1758 if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
1759 Unit_Casing := Identifier_Casing (Source_Index (U));
1760
1761 if List_Representation_Info = 4 then
1762 Relevant_Entities.Reset;
1763 end if;
1764
1765 -- Normal case, list to standard output
1766
1767 if not List_Representation_Info_To_File then
1768 if not List_Representation_Info_To_JSON then
1769 Write_Eol;
1770 Write_Str ("Representation information for unit ");
1771 Write_Unit_Name (Unit_Name (U));
1772 Col := Column;
1773 Write_Eol;
1774
1775 for J in 1 .. Col - 1 loop
1776 Write_Char ('-');
1777 end loop;
1778
1779 Write_Eol;
1780 Need_Separator := True;
1781 end if;
1782
1783 List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
1784
1785 -- List representation information to file
1786
1787 else
1788 Create_Repinfo_File
1789 (Get_Name_String (File_Name (Source_Index (U))));
1790 Set_Special_Output (Write_Info_Line'Access);
1791 if List_Representation_Info_To_JSON then
1792 Write_Line ("[");
1793 end if;
1794 Need_Separator := False;
1795 List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
1796 if List_Representation_Info_To_JSON then
1797 Write_Line ("]");
1798 end if;
1799 Cancel_Special_Output;
1800 Close_Repinfo_File;
1801 end if;
1802 end if;
1803 end loop;
1804
1805 if not List_Representation_Info_To_File
1806 and then List_Representation_Info_To_JSON
1807 then
1808 Write_Line ("]");
1809 end if;
1810 end if;
1811 end List_Rep_Info;
1812
1813 -------------------------------
1814 -- List_Scalar_Storage_Order --
1815 -------------------------------
1816
1817 procedure List_Scalar_Storage_Order
1818 (Ent : Entity_Id;
1819 Bytes_Big_Endian : Boolean)
1820 is
1821 procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean);
1822 -- Show attribute definition clause for Attr_Name (an endianness
1823 -- attribute), depending on whether or not the endianness is reversed
1824 -- compared to native endianness.
1825
1826 ---------------
1827 -- List_Attr --
1828 ---------------
1829
1830 procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean) is
1831 begin
1832 if List_Representation_Info_To_JSON then
1833 Write_Line (",");
1834 Write_Str (" """);
1835 Write_Str (Attr_Name);
1836 Write_Str (""": ""System.");
1837 else
1838 Write_Str ("for ");
1839 List_Name (Ent);
1840 Write_Char (''');
1841 Write_Str (Attr_Name);
1842 Write_Str (" use System.");
1843 end if;
1844
1845 if Bytes_Big_Endian xor Is_Reversed then
1846 Write_Str ("High");
1847 else
1848 Write_Str ("Low");
1849 end if;
1850
1851 Write_Str ("_Order_First");
1852 if List_Representation_Info_To_JSON then
1853 Write_Str ("""");
1854 else
1855 Write_Line (";");
1856 end if;
1857 end List_Attr;
1858
1859 List_SSO : constant Boolean :=
1860 Has_Rep_Item (Ent, Name_Scalar_Storage_Order)
1861 or else SSO_Set_Low_By_Default (Ent)
1862 or else SSO_Set_High_By_Default (Ent);
1863 -- Scalar_Storage_Order is displayed if specified explicitly or set by
1864 -- Default_Scalar_Storage_Order.
1865
1866 -- Start of processing for List_Scalar_Storage_Order
1867
1868 begin
1869 -- For record types, list Bit_Order if not default, or if SSO is shown
1870
1871 -- Also, when -gnatR4 is in effect always list bit order and scalar
1872 -- storage order explicitly, so that you don't need to know the native
1873 -- endianness of the target for which the output was produced in order
1874 -- to interpret it.
1875
1876 if Is_Record_Type (Ent)
1877 and then (List_SSO
1878 or else Reverse_Bit_Order (Ent)
1879 or else List_Representation_Info = 4)
1880 then
1881 List_Attr ("Bit_Order", Reverse_Bit_Order (Ent));
1882 end if;
1883
1884 -- List SSO if required. If not, then storage is supposed to be in
1885 -- native order.
1886
1887 if List_SSO or else List_Representation_Info = 4 then
1888 List_Attr ("Scalar_Storage_Order", Reverse_Storage_Order (Ent));
1889 else
1890 pragma Assert (not Reverse_Storage_Order (Ent));
1891 null;
1892 end if;
1893 end List_Scalar_Storage_Order;
1894
1895 --------------------------
1896 -- List_Subprogram_Info --
1897 --------------------------
1898
1899 procedure List_Subprogram_Info (Ent : Entity_Id) is
1900 First : Boolean := True;
1901 Plen : Natural;
1902 Form : Entity_Id;
1903
1904 begin
1905 Write_Separator;
1906
1907 if List_Representation_Info_To_JSON then
1908 Write_Line ("{");
1909 Write_Str (" ""name"": """);
1910 List_Name (Ent);
1911 Write_Line (""",");
1912 List_Location (Ent);
1913
1914 Write_Str (" ""Convention"": """);
1915 else
1916 case Ekind (Ent) is
1917 when E_Function =>
1918 Write_Str ("function ");
1919
1920 when E_Operator =>
1921 Write_Str ("operator ");
1922
1923 when E_Procedure =>
1924 Write_Str ("procedure ");
1925
1926 when E_Subprogram_Type =>
1927 Write_Str ("type ");
1928
1929 when E_Entry
1930 | E_Entry_Family
1931 =>
1932 Write_Str ("entry ");
1933
1934 when others =>
1935 raise Program_Error;
1936 end case;
1937
1938 List_Name (Ent);
1939 Write_Str (" declared at ");
1940 Write_Location (Sloc (Ent));
1941 Write_Eol;
1942
1943 Write_Str ("convention : ");
1944 end if;
1945
1946 case Convention (Ent) is
1947 when Convention_Ada =>
1948 Write_Str ("Ada");
1949
1950 when Convention_Ada_Pass_By_Copy =>
1951 Write_Str ("Ada_Pass_By_Copy");
1952
1953 when Convention_Ada_Pass_By_Reference =>
1954 Write_Str ("Ada_Pass_By_Reference");
1955
1956 when Convention_Intrinsic =>
1957 Write_Str ("Intrinsic");
1958
1959 when Convention_Entry =>
1960 Write_Str ("Entry");
1961
1962 when Convention_Protected =>
1963 Write_Str ("Protected");
1964
1965 when Convention_Assembler =>
1966 Write_Str ("Assembler");
1967
1968 when Convention_C =>
1969 Write_Str ("C");
1970
1971 when Convention_C_Variadic =>
1972 declare
1973 N : Nat :=
1974 Convention_Id'Pos (Convention (Ent)) -
1975 Convention_Id'Pos (Convention_C_Variadic_0);
1976 begin
1977 Write_Str ("C_Variadic_");
1978 if N >= 10 then
1979 Write_Char ('1');
1980 N := N - 10;
1981 end if;
1982 pragma Assert (N < 10);
1983 Write_Char (Character'Val (Character'Pos ('0') + N));
1984 end;
1985
1986 when Convention_COBOL =>
1987 Write_Str ("COBOL");
1988
1989 when Convention_CPP =>
1990 Write_Str ("C++");
1991
1992 when Convention_Fortran =>
1993 Write_Str ("Fortran");
1994
1995 when Convention_Stdcall =>
1996 Write_Str ("Stdcall");
1997
1998 when Convention_Stubbed =>
1999 Write_Str ("Stubbed");
2000 end case;
2001
2002 if List_Representation_Info_To_JSON then
2003 Write_Line (""",");
2004 Write_Str (" ""formal"": [");
2005 else
2006 Write_Eol;
2007 end if;
2008
2009 -- Find max length of formal name
2010
2011 Plen := 0;
2012 Form := First_Formal (Ent);
2013 while Present (Form) loop
2014 Get_Unqualified_Decoded_Name_String (Chars (Form));
2015
2016 if Name_Len > Plen then
2017 Plen := Name_Len;
2018 end if;
2019
2020 Next_Formal (Form);
2021 end loop;
2022
2023 -- Output formals and mechanisms
2024
2025 Form := First_Formal (Ent);
2026 while Present (Form) loop
2027 Get_Unqualified_Decoded_Name_String (Chars (Form));
2028 Set_Casing (Unit_Casing);
2029
2030 if List_Representation_Info_To_JSON then
2031 if First then
2032 Write_Eol;
2033 First := False;
2034 else
2035 Write_Line (",");
2036 end if;
2037
2038 Write_Line (" {");
2039 Write_Str (" ""name"": """);
2040 Write_Str (Name_Buffer (1 .. Name_Len));
2041 Write_Line (""",");
2042
2043 Write_Str (" ""mechanism"": """);
2044 Write_Mechanism (Mechanism (Form));
2045 Write_Line ("""");
2046 Write_Str (" }");
2047 else
2048 while Name_Len <= Plen loop
2049 Name_Len := Name_Len + 1;
2050 Name_Buffer (Name_Len) := ' ';
2051 end loop;
2052
2053 Write_Str (" ");
2054 Write_Str (Name_Buffer (1 .. Plen + 1));
2055 Write_Str (": passed by ");
2056
2057 Write_Mechanism (Mechanism (Form));
2058 Write_Eol;
2059 end if;
2060
2061 Next_Formal (Form);
2062 end loop;
2063
2064 if List_Representation_Info_To_JSON then
2065 Write_Eol;
2066 Write_Str (" ]");
2067 end if;
2068
2069 if Ekind (Ent) = E_Function then
2070 if List_Representation_Info_To_JSON then
2071 Write_Line (",");
2072 Write_Str (" ""mechanism"": """);
2073 Write_Mechanism (Mechanism (Ent));
2074 Write_Str ("""");
2075 else
2076 Write_Str ("returns by ");
2077 Write_Mechanism (Mechanism (Ent));
2078 Write_Eol;
2079 end if;
2080 end if;
2081
2082 if not Is_Entry (Ent) then
2083 List_Linker_Section (Ent);
2084 end if;
2085
2086 if List_Representation_Info_To_JSON then
2087 Write_Eol;
2088 Write_Line ("}");
2089 end if;
2090 end List_Subprogram_Info;
2091
2092 --------------------
2093 -- List_Type_Info --
2094 --------------------
2095
2096 procedure List_Type_Info (Ent : Entity_Id) is
2097 begin
2098 Write_Separator;
2099
2100 if List_Representation_Info_To_JSON then
2101 Write_Line ("{");
2102 end if;
2103
2104 List_Common_Type_Info (Ent);
2105
2106 -- Special stuff for fixed-point
2107
2108 if Is_Fixed_Point_Type (Ent) then
2109
2110 -- Write small (always a static constant)
2111
2112 if List_Representation_Info_To_JSON then
2113 Write_Line (",");
2114 Write_Str (" ""Small"": ");
2115 UR_Write_To_JSON (Small_Value (Ent));
2116 else
2117 Write_Str ("for ");
2118 List_Name (Ent);
2119 Write_Str ("'Small use ");
2120 UR_Write (Small_Value (Ent));
2121 Write_Line (";");
2122 end if;
2123
2124 -- Write range if static
2125
2126 declare
2127 R : constant Node_Id := Scalar_Range (Ent);
2128
2129 begin
2130 if Nkind (Low_Bound (R)) = N_Real_Literal
2131 and then
2132 Nkind (High_Bound (R)) = N_Real_Literal
2133 then
2134 if List_Representation_Info_To_JSON then
2135 Write_Line (",");
2136 Write_Str (" ""Range"": [ ");
2137 UR_Write_To_JSON (Realval (Low_Bound (R)));
2138 Write_Str (", ");
2139 UR_Write_To_JSON (Realval (High_Bound (R)));
2140 Write_Str (" ]");
2141 else
2142 Write_Str ("for ");
2143 List_Name (Ent);
2144 Write_Str ("'Range use ");
2145 UR_Write (Realval (Low_Bound (R)));
2146 Write_Str (" .. ");
2147 UR_Write (Realval (High_Bound (R)));
2148 Write_Line (";");
2149 end if;
2150 end if;
2151 end;
2152 end if;
2153
2154 List_Linker_Section (Ent);
2155
2156 if List_Representation_Info_To_JSON then
2157 Write_Eol;
2158 Write_Line ("}");
2159 end if;
2160 end List_Type_Info;
2161
2162 ----------------------------
2163 -- Compile_Time_Known_Rep --
2164 ----------------------------
2165
2166 function Compile_Time_Known_Rep (Val : Node_Ref_Or_Val) return Boolean is
2167 begin
2168 return Present (Val) and then Val >= 0;
2169 end Compile_Time_Known_Rep;
2170
2171 ---------------
2172 -- Rep_Value --
2173 ---------------
2174
2175 function Rep_Value (Val : Node_Ref_Or_Val; D : Discrim_List) return Uint is
2176
2177 function B (Val : Boolean) return Ubool;
2178 -- Returns Uint_0 for False, Uint_1 for True
2179
2180 function T (Val : Node_Ref_Or_Val) return Boolean;
2181 -- Returns True for 0, False for any non-zero (i.e. True)
2182
2183 function V (Val : Node_Ref_Or_Val) return Uint;
2184 -- Internal recursive routine to evaluate tree
2185
2186 function W (Val : Uint) return Word;
2187 -- Convert Val to Word, assuming Val is always in the Int range. This
2188 -- is a helper function for the evaluation of bitwise expressions like
2189 -- Bit_And_Expr, for which there is no direct support in uintp. Uint
2190 -- values out of the Int range are expected to be seen in such
2191 -- expressions only with overflowing byte sizes around, introducing
2192 -- inherent unreliabilities in computations anyway.
2193
2194 -------
2195 -- B --
2196 -------
2197
2198 function B (Val : Boolean) return Ubool is
2199 begin
2200 if Val then
2201 return Uint_1;
2202 else
2203 return Uint_0;
2204 end if;
2205 end B;
2206
2207 -------
2208 -- T --
2209 -------
2210
2211 function T (Val : Node_Ref_Or_Val) return Boolean is
2212 begin
2213 if V (Val) = 0 then
2214 return False;
2215 else
2216 return True;
2217 end if;
2218 end T;
2219
2220 -------
2221 -- V --
2222 -------
2223
2224 function V (Val : Node_Ref_Or_Val) return Uint is
2225 L, R, Q : Uint;
2226
2227 begin
2228 if Val >= 0 then
2229 return Val;
2230
2231 else
2232 declare
2233 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
2234
2235 begin
2236 case Node.Expr is
2237 when Cond_Expr =>
2238 if T (Node.Op1) then
2239 return V (Node.Op2);
2240 else
2241 return V (Node.Op3);
2242 end if;
2243
2244 when Plus_Expr =>
2245 return V (Node.Op1) + V (Node.Op2);
2246
2247 when Minus_Expr =>
2248 return V (Node.Op1) - V (Node.Op2);
2249
2250 when Mult_Expr =>
2251 return V (Node.Op1) * V (Node.Op2);
2252
2253 when Trunc_Div_Expr =>
2254 return V (Node.Op1) / V (Node.Op2);
2255
2256 when Ceil_Div_Expr =>
2257 return
2258 UR_Ceiling
2259 (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
2260
2261 when Floor_Div_Expr =>
2262 return
2263 UR_Floor
2264 (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
2265
2266 when Trunc_Mod_Expr =>
2267 return V (Node.Op1) rem V (Node.Op2);
2268
2269 when Floor_Mod_Expr =>
2270 return V (Node.Op1) mod V (Node.Op2);
2271
2272 when Ceil_Mod_Expr =>
2273 L := V (Node.Op1);
2274 R := V (Node.Op2);
2275 Q := UR_Ceiling (L / UR_From_Uint (R));
2276 return L - R * Q;
2277
2278 when Exact_Div_Expr =>
2279 return V (Node.Op1) / V (Node.Op2);
2280
2281 when Negate_Expr =>
2282 return -V (Node.Op1);
2283
2284 when Min_Expr =>
2285 return UI_Min (V (Node.Op1), V (Node.Op2));
2286
2287 when Max_Expr =>
2288 return UI_Max (V (Node.Op1), V (Node.Op2));
2289
2290 when Abs_Expr =>
2291 return UI_Abs (V (Node.Op1));
2292
2293 when Truth_And_Expr =>
2294 return B (T (Node.Op1) and then T (Node.Op2));
2295
2296 when Truth_Or_Expr =>
2297 return B (T (Node.Op1) or else T (Node.Op2));
2298
2299 when Truth_Xor_Expr =>
2300 return B (T (Node.Op1) xor T (Node.Op2));
2301
2302 when Truth_Not_Expr =>
2303 return B (not T (Node.Op1));
2304
2305 when Bit_And_Expr =>
2306 L := V (Node.Op1);
2307 R := V (Node.Op2);
2308 return UI_From_Int (Int (W (L) and W (R)));
2309
2310 when Lt_Expr =>
2311 return B (V (Node.Op1) < V (Node.Op2));
2312
2313 when Le_Expr =>
2314 return B (V (Node.Op1) <= V (Node.Op2));
2315
2316 when Gt_Expr =>
2317 return B (V (Node.Op1) > V (Node.Op2));
2318
2319 when Ge_Expr =>
2320 return B (V (Node.Op1) >= V (Node.Op2));
2321
2322 when Eq_Expr =>
2323 return B (V (Node.Op1) = V (Node.Op2));
2324
2325 when Ne_Expr =>
2326 return B (V (Node.Op1) /= V (Node.Op2));
2327
2328 when Discrim_Val =>
2329 declare
2330 Sub : constant Int := UI_To_Int (Node.Op1);
2331 begin
2332 pragma Assert (Sub in D'Range);
2333 return D (Sub);
2334 end;
2335
2336 when Dynamic_Val =>
2337 return No_Uint;
2338 end case;
2339 end;
2340 end if;
2341 end V;
2342
2343 -------
2344 -- W --
2345 -------
2346
2347 -- We use an unchecked conversion to map Int values to their Word
2348 -- bitwise equivalent, which we could not achieve with a normal type
2349 -- conversion for negative Ints. We want bitwise equivalents because W
2350 -- is used as a helper for bit operators like Bit_And_Expr, and can be
2351 -- called for negative Ints in the context of aligning expressions like
2352 -- X+Align & -Align.
2353
2354 function W (Val : Uint) return Word is
2355 function To_Word is new Ada.Unchecked_Conversion (Int, Word);
2356 begin
2357 return To_Word (UI_To_Int (Val));
2358 end W;
2359
2360 -- Start of processing for Rep_Value
2361
2362 begin
2363 if No (Val) then
2364 return No_Uint;
2365
2366 else
2367 return V (Val);
2368 end if;
2369 end Rep_Value;
2370
2371 ------------
2372 -- Spaces --
2373 ------------
2374
2375 procedure Spaces (N : Natural) is
2376 begin
2377 for J in 1 .. N loop
2378 Write_Char (' ');
2379 end loop;
2380 end Spaces;
2381
2382 ---------------------
2383 -- Write_Info_Line --
2384 ---------------------
2385
2386 procedure Write_Info_Line (S : String) is
2387 begin
2388 Write_Repinfo_Line (S (S'First .. S'Last - 1));
2389 end Write_Info_Line;
2390
2391 ---------------------
2392 -- Write_Mechanism --
2393 ---------------------
2394
2395 procedure Write_Mechanism (M : Mechanism_Type) is
2396 begin
2397 case M is
2398 when 0 =>
2399 Write_Str ("default");
2400
2401 when -1 =>
2402 Write_Str ("copy");
2403
2404 when -2 =>
2405 Write_Str ("reference");
2406
2407 when others =>
2408 raise Program_Error;
2409 end case;
2410 end Write_Mechanism;
2411
2412 ---------------------
2413 -- Write_Separator --
2414 ---------------------
2415
2416 procedure Write_Separator is
2417 begin
2418 if Need_Separator then
2419 if List_Representation_Info_To_JSON then
2420 Write_Line (",");
2421 else
2422 Write_Eol;
2423 end if;
2424 else
2425 Need_Separator := True;
2426 end if;
2427 end Write_Separator;
2428
2429 -----------------------
2430 -- Write_Unknown_Val --
2431 -----------------------
2432
2433 procedure Write_Unknown_Val is
2434 begin
2435 if List_Representation_Info_To_JSON then
2436 Write_Str ("""??""");
2437 else
2438 Write_Str ("??");
2439 end if;
2440 end Write_Unknown_Val;
2441
2442 ---------------
2443 -- Write_Val --
2444 ---------------
2445
2446 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is
2447 begin
2448 if Compile_Time_Known_Rep (Val) then
2449 UI_Write (Val, Decimal);
2450 elsif List_Representation_Info < 3 or else No (Val) then
2451 Write_Unknown_Val;
2452 else
2453 if Paren then
2454 Write_Char ('(');
2455 end if;
2456
2457 List_GCC_Expression (Val);
2458
2459 if Paren then
2460 Write_Char (')');
2461 end if;
2462 end if;
2463 end Write_Val;
2464
2465 end Repinfo;
Mirror of the offical gcc git repository hosted at gcc.gnu.org