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