File : repinfo.adb
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-2016, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with Alloc; use Alloc;
33 with Atree; use Atree;
34 with Casing; use Casing;
35 with Debug; use Debug;
36 with Einfo; use Einfo;
37 with Lib; use Lib;
38 with Namet; use Namet;
39 with Nlists; use Nlists;
40 with Opt; use Opt;
41 with Output; use Output;
42 with Sem_Aux; use Sem_Aux;
43 with Sinfo; use Sinfo;
44 with Sinput; use Sinput;
45 with Snames; use Snames;
46 with Stand; use Stand;
47 with Stringt; use Stringt;
48 with Table; use Table;
49 with Uname; use Uname;
50 with Urealp; use Urealp;
51
52 with Ada.Unchecked_Conversion;
53
54 package body Repinfo is
55
56 SSU : constant := 8;
57 -- Value for Storage_Unit, we do not want to get this from TTypes, since
58 -- this introduces problematic dependencies in ASIS, and in any case this
59 -- value is assumed to be 8 for the implementation of the DDA.
60
61 ---------------------------------------
62 -- Representation of gcc Expressions --
63 ---------------------------------------
64
65 -- This table is used only if Frontend_Layout_On_Target is False, so gigi
66 -- lays out dynamic size/offset fields using encoded gcc expressions.
67
68 -- A table internal to this unit is used to hold the values of back
69 -- annotated expressions. This table is written out by -gnatt and read
70 -- back in for ASIS processing.
71
72 -- Node values are stored as Uint values using the negative of the node
73 -- index in this table. Constants appear as non-negative Uint values.
74
75 type Exp_Node is record
76 Expr : TCode;
77 Op1 : Node_Ref_Or_Val;
78 Op2 : Node_Ref_Or_Val;
79 Op3 : Node_Ref_Or_Val;
80 end record;
81
82 -- The following representation clause ensures that the above record
83 -- has no holes. We do this so that when instances of this record are
84 -- written by Tree_Gen, we do not write uninitialized values to the file.
85
86 for Exp_Node use record
87 Expr at 0 range 0 .. 31;
88 Op1 at 4 range 0 .. 31;
89 Op2 at 8 range 0 .. 31;
90 Op3 at 12 range 0 .. 31;
91 end record;
92
93 for Exp_Node'Size use 16 * 8;
94 -- This ensures that we did not leave out any fields
95
96 package Rep_Table is new Table.Table (
97 Table_Component_Type => Exp_Node,
98 Table_Index_Type => Nat,
99 Table_Low_Bound => 1,
100 Table_Initial => Alloc.Rep_Table_Initial,
101 Table_Increment => Alloc.Rep_Table_Increment,
102 Table_Name => "BE_Rep_Table");
103
104 --------------------------------------------------------------
105 -- Representation of Front-End Dynamic Size/Offset Entities --
106 --------------------------------------------------------------
107
108 package Dynamic_SO_Entity_Table is new Table.Table (
109 Table_Component_Type => Entity_Id,
110 Table_Index_Type => Nat,
111 Table_Low_Bound => 1,
112 Table_Initial => Alloc.Rep_Table_Initial,
113 Table_Increment => Alloc.Rep_Table_Increment,
114 Table_Name => "FE_Rep_Table");
115
116 Unit_Casing : Casing_Type;
117 -- Identifier casing for current unit. This is set by List_Rep_Info for
118 -- each unit, before calling subprograms which may read it.
119
120 Need_Blank_Line : Boolean;
121 -- Set True if a blank line is needed before outputting any information for
122 -- the current entity. Set True when a new entity is processed, and false
123 -- when the blank line is output.
124
125 -----------------------
126 -- Local Subprograms --
127 -----------------------
128
129 function Back_End_Layout return Boolean;
130 -- Test for layout mode, True = back end, False = front end. This function
131 -- is used rather than checking the configuration parameter because we do
132 -- not want Repinfo to depend on Targparm (for ASIS)
133
134 procedure Blank_Line;
135 -- Called before outputting anything for an entity. Ensures that
136 -- a blank line precedes the output for a particular entity.
137
138 procedure List_Entities
139 (Ent : Entity_Id;
140 Bytes_Big_Endian : Boolean;
141 In_Subprogram : Boolean := False);
142 -- This procedure lists the entities associated with the entity E, starting
143 -- with the First_Entity and using the Next_Entity link. If a nested
144 -- package is found, entities within the package are recursively processed.
145 -- When recursing within a subprogram body, Is_Subprogram suppresses
146 -- duplicate information about signature.
147
148 procedure List_Name (Ent : Entity_Id);
149 -- List name of entity Ent in appropriate case. The name is listed with
150 -- full qualification up to but not including the compilation unit name.
151
152 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
153 -- List representation info for array type Ent
154
155 procedure List_Linker_Section (Ent : Entity_Id);
156 -- List linker section for Ent (caller has checked that Ent is an entity
157 -- for which the Linker_Section_Pragma field is defined).
158
159 procedure List_Mechanisms (Ent : Entity_Id);
160 -- List mechanism information for parameters of Ent, which is subprogram,
161 -- subprogram type, or an entry or entry family.
162
163 procedure List_Object_Info (Ent : Entity_Id);
164 -- List representation info for object Ent
165
166 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
167 -- List representation info for record type Ent
168
169 procedure List_Scalar_Storage_Order
170 (Ent : Entity_Id;
171 Bytes_Big_Endian : Boolean);
172 -- List scalar storage order information for record or array type Ent.
173 -- Also includes bit order information for record types, if necessary.
174
175 procedure List_Type_Info (Ent : Entity_Id);
176 -- List type info for type Ent
177
178 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean;
179 -- Returns True if Val represents a variable value, and False if it
180 -- represents a value that is fixed at compile time.
181
182 procedure Spaces (N : Natural);
183 -- Output given number of spaces
184
185 procedure Write_Info_Line (S : String);
186 -- Routine to write a line to Repinfo output file. This routine is passed
187 -- as a special output procedure to Output.Set_Special_Output. Note that
188 -- Write_Info_Line is called with an EOL character at the end of each line,
189 -- as per the Output spec, but the internal call to the appropriate routine
190 -- in Osint requires that the end of line sequence be stripped off.
191
192 procedure Write_Mechanism (M : Mechanism_Type);
193 -- Writes symbolic string for mechanism represented by M
194
195 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
196 -- Given a representation value, write it out. No_Uint values or values
197 -- dependent on discriminants are written as two question marks. If the
198 -- flag Paren is set, then the output is surrounded in parentheses if it is
199 -- other than a simple value.
200
201 ---------------------
202 -- Back_End_Layout --
203 ---------------------
204
205 function Back_End_Layout return Boolean is
206 begin
207 -- We have back end layout if the back end has made any entries in the
208 -- table of GCC expressions, otherwise we have front end layout.
209
210 return Rep_Table.Last > 0;
211 end Back_End_Layout;
212
213 ----------------
214 -- Blank_Line --
215 ----------------
216
217 procedure Blank_Line is
218 begin
219 if Need_Blank_Line then
220 Write_Eol;
221 Need_Blank_Line := False;
222 end if;
223 end Blank_Line;
224
225 ------------------------
226 -- Create_Discrim_Ref --
227 ------------------------
228
229 function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref is
230 begin
231 return Create_Node
232 (Expr => Discrim_Val,
233 Op1 => Discriminant_Number (Discr));
234 end Create_Discrim_Ref;
235
236 ---------------------------
237 -- Create_Dynamic_SO_Ref --
238 ---------------------------
239
240 function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is
241 begin
242 Dynamic_SO_Entity_Table.Append (E);
243 return UI_From_Int (-Dynamic_SO_Entity_Table.Last);
244 end Create_Dynamic_SO_Ref;
245
246 -----------------
247 -- Create_Node --
248 -----------------
249
250 function Create_Node
251 (Expr : TCode;
252 Op1 : Node_Ref_Or_Val;
253 Op2 : Node_Ref_Or_Val := No_Uint;
254 Op3 : Node_Ref_Or_Val := No_Uint) return Node_Ref
255 is
256 begin
257 Rep_Table.Append (
258 (Expr => Expr,
259 Op1 => Op1,
260 Op2 => Op2,
261 Op3 => Op3));
262 return UI_From_Int (-Rep_Table.Last);
263 end Create_Node;
264
265 ---------------------------
266 -- Get_Dynamic_SO_Entity --
267 ---------------------------
268
269 function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id is
270 begin
271 return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U));
272 end Get_Dynamic_SO_Entity;
273
274 -----------------------
275 -- Is_Dynamic_SO_Ref --
276 -----------------------
277
278 function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is
279 begin
280 return U < Uint_0;
281 end Is_Dynamic_SO_Ref;
282
283 ----------------------
284 -- Is_Static_SO_Ref --
285 ----------------------
286
287 function Is_Static_SO_Ref (U : SO_Ref) return Boolean is
288 begin
289 return U >= Uint_0;
290 end Is_Static_SO_Ref;
291
292 ---------
293 -- lgx --
294 ---------
295
296 procedure lgx (U : Node_Ref_Or_Val) is
297 begin
298 List_GCC_Expression (U);
299 Write_Eol;
300 end lgx;
301
302 ----------------------
303 -- List_Array_Info --
304 ----------------------
305
306 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
307 begin
308 List_Type_Info (Ent);
309 Write_Str ("for ");
310 List_Name (Ent);
311 Write_Str ("'Component_Size use ");
312 Write_Val (Component_Size (Ent));
313 Write_Line (";");
314
315 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
316 end List_Array_Info;
317
318 -------------------
319 -- List_Entities --
320 -------------------
321
322 procedure List_Entities
323 (Ent : Entity_Id;
324 Bytes_Big_Endian : Boolean;
325 In_Subprogram : Boolean := False)
326 is
327 Body_E : Entity_Id;
328 E : Entity_Id;
329
330 function Find_Declaration (E : Entity_Id) return Node_Id;
331 -- Utility to retrieve declaration node for entity in the
332 -- case of package bodies and subprograms.
333
334 ----------------------
335 -- Find_Declaration --
336 ----------------------
337
338 function Find_Declaration (E : Entity_Id) return Node_Id is
339 Decl : Node_Id;
340
341 begin
342 Decl := Parent (E);
343 while Present (Decl)
344 and then Nkind (Decl) /= N_Package_Body
345 and then Nkind (Decl) /= N_Subprogram_Declaration
346 and then Nkind (Decl) /= N_Subprogram_Body
347 loop
348 Decl := Parent (Decl);
349 end loop;
350
351 return Decl;
352 end Find_Declaration;
353
354 -- Start of processing for List_Entities
355
356 begin
357 -- List entity if we have one, and it is not a renaming declaration.
358 -- For renamings, we don't get proper information, and really it makes
359 -- sense to restrict the output to the renamed entity.
360
361 if Present (Ent)
362 and then Nkind (Declaration_Node (Ent)) not in N_Renaming_Declaration
363 then
364 -- If entity is a subprogram and we are listing mechanisms,
365 -- then we need to list mechanisms for this entity. We skip this
366 -- if it is a nested subprogram, as the information has already
367 -- been produced when listing the enclosing scope.
368
369 if List_Representation_Info_Mechanisms
370 and then (Is_Subprogram (Ent)
371 or else Ekind (Ent) = E_Entry
372 or else Ekind (Ent) = E_Entry_Family)
373 and then not In_Subprogram
374 then
375 Need_Blank_Line := True;
376 List_Mechanisms (Ent);
377 end if;
378
379 E := First_Entity (Ent);
380 while Present (E) loop
381 Need_Blank_Line := True;
382
383 -- We list entities that come from source (excluding private or
384 -- incomplete types or deferred constants, where we will list the
385 -- info for the full view). If debug flag A is set, then all
386 -- entities are listed
387
388 if (Comes_From_Source (E)
389 and then not Is_Incomplete_Or_Private_Type (E)
390 and then not (Ekind (E) = E_Constant
391 and then Present (Full_View (E))))
392 or else Debug_Flag_AA
393 then
394 if Is_Subprogram (E) then
395 List_Linker_Section (E);
396
397 if List_Representation_Info_Mechanisms then
398 List_Mechanisms (E);
399 end if;
400
401 -- Recurse into entities local to subprogram
402
403 List_Entities (E, Bytes_Big_Endian, True);
404
405 elsif Ekind (E) in Formal_Kind and then In_Subprogram then
406 null;
407
408 elsif Ekind_In (E, E_Entry,
409 E_Entry_Family,
410 E_Subprogram_Type)
411 then
412 if List_Representation_Info_Mechanisms then
413 List_Mechanisms (E);
414 end if;
415
416 elsif Is_Record_Type (E) then
417 if List_Representation_Info >= 1 then
418 List_Record_Info (E, Bytes_Big_Endian);
419 end if;
420
421 List_Linker_Section (E);
422
423 elsif Is_Array_Type (E) then
424 if List_Representation_Info >= 1 then
425 List_Array_Info (E, Bytes_Big_Endian);
426 end if;
427
428 List_Linker_Section (E);
429
430 elsif Is_Type (E) then
431 if List_Representation_Info >= 2 then
432 List_Type_Info (E);
433 List_Linker_Section (E);
434 end if;
435
436 elsif Ekind_In (E, E_Variable, E_Constant) then
437 if List_Representation_Info >= 2 then
438 List_Object_Info (E);
439 List_Linker_Section (E);
440 end if;
441
442 elsif Ekind (E) = E_Loop_Parameter or else Is_Formal (E) then
443 if List_Representation_Info >= 2 then
444 List_Object_Info (E);
445 end if;
446 end if;
447
448 -- Recurse into nested package, but not if they are package
449 -- renamings (in particular renamings of the enclosing package,
450 -- as for some Java bindings and for generic instances).
451
452 if Ekind (E) = E_Package then
453 if No (Renamed_Object (E)) then
454 List_Entities (E, Bytes_Big_Endian);
455 end if;
456
457 -- Recurse into bodies
458
459 elsif Ekind_In (E, E_Protected_Type,
460 E_Task_Type,
461 E_Subprogram_Body,
462 E_Package_Body,
463 E_Task_Body,
464 E_Protected_Body)
465 then
466 List_Entities (E, Bytes_Big_Endian);
467
468 -- Recurse into blocks
469
470 elsif Ekind (E) = E_Block then
471 List_Entities (E, Bytes_Big_Endian);
472 end if;
473 end if;
474
475 E := Next_Entity (E);
476 end loop;
477
478 -- For a package body, the entities of the visible subprograms are
479 -- declared in the corresponding spec. Iterate over its entities in
480 -- order to handle properly the subprogram bodies. Skip bodies in
481 -- subunits, which are listed independently.
482
483 if Ekind (Ent) = E_Package_Body
484 and then Present (Corresponding_Spec (Find_Declaration (Ent)))
485 then
486 E := First_Entity (Corresponding_Spec (Find_Declaration (Ent)));
487 while Present (E) loop
488 if Is_Subprogram (E)
489 and then
490 Nkind (Find_Declaration (E)) = N_Subprogram_Declaration
491 then
492 Body_E := Corresponding_Body (Find_Declaration (E));
493
494 if Present (Body_E)
495 and then
496 Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit
497 then
498 List_Entities (Body_E, Bytes_Big_Endian);
499 end if;
500 end if;
501
502 Next_Entity (E);
503 end loop;
504 end if;
505 end if;
506 end List_Entities;
507
508 -------------------------
509 -- List_GCC_Expression --
510 -------------------------
511
512 procedure List_GCC_Expression (U : Node_Ref_Or_Val) is
513
514 procedure Print_Expr (Val : Node_Ref_Or_Val);
515 -- Internal recursive procedure to print expression
516
517 ----------------
518 -- Print_Expr --
519 ----------------
520
521 procedure Print_Expr (Val : Node_Ref_Or_Val) is
522 begin
523 if Val >= 0 then
524 UI_Write (Val, Decimal);
525
526 else
527 declare
528 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
529
530 procedure Binop (S : String);
531 -- Output text for binary operator with S being operator name
532
533 -----------
534 -- Binop --
535 -----------
536
537 procedure Binop (S : String) is
538 begin
539 Write_Char ('(');
540 Print_Expr (Node.Op1);
541 Write_Str (S);
542 Print_Expr (Node.Op2);
543 Write_Char (')');
544 end Binop;
545
546 -- Start of processing for Print_Expr
547
548 begin
549 case Node.Expr is
550 when Cond_Expr =>
551 Write_Str ("(if ");
552 Print_Expr (Node.Op1);
553 Write_Str (" then ");
554 Print_Expr (Node.Op2);
555 Write_Str (" else ");
556 Print_Expr (Node.Op3);
557 Write_Str (" end)");
558
559 when Plus_Expr =>
560 Binop (" + ");
561
562 when Minus_Expr =>
563 Binop (" - ");
564
565 when Mult_Expr =>
566 Binop (" * ");
567
568 when Trunc_Div_Expr =>
569 Binop (" /t ");
570
571 when Ceil_Div_Expr =>
572 Binop (" /c ");
573
574 when Floor_Div_Expr =>
575 Binop (" /f ");
576
577 when Trunc_Mod_Expr =>
578 Binop (" modt ");
579
580 when Floor_Mod_Expr =>
581 Binop (" modf ");
582
583 when Ceil_Mod_Expr =>
584 Binop (" modc ");
585
586 when Exact_Div_Expr =>
587 Binop (" /e ");
588
589 when Negate_Expr =>
590 Write_Char ('-');
591 Print_Expr (Node.Op1);
592
593 when Min_Expr =>
594 Binop (" min ");
595
596 when Max_Expr =>
597 Binop (" max ");
598
599 when Abs_Expr =>
600 Write_Str ("abs ");
601 Print_Expr (Node.Op1);
602
603 when Truth_Andif_Expr =>
604 Binop (" and if ");
605
606 when Truth_Orif_Expr =>
607 Binop (" or if ");
608
609 when Truth_And_Expr =>
610 Binop (" and ");
611
612 when Truth_Or_Expr =>
613 Binop (" or ");
614
615 when Truth_Xor_Expr =>
616 Binop (" xor ");
617
618 when Truth_Not_Expr =>
619 Write_Str ("not ");
620 Print_Expr (Node.Op1);
621
622 when Bit_And_Expr =>
623 Binop (" & ");
624
625 when Lt_Expr =>
626 Binop (" < ");
627
628 when Le_Expr =>
629 Binop (" <= ");
630
631 when Gt_Expr =>
632 Binop (" > ");
633
634 when Ge_Expr =>
635 Binop (" >= ");
636
637 when Eq_Expr =>
638 Binop (" == ");
639
640 when Ne_Expr =>
641 Binop (" != ");
642
643 when Discrim_Val =>
644 Write_Char ('#');
645 UI_Write (Node.Op1);
646
647 end case;
648 end;
649 end if;
650 end Print_Expr;
651
652 -- Start of processing for List_GCC_Expression
653
654 begin
655 if U = No_Uint then
656 Write_Str ("??");
657 else
658 Print_Expr (U);
659 end if;
660 end List_GCC_Expression;
661
662 -------------------------
663 -- List_Linker_Section --
664 -------------------------
665
666 procedure List_Linker_Section (Ent : Entity_Id) is
667 Arg : Node_Id;
668
669 begin
670 if Present (Linker_Section_Pragma (Ent)) then
671 Write_Str ("pragma Linker_Section (");
672 List_Name (Ent);
673 Write_Str (", """);
674
675 Arg :=
676 Last (Pragma_Argument_Associations (Linker_Section_Pragma (Ent)));
677
678 if Nkind (Arg) = N_Pragma_Argument_Association then
679 Arg := Expression (Arg);
680 end if;
681
682 pragma Assert (Nkind (Arg) = N_String_Literal);
683 String_To_Name_Buffer (Strval (Arg));
684 Write_Str (Name_Buffer (1 .. Name_Len));
685 Write_Str (""");");
686 Write_Eol;
687 end if;
688 end List_Linker_Section;
689
690 ---------------------
691 -- List_Mechanisms --
692 ---------------------
693
694 procedure List_Mechanisms (Ent : Entity_Id) is
695 Plen : Natural;
696 Form : Entity_Id;
697
698 begin
699 Blank_Line;
700
701 case Ekind (Ent) is
702 when E_Function =>
703 Write_Str ("function ");
704
705 when E_Operator =>
706 Write_Str ("operator ");
707
708 when E_Procedure =>
709 Write_Str ("procedure ");
710
711 when E_Subprogram_Type =>
712 Write_Str ("type ");
713
714 when E_Entry | E_Entry_Family =>
715 Write_Str ("entry ");
716
717 when others =>
718 raise Program_Error;
719 end case;
720
721 Get_Unqualified_Decoded_Name_String (Chars (Ent));
722 Write_Str (Name_Buffer (1 .. Name_Len));
723 Write_Str (" declared at ");
724 Write_Location (Sloc (Ent));
725 Write_Eol;
726
727 Write_Str (" convention : ");
728
729 case Convention (Ent) is
730 when Convention_Ada =>
731 Write_Line ("Ada");
732 when Convention_Ada_Pass_By_Copy =>
733 Write_Line ("Ada_Pass_By_Copy");
734 when Convention_Ada_Pass_By_Reference =>
735 Write_Line ("Ada_Pass_By_Reference");
736 when Convention_Intrinsic =>
737 Write_Line ("Intrinsic");
738 when Convention_Entry =>
739 Write_Line ("Entry");
740 when Convention_Protected =>
741 Write_Line ("Protected");
742 when Convention_Assembler =>
743 Write_Line ("Assembler");
744 when Convention_C =>
745 Write_Line ("C");
746 when Convention_COBOL =>
747 Write_Line ("COBOL");
748 when Convention_CPP =>
749 Write_Line ("C++");
750 when Convention_Fortran =>
751 Write_Line ("Fortran");
752 when Convention_Stdcall =>
753 Write_Line ("Stdcall");
754 when Convention_Stubbed =>
755 Write_Line ("Stubbed");
756 end case;
757
758 -- Find max length of formal name
759
760 Plen := 0;
761 Form := First_Formal (Ent);
762 while Present (Form) loop
763 Get_Unqualified_Decoded_Name_String (Chars (Form));
764
765 if Name_Len > Plen then
766 Plen := Name_Len;
767 end if;
768
769 Next_Formal (Form);
770 end loop;
771
772 -- Output formals and mechanisms
773
774 Form := First_Formal (Ent);
775 while Present (Form) loop
776 Get_Unqualified_Decoded_Name_String (Chars (Form));
777 while Name_Len <= Plen loop
778 Name_Len := Name_Len + 1;
779 Name_Buffer (Name_Len) := ' ';
780 end loop;
781
782 Write_Str (" ");
783 Write_Str (Name_Buffer (1 .. Plen + 1));
784 Write_Str (": passed by ");
785
786 Write_Mechanism (Mechanism (Form));
787 Write_Eol;
788 Next_Formal (Form);
789 end loop;
790
791 if Etype (Ent) /= Standard_Void_Type then
792 Write_Str (" returns by ");
793 Write_Mechanism (Mechanism (Ent));
794 Write_Eol;
795 end if;
796 end List_Mechanisms;
797
798 ---------------
799 -- List_Name --
800 ---------------
801
802 procedure List_Name (Ent : Entity_Id) is
803 begin
804 if not Is_Compilation_Unit (Scope (Ent)) then
805 List_Name (Scope (Ent));
806 Write_Char ('.');
807 end if;
808
809 Get_Unqualified_Decoded_Name_String (Chars (Ent));
810 Set_Casing (Unit_Casing);
811 Write_Str (Name_Buffer (1 .. Name_Len));
812 end List_Name;
813
814 ---------------------
815 -- List_Object_Info --
816 ---------------------
817
818 procedure List_Object_Info (Ent : Entity_Id) is
819 begin
820 Blank_Line;
821
822 Write_Str ("for ");
823 List_Name (Ent);
824 Write_Str ("'Size use ");
825 Write_Val (Esize (Ent));
826 Write_Line (";");
827
828 Write_Str ("for ");
829 List_Name (Ent);
830 Write_Str ("'Alignment use ");
831 Write_Val (Alignment (Ent));
832 Write_Line (";");
833 end List_Object_Info;
834
835 ----------------------
836 -- List_Record_Info --
837 ----------------------
838
839 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
840 Comp : Entity_Id;
841 Cfbit : Uint;
842 Sunit : Uint;
843
844 Max_Name_Length : Natural;
845 Max_Suni_Length : Natural;
846
847 begin
848 Blank_Line;
849 List_Type_Info (Ent);
850
851 Write_Str ("for ");
852 List_Name (Ent);
853 Write_Line (" use record");
854
855 -- First loop finds out max line length and max starting position
856 -- length, for the purpose of lining things up nicely.
857
858 Max_Name_Length := 0;
859 Max_Suni_Length := 0;
860
861 Comp := First_Component_Or_Discriminant (Ent);
862 while Present (Comp) loop
863
864 -- Skip discriminant in unchecked union (since it is not there!)
865
866 if Ekind (Comp) = E_Discriminant
867 and then Is_Unchecked_Union (Ent)
868 then
869 null;
870
871 -- All other cases
872
873 else
874 Get_Decoded_Name_String (Chars (Comp));
875 Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len);
876
877 Cfbit := Component_Bit_Offset (Comp);
878
879 if Rep_Not_Constant (Cfbit) then
880 UI_Image_Length := 2;
881
882 else
883 -- Complete annotation in case not done
884
885 Set_Normalized_Position (Comp, Cfbit / SSU);
886 Set_Normalized_First_Bit (Comp, Cfbit mod SSU);
887
888 Sunit := Cfbit / SSU;
889 UI_Image (Sunit);
890 end if;
891
892 -- If the record is not packed, then we know that all fields
893 -- whose position is not specified have a starting normalized
894 -- bit position of zero.
895
896 if Unknown_Normalized_First_Bit (Comp)
897 and then not Is_Packed (Ent)
898 then
899 Set_Normalized_First_Bit (Comp, Uint_0);
900 end if;
901
902 Max_Suni_Length :=
903 Natural'Max (Max_Suni_Length, UI_Image_Length);
904 end if;
905
906 Next_Component_Or_Discriminant (Comp);
907 end loop;
908
909 -- Second loop does actual output based on those values
910
911 Comp := First_Component_Or_Discriminant (Ent);
912 while Present (Comp) loop
913
914 -- Skip discriminant in unchecked union (since it is not there!)
915
916 if Ekind (Comp) = E_Discriminant
917 and then Is_Unchecked_Union (Ent)
918 then
919 goto Continue;
920 end if;
921
922 -- All other cases
923
924 declare
925 Esiz : constant Uint := Esize (Comp);
926 Bofs : constant Uint := Component_Bit_Offset (Comp);
927 Npos : constant Uint := Normalized_Position (Comp);
928 Fbit : constant Uint := Normalized_First_Bit (Comp);
929 Lbit : Uint;
930
931 begin
932 Write_Str (" ");
933 Get_Decoded_Name_String (Chars (Comp));
934 Set_Casing (Unit_Casing);
935 Write_Str (Name_Buffer (1 .. Name_Len));
936
937 for J in 1 .. Max_Name_Length - Name_Len loop
938 Write_Char (' ');
939 end loop;
940
941 Write_Str (" at ");
942
943 if Known_Static_Normalized_Position (Comp) then
944 UI_Image (Npos);
945 Spaces (Max_Suni_Length - UI_Image_Length);
946 Write_Str (UI_Image_Buffer (1 .. UI_Image_Length));
947
948 elsif Known_Component_Bit_Offset (Comp)
949 and then List_Representation_Info = 3
950 then
951 Spaces (Max_Suni_Length - 2);
952 Write_Str ("bit offset");
953 Write_Val (Bofs, Paren => True);
954 Write_Str (" size in bits = ");
955 Write_Val (Esiz, Paren => True);
956 Write_Eol;
957 goto Continue;
958
959 elsif Known_Normalized_Position (Comp)
960 and then List_Representation_Info = 3
961 then
962 Spaces (Max_Suni_Length - 2);
963 Write_Val (Npos);
964
965 else
966 -- For the packed case, we don't know the bit positions if we
967 -- don't know the starting position.
968
969 if Is_Packed (Ent) then
970 Write_Line ("?? range ? .. ??;");
971 goto Continue;
972
973 -- Otherwise we can continue
974
975 else
976 Write_Str ("??");
977 end if;
978 end if;
979
980 Write_Str (" range ");
981 UI_Write (Fbit);
982 Write_Str (" .. ");
983
984 -- Allowing Uint_0 here is an annoying special case. Really this
985 -- should be a fine Esize value but currently it means unknown,
986 -- except that we know after gigi has back annotated that a size
987 -- of zero is real, since otherwise gigi back annotates using
988 -- No_Uint as the value to indicate unknown).
989
990 if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp))
991 and then Known_Static_Normalized_First_Bit (Comp)
992 then
993 Lbit := Fbit + Esiz - 1;
994
995 if Lbit < 10 then
996 Write_Char (' ');
997 end if;
998
999 UI_Write (Lbit);
1000
1001 -- The test for Esize (Comp) not Uint_0 here is an annoying
1002 -- special case. Officially a value of zero for Esize means
1003 -- unknown, but here we use the fact that we know that gigi
1004 -- annotates Esize with No_Uint, not Uint_0. Really everyone
1005 -- should use No_Uint???
1006
1007 elsif List_Representation_Info < 3
1008 or else (Esize (Comp) /= Uint_0 and then Unknown_Esize (Comp))
1009 then
1010 Write_Str ("??");
1011
1012 -- List_Representation >= 3 and Known_Esize (Comp)
1013
1014 else
1015 Write_Val (Esiz, Paren => True);
1016
1017 -- If in front end layout mode, then dynamic size is stored
1018 -- in storage units, so renormalize for output
1019
1020 if not Back_End_Layout then
1021 Write_Str (" * ");
1022 Write_Int (SSU);
1023 end if;
1024
1025 -- Add appropriate first bit offset
1026
1027 if Fbit = 0 then
1028 Write_Str (" - 1");
1029
1030 elsif Fbit = 1 then
1031 null;
1032
1033 else
1034 Write_Str (" + ");
1035 Write_Int (UI_To_Int (Fbit) - 1);
1036 end if;
1037 end if;
1038
1039 Write_Line (";");
1040 end;
1041
1042 <<Continue>>
1043 Next_Component_Or_Discriminant (Comp);
1044 end loop;
1045
1046 Write_Line ("end record;");
1047
1048 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
1049 end List_Record_Info;
1050
1051 -------------------
1052 -- List_Rep_Info --
1053 -------------------
1054
1055 procedure List_Rep_Info (Bytes_Big_Endian : Boolean) is
1056 Col : Nat;
1057
1058 begin
1059 if List_Representation_Info /= 0
1060 or else List_Representation_Info_Mechanisms
1061 then
1062 for U in Main_Unit .. Last_Unit loop
1063 if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
1064 Unit_Casing := Identifier_Casing (Source_Index (U));
1065
1066 -- Normal case, list to standard output
1067
1068 if not List_Representation_Info_To_File then
1069 Write_Eol;
1070 Write_Str ("Representation information for unit ");
1071 Write_Unit_Name (Unit_Name (U));
1072 Col := Column;
1073 Write_Eol;
1074
1075 for J in 1 .. Col - 1 loop
1076 Write_Char ('-');
1077 end loop;
1078
1079 Write_Eol;
1080 List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
1081
1082 -- List representation information to file
1083
1084 else
1085 Create_Repinfo_File_Access.all
1086 (Get_Name_String (File_Name (Source_Index (U))));
1087 Set_Special_Output (Write_Info_Line'Access);
1088 List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
1089 Set_Special_Output (null);
1090 Close_Repinfo_File_Access.all;
1091 end if;
1092 end if;
1093 end loop;
1094 end if;
1095 end List_Rep_Info;
1096
1097 -------------------------------
1098 -- List_Scalar_Storage_Order --
1099 -------------------------------
1100
1101 procedure List_Scalar_Storage_Order
1102 (Ent : Entity_Id;
1103 Bytes_Big_Endian : Boolean)
1104 is
1105 procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean);
1106 -- Show attribute definition clause for Attr_Name (an endianness
1107 -- attribute), depending on whether or not the endianness is reversed
1108 -- compared to native endianness.
1109
1110 ---------------
1111 -- List_Attr --
1112 ---------------
1113
1114 procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean) is
1115 begin
1116 Write_Str ("for ");
1117 List_Name (Ent);
1118 Write_Str ("'" & Attr_Name & " use System.");
1119
1120 if Bytes_Big_Endian xor Is_Reversed then
1121 Write_Str ("High");
1122 else
1123 Write_Str ("Low");
1124 end if;
1125
1126 Write_Line ("_Order_First;");
1127 end List_Attr;
1128
1129 List_SSO : constant Boolean :=
1130 Has_Rep_Item (Ent, Name_Scalar_Storage_Order)
1131 or else SSO_Set_Low_By_Default (Ent)
1132 or else SSO_Set_High_By_Default (Ent);
1133 -- Scalar_Storage_Order is displayed if specified explicitly
1134 -- or set by Default_Scalar_Storage_Order.
1135
1136 -- Start of processing for List_Scalar_Storage_Order
1137
1138 begin
1139 -- For record types, list Bit_Order if not default, or if SSO is shown
1140
1141 if Is_Record_Type (Ent)
1142 and then (List_SSO or else Reverse_Bit_Order (Ent))
1143 then
1144 List_Attr ("Bit_Order", Reverse_Bit_Order (Ent));
1145 end if;
1146
1147 -- List SSO if required. If not, then storage is supposed to be in
1148 -- native order.
1149
1150 if List_SSO then
1151 List_Attr ("Scalar_Storage_Order", Reverse_Storage_Order (Ent));
1152 else
1153 pragma Assert (not Reverse_Storage_Order (Ent));
1154 null;
1155 end if;
1156 end List_Scalar_Storage_Order;
1157
1158 --------------------
1159 -- List_Type_Info --
1160 --------------------
1161
1162 procedure List_Type_Info (Ent : Entity_Id) is
1163 begin
1164 Blank_Line;
1165
1166 -- Do not list size info for unconstrained arrays, not meaningful
1167
1168 if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then
1169 null;
1170
1171 else
1172 -- If Esize and RM_Size are the same and known, list as Size. This
1173 -- is a common case, which we may as well list in simple form.
1174
1175 if Esize (Ent) = RM_Size (Ent) then
1176 Write_Str ("for ");
1177 List_Name (Ent);
1178 Write_Str ("'Size use ");
1179 Write_Val (Esize (Ent));
1180 Write_Line (";");
1181
1182 -- For now, temporary case, to be removed when gigi properly back
1183 -- annotates RM_Size, if RM_Size is not set, then list Esize as Size.
1184 -- This avoids odd Object_Size output till we fix things???
1185
1186 elsif Unknown_RM_Size (Ent) then
1187 Write_Str ("for ");
1188 List_Name (Ent);
1189 Write_Str ("'Size use ");
1190 Write_Val (Esize (Ent));
1191 Write_Line (";");
1192
1193 -- Otherwise list size values separately if they are set
1194
1195 else
1196 Write_Str ("for ");
1197 List_Name (Ent);
1198 Write_Str ("'Object_Size use ");
1199 Write_Val (Esize (Ent));
1200 Write_Line (";");
1201
1202 -- Note on following check: The RM_Size of a discrete type can
1203 -- legitimately be set to zero, so a special check is needed.
1204
1205 Write_Str ("for ");
1206 List_Name (Ent);
1207 Write_Str ("'Value_Size use ");
1208 Write_Val (RM_Size (Ent));
1209 Write_Line (";");
1210 end if;
1211 end if;
1212
1213 Write_Str ("for ");
1214 List_Name (Ent);
1215 Write_Str ("'Alignment use ");
1216 Write_Val (Alignment (Ent));
1217 Write_Line (";");
1218
1219 -- Special stuff for fixed-point
1220
1221 if Is_Fixed_Point_Type (Ent) then
1222
1223 -- Write small (always a static constant)
1224
1225 Write_Str ("for ");
1226 List_Name (Ent);
1227 Write_Str ("'Small use ");
1228 UR_Write (Small_Value (Ent));
1229 Write_Line (";");
1230
1231 -- Write range if static
1232
1233 declare
1234 R : constant Node_Id := Scalar_Range (Ent);
1235
1236 begin
1237 if Nkind (Low_Bound (R)) = N_Real_Literal
1238 and then
1239 Nkind (High_Bound (R)) = N_Real_Literal
1240 then
1241 Write_Str ("for ");
1242 List_Name (Ent);
1243 Write_Str ("'Range use ");
1244 UR_Write (Realval (Low_Bound (R)));
1245 Write_Str (" .. ");
1246 UR_Write (Realval (High_Bound (R)));
1247 Write_Line (";");
1248 end if;
1249 end;
1250 end if;
1251 end List_Type_Info;
1252
1253 ----------------------
1254 -- Rep_Not_Constant --
1255 ----------------------
1256
1257 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is
1258 begin
1259 if Val = No_Uint or else Val < 0 then
1260 return True;
1261 else
1262 return False;
1263 end if;
1264 end Rep_Not_Constant;
1265
1266 ---------------
1267 -- Rep_Value --
1268 ---------------
1269
1270 function Rep_Value
1271 (Val : Node_Ref_Or_Val;
1272 D : Discrim_List) return Uint
1273 is
1274 function B (Val : Boolean) return Uint;
1275 -- Returns Uint_0 for False, Uint_1 for True
1276
1277 function T (Val : Node_Ref_Or_Val) return Boolean;
1278 -- Returns True for 0, False for any non-zero (i.e. True)
1279
1280 function V (Val : Node_Ref_Or_Val) return Uint;
1281 -- Internal recursive routine to evaluate tree
1282
1283 function W (Val : Uint) return Word;
1284 -- Convert Val to Word, assuming Val is always in the Int range. This
1285 -- is a helper function for the evaluation of bitwise expressions like
1286 -- Bit_And_Expr, for which there is no direct support in uintp. Uint
1287 -- values out of the Int range are expected to be seen in such
1288 -- expressions only with overflowing byte sizes around, introducing
1289 -- inherent unreliabilities in computations anyway.
1290
1291 -------
1292 -- B --
1293 -------
1294
1295 function B (Val : Boolean) return Uint is
1296 begin
1297 if Val then
1298 return Uint_1;
1299 else
1300 return Uint_0;
1301 end if;
1302 end B;
1303
1304 -------
1305 -- T --
1306 -------
1307
1308 function T (Val : Node_Ref_Or_Val) return Boolean is
1309 begin
1310 if V (Val) = 0 then
1311 return False;
1312 else
1313 return True;
1314 end if;
1315 end T;
1316
1317 -------
1318 -- V --
1319 -------
1320
1321 function V (Val : Node_Ref_Or_Val) return Uint is
1322 L, R, Q : Uint;
1323
1324 begin
1325 if Val >= 0 then
1326 return Val;
1327
1328 else
1329 declare
1330 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
1331
1332 begin
1333 case Node.Expr is
1334 when Cond_Expr =>
1335 if T (Node.Op1) then
1336 return V (Node.Op2);
1337 else
1338 return V (Node.Op3);
1339 end if;
1340
1341 when Plus_Expr =>
1342 return V (Node.Op1) + V (Node.Op2);
1343
1344 when Minus_Expr =>
1345 return V (Node.Op1) - V (Node.Op2);
1346
1347 when Mult_Expr =>
1348 return V (Node.Op1) * V (Node.Op2);
1349
1350 when Trunc_Div_Expr =>
1351 return V (Node.Op1) / V (Node.Op2);
1352
1353 when Ceil_Div_Expr =>
1354 return
1355 UR_Ceiling
1356 (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
1357
1358 when Floor_Div_Expr =>
1359 return
1360 UR_Floor
1361 (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
1362
1363 when Trunc_Mod_Expr =>
1364 return V (Node.Op1) rem V (Node.Op2);
1365
1366 when Floor_Mod_Expr =>
1367 return V (Node.Op1) mod V (Node.Op2);
1368
1369 when Ceil_Mod_Expr =>
1370 L := V (Node.Op1);
1371 R := V (Node.Op2);
1372 Q := UR_Ceiling (L / UR_From_Uint (R));
1373 return L - R * Q;
1374
1375 when Exact_Div_Expr =>
1376 return V (Node.Op1) / V (Node.Op2);
1377
1378 when Negate_Expr =>
1379 return -V (Node.Op1);
1380
1381 when Min_Expr =>
1382 return UI_Min (V (Node.Op1), V (Node.Op2));
1383
1384 when Max_Expr =>
1385 return UI_Max (V (Node.Op1), V (Node.Op2));
1386
1387 when Abs_Expr =>
1388 return UI_Abs (V (Node.Op1));
1389
1390 when Truth_Andif_Expr =>
1391 return B (T (Node.Op1) and then T (Node.Op2));
1392
1393 when Truth_Orif_Expr =>
1394 return B (T (Node.Op1) or else T (Node.Op2));
1395
1396 when Truth_And_Expr =>
1397 return B (T (Node.Op1) and then T (Node.Op2));
1398
1399 when Truth_Or_Expr =>
1400 return B (T (Node.Op1) or else T (Node.Op2));
1401
1402 when Truth_Xor_Expr =>
1403 return B (T (Node.Op1) xor T (Node.Op2));
1404
1405 when Truth_Not_Expr =>
1406 return B (not T (Node.Op1));
1407
1408 when Bit_And_Expr =>
1409 L := V (Node.Op1);
1410 R := V (Node.Op2);
1411 return UI_From_Int (Int (W (L) and W (R)));
1412
1413 when Lt_Expr =>
1414 return B (V (Node.Op1) < V (Node.Op2));
1415
1416 when Le_Expr =>
1417 return B (V (Node.Op1) <= V (Node.Op2));
1418
1419 when Gt_Expr =>
1420 return B (V (Node.Op1) > V (Node.Op2));
1421
1422 when Ge_Expr =>
1423 return B (V (Node.Op1) >= V (Node.Op2));
1424
1425 when Eq_Expr =>
1426 return B (V (Node.Op1) = V (Node.Op2));
1427
1428 when Ne_Expr =>
1429 return B (V (Node.Op1) /= V (Node.Op2));
1430
1431 when Discrim_Val =>
1432 declare
1433 Sub : constant Int := UI_To_Int (Node.Op1);
1434 begin
1435 pragma Assert (Sub in D'Range);
1436 return D (Sub);
1437 end;
1438
1439 end case;
1440 end;
1441 end if;
1442 end V;
1443
1444 -------
1445 -- W --
1446 -------
1447
1448 -- We use an unchecked conversion to map Int values to their Word
1449 -- bitwise equivalent, which we could not achieve with a normal type
1450 -- conversion for negative Ints. We want bitwise equivalents because W
1451 -- is used as a helper for bit operators like Bit_And_Expr, and can be
1452 -- called for negative Ints in the context of aligning expressions like
1453 -- X+Align & -Align.
1454
1455 function W (Val : Uint) return Word is
1456 function To_Word is new Ada.Unchecked_Conversion (Int, Word);
1457 begin
1458 return To_Word (UI_To_Int (Val));
1459 end W;
1460
1461 -- Start of processing for Rep_Value
1462
1463 begin
1464 if Val = No_Uint then
1465 return No_Uint;
1466
1467 else
1468 return V (Val);
1469 end if;
1470 end Rep_Value;
1471
1472 ------------
1473 -- Spaces --
1474 ------------
1475
1476 procedure Spaces (N : Natural) is
1477 begin
1478 for J in 1 .. N loop
1479 Write_Char (' ');
1480 end loop;
1481 end Spaces;
1482
1483 ---------------
1484 -- Tree_Read --
1485 ---------------
1486
1487 procedure Tree_Read is
1488 begin
1489 Rep_Table.Tree_Read;
1490 end Tree_Read;
1491
1492 ----------------
1493 -- Tree_Write --
1494 ----------------
1495
1496 procedure Tree_Write is
1497 begin
1498 Rep_Table.Tree_Write;
1499 end Tree_Write;
1500
1501 ---------------------
1502 -- Write_Info_Line --
1503 ---------------------
1504
1505 procedure Write_Info_Line (S : String) is
1506 begin
1507 Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1));
1508 end Write_Info_Line;
1509
1510 ---------------------
1511 -- Write_Mechanism --
1512 ---------------------
1513
1514 procedure Write_Mechanism (M : Mechanism_Type) is
1515 begin
1516 case M is
1517 when 0 =>
1518 Write_Str ("default");
1519
1520 when -1 =>
1521 Write_Str ("copy");
1522
1523 when -2 =>
1524 Write_Str ("reference");
1525
1526 when others =>
1527 raise Program_Error;
1528 end case;
1529 end Write_Mechanism;
1530
1531 ---------------
1532 -- Write_Val --
1533 ---------------
1534
1535 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is
1536 begin
1537 if Rep_Not_Constant (Val) then
1538 if List_Representation_Info < 3 or else Val = No_Uint then
1539 Write_Str ("??");
1540
1541 else
1542 if Back_End_Layout then
1543 Write_Char (' ');
1544
1545 if Paren then
1546 Write_Char ('(');
1547 List_GCC_Expression (Val);
1548 Write_Char (')');
1549 else
1550 List_GCC_Expression (Val);
1551 end if;
1552
1553 Write_Char (' ');
1554
1555 else
1556 if Paren then
1557 Write_Char ('(');
1558 Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
1559 Write_Char (')');
1560 else
1561 Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
1562 end if;
1563 end if;
1564 end if;
1565
1566 else
1567 UI_Write (Val);
1568 end if;
1569 end Write_Val;
1570
1571 end Repinfo;