projects / gcc.git / blob
? search:


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