Dead
[official-gcc.git] / gomp-20050608-branch / gcc / ada / repinfo.adb
blobba1646bfad9108aac2b68203fdec395e16e5665c
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-2005 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 with Alloc; use Alloc;
35 with Atree; use Atree;
36 with Casing; use Casing;
37 with Debug; use Debug;
38 with Einfo; use Einfo;
39 with Lib; use Lib;
40 with Namet; use Namet;
41 with Opt; use Opt;
42 with Output; use Output;
43 with Sinfo; use Sinfo;
44 with Sinput; use Sinput;
45 with Snames; use Snames;
46 with Stand; use Stand;
47 with Table; use Table;
48 with Uname; use Uname;
49 with Urealp; use Urealp;
51 with Ada.Unchecked_Conversion;
53 package body Repinfo is
55 SSU : constant := 8;
56 -- Value for Storage_Unit, we do not want to get this from TTypes, since
57 -- this introduces problematic dependencies in ASIS, and in any case this
58 -- value is assumed to be 8 for the implementation of the DDA.
60 -- This is wrong for AAMP???
62 ---------------------------------------
63 -- Representation of gcc Expressions --
64 ---------------------------------------
66 -- This table is used only if Frontend_Layout_On_Target is False, so that
67 -- gigi lays out dynamic size/offset fields using encoded gcc
68 -- expressions.
70 -- A table internal to this unit is used to hold the values of back
71 -- annotated expressions. This table is written out by -gnatt and read
72 -- back in for ASIS processing.
74 -- Node values are stored as Uint values using the negative of the node
75 -- index in this table. Constants appear as non-negative Uint values.
77 type Exp_Node is record
78 Expr : TCode;
79 Op1 : Node_Ref_Or_Val;
80 Op2 : Node_Ref_Or_Val;
81 Op3 : Node_Ref_Or_Val;
82 end record;
84 package Rep_Table is new Table.Table (
85 Table_Component_Type => Exp_Node,
86 Table_Index_Type => Nat,
87 Table_Low_Bound => 1,
88 Table_Initial => Alloc.Rep_Table_Initial,
89 Table_Increment => Alloc.Rep_Table_Increment,
90 Table_Name => "BE_Rep_Table");
92 --------------------------------------------------------------
93 -- Representation of Front-End Dynamic Size/Offset Entities --
94 --------------------------------------------------------------
96 package Dynamic_SO_Entity_Table is new Table.Table (
97 Table_Component_Type => Entity_Id,
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 => "FE_Rep_Table");
104 Unit_Casing : Casing_Type;
105 -- Identifier casing for current unit
107 Need_Blank_Line : Boolean;
108 -- Set True if a blank line is needed before outputting any information for
109 -- the current entity. Set True when a new entity is processed, and false
110 -- when the blank line is output.
112 -----------------------
113 -- Local Subprograms --
114 -----------------------
116 function Back_End_Layout return Boolean;
117 -- Test for layout mode, True = back end, False = front end. This function
118 -- is used rather than checking the configuration parameter because we do
119 -- not want Repinfo to depend on Targparm (for ASIS)
121 procedure Blank_Line;
122 -- Called before outputting anything for an entity. Ensures that
123 -- a blank line precedes the output for a particular entity.
125 procedure List_Entities (Ent : Entity_Id);
126 -- This procedure lists the entities associated with the entity E, starting
127 -- with the First_Entity and using the Next_Entity link. If a nested
128 -- package is found, entities within the package are recursively processed.
130 procedure List_Name (Ent : Entity_Id);
131 -- List name of entity Ent in appropriate case. The name is listed with
132 -- full qualification up to but not including the compilation unit name.
134 procedure List_Array_Info (Ent : Entity_Id);
135 -- List representation info for array type Ent
137 procedure List_Mechanisms (Ent : Entity_Id);
138 -- List mechanism information for parameters of Ent, which is subprogram,
139 -- subprogram type, or an entry or entry family.
141 procedure List_Object_Info (Ent : Entity_Id);
142 -- List representation info for object Ent
144 procedure List_Record_Info (Ent : Entity_Id);
145 -- List representation info for record type Ent
147 procedure List_Type_Info (Ent : Entity_Id);
148 -- List type info for type Ent
150 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean;
151 -- Returns True if Val represents a variable value, and False if it
152 -- represents a value that is fixed at compile time.
154 procedure Spaces (N : Natural);
155 -- Output given number of spaces
157 procedure Write_Info_Line (S : String);
158 -- Routine to write a line to Repinfo output file. This routine is passed
159 -- as a special output procedure to Output.Set_Special_Output. Note that
160 -- Write_Info_Line is called with an EOL character at the end of each line,
161 -- as per the Output spec, but the internal call to the appropriate routine
162 -- in Osint requires that the end of line sequence be stripped off.
164 procedure Write_Mechanism (M : Mechanism_Type);
165 -- Writes symbolic string for mechanism represented by M
167 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
168 -- Given a representation value, write it out. No_Uint values or values
169 -- dependent on discriminants are written as two question marks. If the
170 -- flag Paren is set, then the output is surrounded in parentheses if it is
171 -- other than a simple value.
173 ---------------------
174 -- Back_End_Layout --
175 ---------------------
177 function Back_End_Layout return Boolean is
178 begin
179 -- We have back end layout if the back end has made any entries in the
180 -- table of GCC expressions, otherwise we have front end layout.
182 return Rep_Table.Last > 0;
183 end Back_End_Layout;
185 ----------------
186 -- Blank_Line --
187 ----------------
189 procedure Blank_Line is
190 begin
191 if Need_Blank_Line then
192 Write_Eol;
193 Need_Blank_Line := False;
194 end if;
195 end Blank_Line;
197 ------------------------
198 -- Create_Discrim_Ref --
199 ------------------------
201 function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref is
202 N : constant Uint := Discriminant_Number (Discr);
203 T : Nat;
204 begin
205 Rep_Table.Increment_Last;
206 T := Rep_Table.Last;
207 Rep_Table.Table (T).Expr := Discrim_Val;
208 Rep_Table.Table (T).Op1 := N;
209 Rep_Table.Table (T).Op2 := No_Uint;
210 Rep_Table.Table (T).Op3 := No_Uint;
211 return UI_From_Int (-T);
212 end Create_Discrim_Ref;
214 ---------------------------
215 -- Create_Dynamic_SO_Ref --
216 ---------------------------
218 function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is
219 T : Nat;
220 begin
221 Dynamic_SO_Entity_Table.Increment_Last;
222 T := Dynamic_SO_Entity_Table.Last;
223 Dynamic_SO_Entity_Table.Table (T) := E;
224 return UI_From_Int (-T);
225 end Create_Dynamic_SO_Ref;
227 -----------------
228 -- Create_Node --
229 -----------------
231 function Create_Node
232 (Expr : TCode;
233 Op1 : Node_Ref_Or_Val;
234 Op2 : Node_Ref_Or_Val := No_Uint;
235 Op3 : Node_Ref_Or_Val := No_Uint) return Node_Ref
237 T : Nat;
238 begin
239 Rep_Table.Increment_Last;
240 T := Rep_Table.Last;
241 Rep_Table.Table (T).Expr := Expr;
242 Rep_Table.Table (T).Op1 := Op1;
243 Rep_Table.Table (T).Op2 := Op2;
244 Rep_Table.Table (T).Op3 := Op3;
245 return UI_From_Int (-T);
246 end Create_Node;
248 ---------------------------
249 -- Get_Dynamic_SO_Entity --
250 ---------------------------
252 function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id is
253 begin
254 return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U));
255 end Get_Dynamic_SO_Entity;
257 -----------------------
258 -- Is_Dynamic_SO_Ref --
259 -----------------------
261 function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is
262 begin
263 return U < Uint_0;
264 end Is_Dynamic_SO_Ref;
266 ----------------------
267 -- Is_Static_SO_Ref --
268 ----------------------
270 function Is_Static_SO_Ref (U : SO_Ref) return Boolean is
271 begin
272 return U >= Uint_0;
273 end Is_Static_SO_Ref;
275 ---------
276 -- lgx --
277 ---------
279 procedure lgx (U : Node_Ref_Or_Val) is
280 begin
281 List_GCC_Expression (U);
282 Write_Eol;
283 end lgx;
285 ----------------------
286 -- List_Array_Info --
287 ----------------------
289 procedure List_Array_Info (Ent : Entity_Id) is
290 begin
291 List_Type_Info (Ent);
292 Write_Str ("for ");
293 List_Name (Ent);
294 Write_Str ("'Component_Size use ");
295 Write_Val (Component_Size (Ent));
296 Write_Line (";");
297 end List_Array_Info;
299 -------------------
300 -- List_Entities --
301 -------------------
303 procedure List_Entities (Ent : Entity_Id) is
304 Body_E : Entity_Id;
305 E : Entity_Id;
307 function Find_Declaration (E : Entity_Id) return Node_Id;
308 -- Utility to retrieve declaration node for entity in the
309 -- case of package bodies and subprograms.
311 ----------------------
312 -- Find_Declaration --
313 ----------------------
315 function Find_Declaration (E : Entity_Id) return Node_Id is
316 Decl : Node_Id;
318 begin
319 Decl := Parent (E);
320 while Present (Decl)
321 and then Nkind (Decl) /= N_Package_Body
322 and then Nkind (Decl) /= N_Subprogram_Declaration
323 and then Nkind (Decl) /= N_Subprogram_Body
324 loop
325 Decl := Parent (Decl);
326 end loop;
328 return Decl;
329 end Find_Declaration;
331 -- Start of processing for List_Entities
333 begin
334 if Present (Ent) then
336 -- If entity is a subprogram and we are listing mechanisms,
337 -- then we need to list mechanisms for this entity.
339 if List_Representation_Info_Mechanisms
340 and then (Is_Subprogram (Ent)
341 or else Ekind (Ent) = E_Entry
342 or else Ekind (Ent) = E_Entry_Family)
343 then
344 Need_Blank_Line := True;
345 List_Mechanisms (Ent);
346 end if;
348 E := First_Entity (Ent);
349 while Present (E) loop
350 Need_Blank_Line := True;
352 -- We list entities that come from source (excluding private or
353 -- incomplete types or deferred constants, where we will list the
354 -- info for the full view). If debug flag A is set, then all
355 -- entities are listed
357 if (Comes_From_Source (E)
358 and then not Is_Incomplete_Or_Private_Type (E)
359 and then not (Ekind (E) = E_Constant
360 and then Present (Full_View (E))))
361 or else Debug_Flag_AA
362 then
363 if Is_Subprogram (E)
364 or else
365 Ekind (E) = E_Entry
366 or else
367 Ekind (E) = E_Entry_Family
368 or else
369 Ekind (E) = E_Subprogram_Type
370 then
371 if List_Representation_Info_Mechanisms then
372 List_Mechanisms (E);
373 end if;
375 elsif Is_Record_Type (E) then
376 if List_Representation_Info >= 1 then
377 List_Record_Info (E);
378 end if;
380 elsif Is_Array_Type (E) then
381 if List_Representation_Info >= 1 then
382 List_Array_Info (E);
383 end if;
385 elsif Is_Type (E) then
386 if List_Representation_Info >= 2 then
387 List_Type_Info (E);
388 end if;
390 elsif Ekind (E) = E_Variable
391 or else
392 Ekind (E) = E_Constant
393 or else
394 Ekind (E) = E_Loop_Parameter
395 or else
396 Is_Formal (E)
397 then
398 if List_Representation_Info >= 2 then
399 List_Object_Info (E);
400 end if;
402 end if;
404 -- Recurse into nested package, but not if they are package
405 -- renamings (in particular renamings of the enclosing package,
406 -- as for some Java bindings and for generic instances).
408 if Ekind (E) = E_Package then
409 if No (Renamed_Object (E)) then
410 List_Entities (E);
411 end if;
413 -- Recurse into bodies
415 elsif Ekind (E) = E_Protected_Type
416 or else
417 Ekind (E) = E_Task_Type
418 or else
419 Ekind (E) = E_Subprogram_Body
420 or else
421 Ekind (E) = E_Package_Body
422 or else
423 Ekind (E) = E_Task_Body
424 or else
425 Ekind (E) = E_Protected_Body
426 then
427 List_Entities (E);
429 -- Recurse into blocks
431 elsif Ekind (E) = E_Block then
432 List_Entities (E);
433 end if;
434 end if;
436 E := Next_Entity (E);
437 end loop;
439 -- For a package body, the entities of the visible subprograms are
440 -- declared in the corresponding spec. Iterate over its entities in
441 -- order to handle properly the subprogram bodies. Skip bodies in
442 -- subunits, which are listed independently.
444 if Ekind (Ent) = E_Package_Body
445 and then Present (Corresponding_Spec (Find_Declaration (Ent)))
446 then
447 E := First_Entity (Corresponding_Spec (Find_Declaration (Ent)));
449 while Present (E) loop
450 if Is_Subprogram (E)
451 and then
452 Nkind (Find_Declaration (E)) = N_Subprogram_Declaration
453 then
454 Body_E := Corresponding_Body (Find_Declaration (E));
456 if Present (Body_E)
457 and then
458 Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit
459 then
460 List_Entities (Body_E);
461 end if;
462 end if;
464 Next_Entity (E);
465 end loop;
466 end if;
467 end if;
468 end List_Entities;
470 -------------------------
471 -- List_GCC_Expression --
472 -------------------------
474 procedure List_GCC_Expression (U : Node_Ref_Or_Val) is
476 procedure Print_Expr (Val : Node_Ref_Or_Val);
477 -- Internal recursive procedure to print expression
479 ----------------
480 -- Print_Expr --
481 ----------------
483 procedure Print_Expr (Val : Node_Ref_Or_Val) is
484 begin
485 if Val >= 0 then
486 UI_Write (Val, Decimal);
488 else
489 declare
490 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
492 procedure Binop (S : String);
493 -- Output text for binary operator with S being operator name
495 -----------
496 -- Binop --
497 -----------
499 procedure Binop (S : String) is
500 begin
501 Write_Char ('(');
502 Print_Expr (Node.Op1);
503 Write_Str (S);
504 Print_Expr (Node.Op2);
505 Write_Char (')');
506 end Binop;
508 -- Start of processing for Print_Expr
510 begin
511 case Node.Expr is
512 when Cond_Expr =>
513 Write_Str ("(if ");
514 Print_Expr (Node.Op1);
515 Write_Str (" then ");
516 Print_Expr (Node.Op2);
517 Write_Str (" else ");
518 Print_Expr (Node.Op3);
519 Write_Str (" end)");
521 when Plus_Expr =>
522 Binop (" + ");
524 when Minus_Expr =>
525 Binop (" - ");
527 when Mult_Expr =>
528 Binop (" * ");
530 when Trunc_Div_Expr =>
531 Binop (" /t ");
533 when Ceil_Div_Expr =>
534 Binop (" /c ");
536 when Floor_Div_Expr =>
537 Binop (" /f ");
539 when Trunc_Mod_Expr =>
540 Binop (" modt ");
542 when Floor_Mod_Expr =>
543 Binop (" modf ");
545 when Ceil_Mod_Expr =>
546 Binop (" modc ");
548 when Exact_Div_Expr =>
549 Binop (" /e ");
551 when Negate_Expr =>
552 Write_Char ('-');
553 Print_Expr (Node.Op1);
555 when Min_Expr =>
556 Binop (" min ");
558 when Max_Expr =>
559 Binop (" max ");
561 when Abs_Expr =>
562 Write_Str ("abs ");
563 Print_Expr (Node.Op1);
565 when Truth_Andif_Expr =>
566 Binop (" and if ");
568 when Truth_Orif_Expr =>
569 Binop (" or if ");
571 when Truth_And_Expr =>
572 Binop (" and ");
574 when Truth_Or_Expr =>
575 Binop (" or ");
577 when Truth_Xor_Expr =>
578 Binop (" xor ");
580 when Truth_Not_Expr =>
581 Write_Str ("not ");
582 Print_Expr (Node.Op1);
584 when Bit_And_Expr =>
585 Binop (" & ");
587 when Lt_Expr =>
588 Binop (" < ");
590 when Le_Expr =>
591 Binop (" <= ");
593 when Gt_Expr =>
594 Binop (" > ");
596 when Ge_Expr =>
597 Binop (" >= ");
599 when Eq_Expr =>
600 Binop (" == ");
602 when Ne_Expr =>
603 Binop (" != ");
605 when Discrim_Val =>
606 Write_Char ('#');
607 UI_Write (Node.Op1);
609 end case;
610 end;
611 end if;
612 end Print_Expr;
614 -- Start of processing for List_GCC_Expression
616 begin
617 if U = No_Uint then
618 Write_Str ("??");
619 else
620 Print_Expr (U);
621 end if;
622 end List_GCC_Expression;
624 ---------------------
625 -- List_Mechanisms --
626 ---------------------
628 procedure List_Mechanisms (Ent : Entity_Id) is
629 Plen : Natural;
630 Form : Entity_Id;
632 begin
633 Blank_Line;
635 case Ekind (Ent) is
636 when E_Function =>
637 Write_Str ("function ");
639 when E_Operator =>
640 Write_Str ("operator ");
642 when E_Procedure =>
643 Write_Str ("procedure ");
645 when E_Subprogram_Type =>
646 Write_Str ("type ");
648 when E_Entry | E_Entry_Family =>
649 Write_Str ("entry ");
651 when others =>
652 raise Program_Error;
653 end case;
655 Get_Unqualified_Decoded_Name_String (Chars (Ent));
656 Write_Str (Name_Buffer (1 .. Name_Len));
657 Write_Str (" declared at ");
658 Write_Location (Sloc (Ent));
659 Write_Eol;
661 Write_Str (" convention : ");
663 case Convention (Ent) is
664 when Convention_Ada => Write_Line ("Ada");
665 when Convention_Intrinsic => Write_Line ("InLineinsic");
666 when Convention_Entry => Write_Line ("Entry");
667 when Convention_Protected => Write_Line ("Protected");
668 when Convention_Assembler => Write_Line ("Assembler");
669 when Convention_C => Write_Line ("C");
670 when Convention_COBOL => Write_Line ("COBOL");
671 when Convention_CPP => Write_Line ("C++");
672 when Convention_Fortran => Write_Line ("Fortran");
673 when Convention_Java => Write_Line ("Java");
674 when Convention_Stdcall => Write_Line ("Stdcall");
675 when Convention_Stubbed => Write_Line ("Stubbed");
676 end case;
678 -- Find max length of formal name
680 Plen := 0;
681 Form := First_Formal (Ent);
682 while Present (Form) loop
683 Get_Unqualified_Decoded_Name_String (Chars (Form));
685 if Name_Len > Plen then
686 Plen := Name_Len;
687 end if;
689 Next_Formal (Form);
690 end loop;
692 -- Output formals and mechanisms
694 Form := First_Formal (Ent);
695 while Present (Form) loop
696 Get_Unqualified_Decoded_Name_String (Chars (Form));
698 while Name_Len <= Plen loop
699 Name_Len := Name_Len + 1;
700 Name_Buffer (Name_Len) := ' ';
701 end loop;
703 Write_Str (" ");
704 Write_Str (Name_Buffer (1 .. Plen + 1));
705 Write_Str (": passed by ");
707 Write_Mechanism (Mechanism (Form));
708 Write_Eol;
709 Next_Formal (Form);
710 end loop;
712 if Etype (Ent) /= Standard_Void_Type then
713 Write_Str (" returns by ");
714 Write_Mechanism (Mechanism (Ent));
715 Write_Eol;
716 end if;
717 end List_Mechanisms;
719 ---------------
720 -- List_Name --
721 ---------------
723 procedure List_Name (Ent : Entity_Id) is
724 begin
725 if not Is_Compilation_Unit (Scope (Ent)) then
726 List_Name (Scope (Ent));
727 Write_Char ('.');
728 end if;
730 Get_Unqualified_Decoded_Name_String (Chars (Ent));
731 Set_Casing (Unit_Casing);
732 Write_Str (Name_Buffer (1 .. Name_Len));
733 end List_Name;
735 ---------------------
736 -- List_Object_Info --
737 ---------------------
739 procedure List_Object_Info (Ent : Entity_Id) is
740 begin
741 Blank_Line;
743 Write_Str ("for ");
744 List_Name (Ent);
745 Write_Str ("'Size use ");
746 Write_Val (Esize (Ent));
747 Write_Line (";");
749 Write_Str ("for ");
750 List_Name (Ent);
751 Write_Str ("'Alignment use ");
752 Write_Val (Alignment (Ent));
753 Write_Line (";");
754 end List_Object_Info;
756 ----------------------
757 -- List_Record_Info --
758 ----------------------
760 procedure List_Record_Info (Ent : Entity_Id) is
761 Comp : Entity_Id;
762 Cfbit : Uint;
763 Sunit : Uint;
765 Max_Name_Length : Natural;
766 Max_Suni_Length : Natural;
768 begin
769 Blank_Line;
770 List_Type_Info (Ent);
772 Write_Str ("for ");
773 List_Name (Ent);
774 Write_Line (" use record");
776 -- First loop finds out max line length and max starting position
777 -- length, for the purpose of lining things up nicely.
779 Max_Name_Length := 0;
780 Max_Suni_Length := 0;
782 Comp := First_Entity (Ent);
783 while Present (Comp) loop
784 if Ekind (Comp) = E_Component
785 or else Ekind (Comp) = E_Discriminant
786 then
787 Get_Decoded_Name_String (Chars (Comp));
788 Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len);
790 Cfbit := Component_Bit_Offset (Comp);
792 if Rep_Not_Constant (Cfbit) then
793 UI_Image_Length := 2;
795 else
796 -- Complete annotation in case not done
798 Set_Normalized_Position (Comp, Cfbit / SSU);
799 Set_Normalized_First_Bit (Comp, Cfbit mod SSU);
801 Sunit := Cfbit / SSU;
802 UI_Image (Sunit);
803 end if;
805 -- If the record is not packed, then we know that all fields whose
806 -- position is not specified have a starting normalized bit
807 -- position of zero
809 if Unknown_Normalized_First_Bit (Comp)
810 and then not Is_Packed (Ent)
811 then
812 Set_Normalized_First_Bit (Comp, Uint_0);
813 end if;
815 Max_Suni_Length :=
816 Natural'Max (Max_Suni_Length, UI_Image_Length);
817 end if;
819 Comp := Next_Entity (Comp);
820 end loop;
822 -- Second loop does actual output based on those values
824 Comp := First_Entity (Ent);
825 while Present (Comp) loop
826 if Ekind (Comp) = E_Component
827 or else Ekind (Comp) = E_Discriminant
828 then
829 declare
830 Esiz : constant Uint := Esize (Comp);
831 Bofs : constant Uint := Component_Bit_Offset (Comp);
832 Npos : constant Uint := Normalized_Position (Comp);
833 Fbit : constant Uint := Normalized_First_Bit (Comp);
834 Lbit : Uint;
836 begin
837 Write_Str (" ");
838 Get_Decoded_Name_String (Chars (Comp));
839 Set_Casing (Unit_Casing);
840 Write_Str (Name_Buffer (1 .. Name_Len));
842 for J in 1 .. Max_Name_Length - Name_Len loop
843 Write_Char (' ');
844 end loop;
846 Write_Str (" at ");
848 if Known_Static_Normalized_Position (Comp) then
849 UI_Image (Npos);
850 Spaces (Max_Suni_Length - UI_Image_Length);
851 Write_Str (UI_Image_Buffer (1 .. UI_Image_Length));
853 elsif Known_Component_Bit_Offset (Comp)
854 and then List_Representation_Info = 3
855 then
856 Spaces (Max_Suni_Length - 2);
857 Write_Str ("bit offset");
858 Write_Val (Bofs, Paren => True);
859 Write_Str (" size in bits = ");
860 Write_Val (Esiz, Paren => True);
861 Write_Eol;
862 goto Continue;
864 elsif Known_Normalized_Position (Comp)
865 and then List_Representation_Info = 3
866 then
867 Spaces (Max_Suni_Length - 2);
868 Write_Val (Npos);
870 else
871 -- For the packed case, we don't know the bit positions
872 -- if we don't know the starting position!
874 if Is_Packed (Ent) then
875 Write_Line ("?? range ? .. ??;");
876 goto Continue;
878 -- Otherwise we can continue
880 else
881 Write_Str ("??");
882 end if;
883 end if;
885 Write_Str (" range ");
886 UI_Write (Fbit);
887 Write_Str (" .. ");
889 -- Allowing Uint_0 here is a kludge, really this should be a
890 -- fine Esize value but currently it means unknown, except that
891 -- we know after gigi has back annotated that a size of zero is
892 -- real, since otherwise gigi back annotates using No_Uint as
893 -- the value to indicate unknown).
895 if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp))
896 and then Known_Static_Normalized_First_Bit (Comp)
897 then
898 Lbit := Fbit + Esiz - 1;
900 if Lbit < 10 then
901 Write_Char (' ');
902 end if;
904 UI_Write (Lbit);
906 -- The test for Esize (Comp) not being Uint_0 here is a kludge.
907 -- Officially a value of zero for Esize means unknown, but here
908 -- we use the fact that we know that gigi annotates Esize with
909 -- No_Uint, not Uint_0. Really everyone should use No_Uint???
911 elsif List_Representation_Info < 3
912 or else (Esize (Comp) /= Uint_0 and then Unknown_Esize (Comp))
913 then
914 Write_Str ("??");
916 else -- List_Representation >= 3 and Known_Esize (Comp)
918 Write_Val (Esiz, Paren => True);
920 -- If in front end layout mode, then dynamic size is stored
921 -- in storage units, so renormalize for output
923 if not Back_End_Layout then
924 Write_Str (" * ");
925 Write_Int (SSU);
926 end if;
928 -- Add appropriate first bit offset
930 if Fbit = 0 then
931 Write_Str (" - 1");
933 elsif Fbit = 1 then
934 null;
936 else
937 Write_Str (" + ");
938 Write_Int (UI_To_Int (Fbit) - 1);
939 end if;
940 end if;
942 Write_Line (";");
943 end;
944 end if;
946 <<Continue>>
947 Comp := Next_Entity (Comp);
948 end loop;
950 Write_Line ("end record;");
951 end List_Record_Info;
953 -------------------
954 -- List_Rep_Info --
955 -------------------
957 procedure List_Rep_Info is
958 Col : Nat;
960 begin
961 if List_Representation_Info /= 0
962 or else List_Representation_Info_Mechanisms
963 then
964 for U in Main_Unit .. Last_Unit loop
965 if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
967 -- Normal case, list to standard output
969 if not List_Representation_Info_To_File then
970 Unit_Casing := Identifier_Casing (Source_Index (U));
971 Write_Eol;
972 Write_Str ("Representation information for unit ");
973 Write_Unit_Name (Unit_Name (U));
974 Col := Column;
975 Write_Eol;
977 for J in 1 .. Col - 1 loop
978 Write_Char ('-');
979 end loop;
981 Write_Eol;
982 List_Entities (Cunit_Entity (U));
984 -- List representation information to file
986 else
987 Creat_Repinfo_File_Access.all (File_Name (Source_Index (U)));
988 Set_Special_Output (Write_Info_Line'Access);
989 List_Entities (Cunit_Entity (U));
990 Set_Special_Output (null);
991 Close_Repinfo_File_Access.all;
992 end if;
993 end if;
994 end loop;
995 end if;
996 end List_Rep_Info;
998 --------------------
999 -- List_Type_Info --
1000 --------------------
1002 procedure List_Type_Info (Ent : Entity_Id) is
1003 begin
1004 Blank_Line;
1006 -- Do not list size info for unconstrained arrays, not meaningful
1008 if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then
1009 null;
1011 else
1012 -- If Esize and RM_Size are the same and known, list as Size. This
1013 -- is a common case, which we may as well list in simple form.
1015 if Esize (Ent) = RM_Size (Ent) then
1016 Write_Str ("for ");
1017 List_Name (Ent);
1018 Write_Str ("'Size use ");
1019 Write_Val (Esize (Ent));
1020 Write_Line (";");
1022 -- For now, temporary case, to be removed when gigi properly back
1023 -- annotates RM_Size, if RM_Size is not set, then list Esize as Size.
1024 -- This avoids odd Object_Size output till we fix things???
1026 elsif Unknown_RM_Size (Ent) then
1027 Write_Str ("for ");
1028 List_Name (Ent);
1029 Write_Str ("'Size use ");
1030 Write_Val (Esize (Ent));
1031 Write_Line (";");
1033 -- Otherwise list size values separately if they are set
1035 else
1036 Write_Str ("for ");
1037 List_Name (Ent);
1038 Write_Str ("'Object_Size use ");
1039 Write_Val (Esize (Ent));
1040 Write_Line (";");
1042 -- Note on following check: The RM_Size of a discrete type can
1043 -- legitimately be set to zero, so a special check is needed.
1045 Write_Str ("for ");
1046 List_Name (Ent);
1047 Write_Str ("'Value_Size use ");
1048 Write_Val (RM_Size (Ent));
1049 Write_Line (";");
1050 end if;
1051 end if;
1053 Write_Str ("for ");
1054 List_Name (Ent);
1055 Write_Str ("'Alignment use ");
1056 Write_Val (Alignment (Ent));
1057 Write_Line (";");
1058 end List_Type_Info;
1060 ----------------------
1061 -- Rep_Not_Constant --
1062 ----------------------
1064 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is
1065 begin
1066 if Val = No_Uint or else Val < 0 then
1067 return True;
1068 else
1069 return False;
1070 end if;
1071 end Rep_Not_Constant;
1073 ---------------
1074 -- Rep_Value --
1075 ---------------
1077 function Rep_Value
1078 (Val : Node_Ref_Or_Val;
1079 D : Discrim_List) return Uint
1081 function B (Val : Boolean) return Uint;
1082 -- Returns Uint_0 for False, Uint_1 for True
1084 function T (Val : Node_Ref_Or_Val) return Boolean;
1085 -- Returns True for 0, False for any non-zero (i.e. True)
1087 function V (Val : Node_Ref_Or_Val) return Uint;
1088 -- Internal recursive routine to evaluate tree
1090 function W (Val : Uint) return Word;
1091 -- Convert Val to Word, assuming Val is always in the Int range. This is
1092 -- a helper function for the evaluation of bitwise expressions like
1093 -- Bit_And_Expr, for which there is no direct support in uintp. Uint
1094 -- values out of the Int range are expected to be seen in such
1095 -- expressions only with overflowing byte sizes around, introducing
1096 -- inherent unreliabilties in computations anyway.
1098 -------
1099 -- B --
1100 -------
1102 function B (Val : Boolean) return Uint is
1103 begin
1104 if Val then
1105 return Uint_1;
1106 else
1107 return Uint_0;
1108 end if;
1109 end B;
1111 -------
1112 -- T --
1113 -------
1115 function T (Val : Node_Ref_Or_Val) return Boolean is
1116 begin
1117 if V (Val) = 0 then
1118 return False;
1119 else
1120 return True;
1121 end if;
1122 end T;
1124 -------
1125 -- W --
1126 -------
1128 -- We use an unchecked conversion to map Int values to their Word
1129 -- bitwise equivalent, which we could not achieve with a normal type
1130 -- conversion for negative Ints. We want bitwise equivalents because W
1131 -- is used as a helper for bit operators like Bit_And_Expr, and can be
1132 -- called for negative Ints in the context of aligning expressions like
1133 -- X+Align & -Align.
1135 function W (Val : Uint) return Word is
1136 function To_Word is new Ada.Unchecked_Conversion (Int, Word);
1137 begin
1138 return To_Word (UI_To_Int (Val));
1139 end W;
1141 -------
1142 -- V --
1143 -------
1145 function V (Val : Node_Ref_Or_Val) return Uint is
1146 L, R, Q : Uint;
1148 begin
1149 if Val >= 0 then
1150 return Val;
1152 else
1153 declare
1154 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
1156 begin
1157 case Node.Expr is
1158 when Cond_Expr =>
1159 if T (Node.Op1) then
1160 return V (Node.Op2);
1161 else
1162 return V (Node.Op3);
1163 end if;
1165 when Plus_Expr =>
1166 return V (Node.Op1) + V (Node.Op2);
1168 when Minus_Expr =>
1169 return V (Node.Op1) - V (Node.Op2);
1171 when Mult_Expr =>
1172 return V (Node.Op1) * V (Node.Op2);
1174 when Trunc_Div_Expr =>
1175 return V (Node.Op1) / V (Node.Op2);
1177 when Ceil_Div_Expr =>
1178 return
1179 UR_Ceiling
1180 (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
1182 when Floor_Div_Expr =>
1183 return
1184 UR_Floor
1185 (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
1187 when Trunc_Mod_Expr =>
1188 return V (Node.Op1) rem V (Node.Op2);
1190 when Floor_Mod_Expr =>
1191 return V (Node.Op1) mod V (Node.Op2);
1193 when Ceil_Mod_Expr =>
1194 L := V (Node.Op1);
1195 R := V (Node.Op2);
1196 Q := UR_Ceiling (L / UR_From_Uint (R));
1197 return L - R * Q;
1199 when Exact_Div_Expr =>
1200 return V (Node.Op1) / V (Node.Op2);
1202 when Negate_Expr =>
1203 return -V (Node.Op1);
1205 when Min_Expr =>
1206 return UI_Min (V (Node.Op1), V (Node.Op2));
1208 when Max_Expr =>
1209 return UI_Max (V (Node.Op1), V (Node.Op2));
1211 when Abs_Expr =>
1212 return UI_Abs (V (Node.Op1));
1214 when Truth_Andif_Expr =>
1215 return B (T (Node.Op1) and then T (Node.Op2));
1217 when Truth_Orif_Expr =>
1218 return B (T (Node.Op1) or else T (Node.Op2));
1220 when Truth_And_Expr =>
1221 return B (T (Node.Op1) and T (Node.Op2));
1223 when Truth_Or_Expr =>
1224 return B (T (Node.Op1) or T (Node.Op2));
1226 when Truth_Xor_Expr =>
1227 return B (T (Node.Op1) xor T (Node.Op2));
1229 when Truth_Not_Expr =>
1230 return B (not T (Node.Op1));
1232 when Bit_And_Expr =>
1233 L := V (Node.Op1);
1234 R := V (Node.Op2);
1235 return UI_From_Int (Int (W (L) and W (R)));
1237 when Lt_Expr =>
1238 return B (V (Node.Op1) < V (Node.Op2));
1240 when Le_Expr =>
1241 return B (V (Node.Op1) <= V (Node.Op2));
1243 when Gt_Expr =>
1244 return B (V (Node.Op1) > V (Node.Op2));
1246 when Ge_Expr =>
1247 return B (V (Node.Op1) >= V (Node.Op2));
1249 when Eq_Expr =>
1250 return B (V (Node.Op1) = V (Node.Op2));
1252 when Ne_Expr =>
1253 return B (V (Node.Op1) /= V (Node.Op2));
1255 when Discrim_Val =>
1256 declare
1257 Sub : constant Int := UI_To_Int (Node.Op1);
1259 begin
1260 pragma Assert (Sub in D'Range);
1261 return D (Sub);
1262 end;
1264 end case;
1265 end;
1266 end if;
1267 end V;
1269 -- Start of processing for Rep_Value
1271 begin
1272 if Val = No_Uint then
1273 return No_Uint;
1275 else
1276 return V (Val);
1277 end if;
1278 end Rep_Value;
1280 ------------
1281 -- Spaces --
1282 ------------
1284 procedure Spaces (N : Natural) is
1285 begin
1286 for J in 1 .. N loop
1287 Write_Char (' ');
1288 end loop;
1289 end Spaces;
1291 ---------------
1292 -- Tree_Read --
1293 ---------------
1295 procedure Tree_Read is
1296 begin
1297 Rep_Table.Tree_Read;
1298 end Tree_Read;
1300 ----------------
1301 -- Tree_Write --
1302 ----------------
1304 procedure Tree_Write is
1305 begin
1306 Rep_Table.Tree_Write;
1307 end Tree_Write;
1309 ---------------------
1310 -- Write_Info_Line --
1311 ---------------------
1313 procedure Write_Info_Line (S : String) is
1314 begin
1315 Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1));
1316 end Write_Info_Line;
1318 ---------------------
1319 -- Write_Mechanism --
1320 ---------------------
1322 procedure Write_Mechanism (M : Mechanism_Type) is
1323 begin
1324 case M is
1325 when 0 =>
1326 Write_Str ("default");
1328 when -1 =>
1329 Write_Str ("copy");
1331 when -2 =>
1332 Write_Str ("reference");
1334 when -3 =>
1335 Write_Str ("descriptor");
1337 when -4 =>
1338 Write_Str ("descriptor (UBS)");
1340 when -5 =>
1341 Write_Str ("descriptor (UBSB)");
1343 when -6 =>
1344 Write_Str ("descriptor (UBA)");
1346 when -7 =>
1347 Write_Str ("descriptor (S)");
1349 when -8 =>
1350 Write_Str ("descriptor (SB)");
1352 when -9 =>
1353 Write_Str ("descriptor (A)");
1355 when -10 =>
1356 Write_Str ("descriptor (NCA)");
1358 when others =>
1359 raise Program_Error;
1360 end case;
1361 end Write_Mechanism;
1363 ---------------
1364 -- Write_Val --
1365 ---------------
1367 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is
1368 begin
1369 if Rep_Not_Constant (Val) then
1370 if List_Representation_Info < 3 or else Val = No_Uint then
1371 Write_Str ("??");
1373 else
1374 if Back_End_Layout then
1375 Write_Char (' ');
1377 if Paren then
1378 Write_Char ('(');
1379 List_GCC_Expression (Val);
1380 Write_Char (')');
1381 else
1382 List_GCC_Expression (Val);
1383 end if;
1385 Write_Char (' ');
1387 else
1388 if Paren then
1389 Write_Char ('(');
1390 Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
1391 Write_Char (')');
1392 else
1393 Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
1394 end if;
1395 end if;
1396 end if;
1398 else
1399 UI_Write (Val);
1400 end if;
1401 end Write_Val;
1403 end Repinfo;