?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* dwarf2out.c (loc_descriptor_from_tree, case CONSTRUCTOR): New case.
[official-gcc.git] / gcc / ada / repinfo.adb
blobf7315dbf242e866b21dc54157123690395ac387d
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-2002 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 ------------------------------------------------------------------------------
33
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 Table; use Table;
46 with Uname; use Uname;
47 with Urealp; use Urealp;
48
49 package body Repinfo is
50
51 SSU : constant := 8;
52 -- Value for Storage_Unit, we do not want to get this from TTypes, since
53 -- this introduces problematic dependencies in ASIS, and in any case this
54 -- value is assumed to be 8 for the implementation of the DDA.
55 -- This is wrong for AAMP???
56
57 ---------------------------------------
58 -- Representation of gcc Expressions --
59 ---------------------------------------
60
61 -- This table is used only if Frontend_Layout_On_Target is False,
62 -- so that gigi lays out dynamic size/offset fields using encoded
63 -- gcc expressions.
64
65 -- A table internal to this unit is used to hold the values of
66 -- back annotated expressions. This table is written out by -gnatt
67 -- and read back in for ASIS processing.
68
69 -- Node values are stored as Uint values which are the negative of
70 -- the node index in this table. Constants appear as non-negative
71 -- Uint values.
72
73 type Exp_Node is record
74 Expr : TCode;
75 Op1 : Node_Ref_Or_Val;
76 Op2 : Node_Ref_Or_Val;
77 Op3 : Node_Ref_Or_Val;
78 end record;
79
80 package Rep_Table is new Table.Table (
81 Table_Component_Type => Exp_Node,
82 Table_Index_Type => Nat,
83 Table_Low_Bound => 1,
84 Table_Initial => Alloc.Rep_Table_Initial,
85 Table_Increment => Alloc.Rep_Table_Increment,
86 Table_Name => "BE_Rep_Table");
87
88 --------------------------------------------------------------
89 -- Representation of Front-End Dynamic Size/Offset Entities --
90 --------------------------------------------------------------
91
92 package Dynamic_SO_Entity_Table is new Table.Table (
93 Table_Component_Type => Entity_Id,
94 Table_Index_Type => Nat,
95 Table_Low_Bound => 1,
96 Table_Initial => Alloc.Rep_Table_Initial,
97 Table_Increment => Alloc.Rep_Table_Increment,
98 Table_Name => "FE_Rep_Table");
99
100 -----------------------
101 -- Local Subprograms --
102 -----------------------
103
104 Unit_Casing : Casing_Type;
105 -- Identifier casing for current unit
106
107 procedure Spaces (N : Natural);
108 -- Output given number of spaces
109
110 function Back_End_Layout return Boolean;
111 -- Test for layout mode, True = back end, False = front end. This
112 -- function is used rather than checking the configuration parameter
113 -- because we do not want Repinfo to depend on Targparm (for ASIS)
114
115 procedure List_Entities (Ent : Entity_Id);
116 -- This procedure lists the entities associated with the entity E,
117 -- starting with the First_Entity and using the Next_Entity link.
118 -- If a nested package is found, entities within the package are
119 -- recursively processed.
120
121 procedure List_Name (Ent : Entity_Id);
122 -- List name of entity Ent in appropriate case. The name is listed with
123 -- full qualification up to but not including the compilation unit name.
124
125 procedure List_Array_Info (Ent : Entity_Id);
126 -- List representation info for array type Ent
127
128 procedure List_Object_Info (Ent : Entity_Id);
129 -- List representation info for object Ent
130
131 procedure List_Record_Info (Ent : Entity_Id);
132 -- List representation info for record type Ent
133
134 procedure List_Type_Info (Ent : Entity_Id);
135 -- List type info for type Ent
136
137 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean;
138 -- Returns True if Val represents a variable value, and False if it
139 -- represents a value that is fixed at compile time.
140
141 procedure Write_Info_Line (S : String);
142 -- Routine to write a line to Repinfo output file. This routine is
143 -- passed as a special output procedure to Output.Set_Special_Output.
144 -- Note that Write_Info_Line is called with an EOL character at the
145 -- end of each line, as per the Output spec, but the internal call
146 -- to the appropriate routine in Osint requires that the end of line
147 -- sequence be stripped off.
148
149 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
150 -- Given a representation value, write it out. No_Uint values or values
151 -- dependent on discriminants are written as two question marks. If the
152 -- flag Paren is set, then the output is surrounded in parentheses if
153 -- it is other than a simple value.
154
155 ---------------------
156 -- Back_End_Layout --
157 ---------------------
158
159 function Back_End_Layout return Boolean is
160 begin
161 -- We have back end layout if the back end has made any entries in
162 -- the table of GCC expressions, otherwise we have front end layout.
163
164 return Rep_Table.Last > 0;
165 end Back_End_Layout;
166
167 ------------------------
168 -- Create_Discrim_Ref --
169 ------------------------
170
171 function Create_Discrim_Ref
172 (Discr : Entity_Id)
173 return Node_Ref
174 is
175 N : constant Uint := Discriminant_Number (Discr);
176 T : Nat;
177
178 begin
179 Rep_Table.Increment_Last;
180 T := Rep_Table.Last;
181 Rep_Table.Table (T).Expr := Discrim_Val;
182 Rep_Table.Table (T).Op1 := N;
183 Rep_Table.Table (T).Op2 := No_Uint;
184 Rep_Table.Table (T).Op3 := No_Uint;
185 return UI_From_Int (-T);
186 end Create_Discrim_Ref;
187
188 ---------------------------
189 -- Create_Dynamic_SO_Ref --
190 ---------------------------
191
192 function Create_Dynamic_SO_Ref
193 (E : Entity_Id)
194 return Dynamic_SO_Ref
195 is
196 T : Nat;
197
198 begin
199 Dynamic_SO_Entity_Table.Increment_Last;
200 T := Dynamic_SO_Entity_Table.Last;
201 Dynamic_SO_Entity_Table.Table (T) := E;
202 return UI_From_Int (-T);
203 end Create_Dynamic_SO_Ref;
204
205 -----------------
206 -- Create_Node --
207 -----------------
208
209 function Create_Node
210 (Expr : TCode;
211 Op1 : Node_Ref_Or_Val;
212 Op2 : Node_Ref_Or_Val := No_Uint;
213 Op3 : Node_Ref_Or_Val := No_Uint)
214 return Node_Ref
215 is
216 T : Nat;
217
218 begin
219 Rep_Table.Increment_Last;
220 T := Rep_Table.Last;
221 Rep_Table.Table (T).Expr := Expr;
222 Rep_Table.Table (T).Op1 := Op1;
223 Rep_Table.Table (T).Op2 := Op2;
224 Rep_Table.Table (T).Op3 := Op3;
225
226 return UI_From_Int (-T);
227 end Create_Node;
228
229 ---------------------------
230 -- Get_Dynamic_SO_Entity --
231 ---------------------------
232
233 function Get_Dynamic_SO_Entity
234 (U : Dynamic_SO_Ref)
235 return Entity_Id
236 is
237 begin
238 return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U));
239 end Get_Dynamic_SO_Entity;
240
241 -----------------------
242 -- Is_Dynamic_SO_Ref --
243 -----------------------
244
245 function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is
246 begin
247 return U < Uint_0;
248 end Is_Dynamic_SO_Ref;
249
250 ----------------------
251 -- Is_Static_SO_Ref --
252 ----------------------
253
254 function Is_Static_SO_Ref (U : SO_Ref) return Boolean is
255 begin
256 return U >= Uint_0;
257 end Is_Static_SO_Ref;
258
259 ---------
260 -- lgx --
261 ---------
262
263 procedure lgx (U : Node_Ref_Or_Val) is
264 begin
265 List_GCC_Expression (U);
266 Write_Eol;
267 end lgx;
268
269 ----------------------
270 -- List_Array_Info --
271 ----------------------
272
273 procedure List_Array_Info (Ent : Entity_Id) is
274 begin
275 List_Type_Info (Ent);
276
277 Write_Str ("for ");
278 List_Name (Ent);
279 Write_Str ("'Component_Size use ");
280 Write_Val (Component_Size (Ent));
281 Write_Line (";");
282 end List_Array_Info;
283
284 -------------------
285 -- List_Entities --
286 -------------------
287
288 procedure List_Entities (Ent : Entity_Id) is
289 E : Entity_Id;
290
291 begin
292 if Present (Ent) then
293 E := First_Entity (Ent);
294 while Present (E) loop
295
296 -- We list entities that come from source (excluding private
297 -- types, where we will list the info for the full view). If
298 -- debug flag A is set, all entities are listed
299
300 if (Comes_From_Source (E) and then not Is_Private_Type (E))
301 or else Debug_Flag_AA
302 then
303 if Is_Record_Type (E) then
304 List_Record_Info (E);
305
306 elsif Is_Array_Type (E) then
307 List_Array_Info (E);
308
309 elsif List_Representation_Info >= 2 then
310 if Is_Type (E) then
311 List_Type_Info (E);
312
313 elsif Ekind (E) = E_Variable
314 or else
315 Ekind (E) = E_Constant
316 or else
317 Ekind (E) = E_Loop_Parameter
318 or else
319 Is_Formal (E)
320 then
321 List_Object_Info (E);
322 end if;
323 end if;
324
325 -- Recurse into nested package, but not if they are
326 -- package renamings (in particular renamings of the
327 -- enclosing package, as for some Java bindings and
328 -- for generic instances).
329
330 if Ekind (E) = E_Package then
331 if No (Renamed_Object (E)) then
332 List_Entities (E);
333 end if;
334
335 -- Recurse into bodies
336
337 elsif Ekind (E) = E_Protected_Type
338 or else
339 Ekind (E) = E_Task_Type
340 or else
341 Ekind (E) = E_Subprogram_Body
342 or else
343 Ekind (E) = E_Package_Body
344 or else
345 Ekind (E) = E_Task_Body
346 or else
347 Ekind (E) = E_Protected_Body
348 then
349 List_Entities (E);
350
351 -- Recurse into blocks
352
353 elsif Ekind (E) = E_Block then
354 List_Entities (E);
355 end if;
356 end if;
357
358 E := Next_Entity (E);
359 end loop;
360 end if;
361 end List_Entities;
362
363 -------------------------
364 -- List_GCC_Expression --
365 -------------------------
366
367 procedure List_GCC_Expression (U : Node_Ref_Or_Val) is
368
369 procedure P (Val : Node_Ref_Or_Val);
370 -- Internal recursive procedure to print expression
371
372 procedure P (Val : Node_Ref_Or_Val) is
373 begin
374 if Val >= 0 then
375 UI_Write (Val, Decimal);
376
377 else
378 declare
379 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
380
381 procedure Binop (S : String);
382 -- Output text for binary operator with S being operator name
383
384 procedure Binop (S : String) is
385 begin
386 Write_Char ('(');
387 P (Node.Op1);
388 Write_Str (S);
389 P (Node.Op2);
390 Write_Char (')');
391 end Binop;
392
393 -- Start of processing for P
394
395 begin
396 case Node.Expr is
397 when Cond_Expr =>
398 Write_Str ("(if ");
399 P (Node.Op1);
400 Write_Str (" then ");
401 P (Node.Op2);
402 Write_Str (" else ");
403 P (Node.Op3);
404 Write_Str (" end)");
405
406 when Plus_Expr =>
407 Binop (" + ");
408
409 when Minus_Expr =>
410 Binop (" - ");
411
412 when Mult_Expr =>
413 Binop (" * ");
414
415 when Trunc_Div_Expr =>
416 Binop (" /t ");
417
418 when Ceil_Div_Expr =>
419 Binop (" /c ");
420
421 when Floor_Div_Expr =>
422 Binop (" /f ");
423
424 when Trunc_Mod_Expr =>
425 Binop (" modt ");
426
427 when Floor_Mod_Expr =>
428 Binop (" modf ");
429
430 when Ceil_Mod_Expr =>
431 Binop (" modc ");
432
433 when Exact_Div_Expr =>
434 Binop (" /e ");
435
436 when Negate_Expr =>
437 Write_Char ('-');
438 P (Node.Op1);
439
440 when Min_Expr =>
441 Binop (" min ");
442
443 when Max_Expr =>
444 Binop (" max ");
445
446 when Abs_Expr =>
447 Write_Str ("abs ");
448 P (Node.Op1);
449
450 when Truth_Andif_Expr =>
451 Binop (" and if ");
452
453 when Truth_Orif_Expr =>
454 Binop (" or if ");
455
456 when Truth_And_Expr =>
457 Binop (" and ");
458
459 when Truth_Or_Expr =>
460 Binop (" or ");
461
462 when Truth_Xor_Expr =>
463 Binop (" xor ");
464
465 when Truth_Not_Expr =>
466 Write_Str ("not ");
467 P (Node.Op1);
468
469 when Lt_Expr =>
470 Binop (" < ");
471
472 when Le_Expr =>
473 Binop (" <= ");
474
475 when Gt_Expr =>
476 Binop (" > ");
477
478 when Ge_Expr =>
479 Binop (" >= ");
480
481 when Eq_Expr =>
482 Binop (" == ");
483
484 when Ne_Expr =>
485 Binop (" != ");
486
487 when Discrim_Val =>
488 Write_Char ('#');
489 UI_Write (Node.Op1);
490
491 end case;
492 end;
493 end if;
494 end P;
495
496 -- Start of processing for List_GCC_Expression
497
498 begin
499 if U = No_Uint then
500 Write_Str ("??");
501 else
502 P (U);
503 end if;
504 end List_GCC_Expression;
505
506 ---------------
507 -- List_Name --
508 ---------------
509
510 procedure List_Name (Ent : Entity_Id) is
511 begin
512 if not Is_Compilation_Unit (Scope (Ent)) then
513 List_Name (Scope (Ent));
514 Write_Char ('.');
515 end if;
516
517 Get_Unqualified_Decoded_Name_String (Chars (Ent));
518 Set_Casing (Unit_Casing);
519 Write_Str (Name_Buffer (1 .. Name_Len));
520 end List_Name;
521
522 ---------------------
523 -- List_Object_Info --
524 ---------------------
525
526 procedure List_Object_Info (Ent : Entity_Id) is
527 begin
528 Write_Eol;
529
530 Write_Str ("for ");
531 List_Name (Ent);
532 Write_Str ("'Size use ");
533 Write_Val (Esize (Ent));
534 Write_Line (";");
535
536 Write_Str ("for ");
537 List_Name (Ent);
538 Write_Str ("'Alignment use ");
539 Write_Val (Alignment (Ent));
540 Write_Line (";");
541 end List_Object_Info;
542
543 ----------------------
544 -- List_Record_Info --
545 ----------------------
546
547 procedure List_Record_Info (Ent : Entity_Id) is
548 Comp : Entity_Id;
549 Esiz : Uint;
550 Cfbit : Uint;
551 Sunit : Uint;
552
553 Max_Name_Length : Natural;
554 Max_Suni_Length : Natural;
555
556 begin
557 List_Type_Info (Ent);
558
559 Write_Str ("for ");
560 List_Name (Ent);
561 Write_Line (" use record");
562
563 -- First loop finds out max line length and max starting position
564 -- length, for the purpose of lining things up nicely.
565
566 Max_Name_Length := 0;
567 Max_Suni_Length := 0;
568
569 Comp := First_Entity (Ent);
570 while Present (Comp) loop
571 if Ekind (Comp) = E_Component
572 or else Ekind (Comp) = E_Discriminant
573 then
574 Get_Decoded_Name_String (Chars (Comp));
575 Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len);
576
577 Cfbit := Component_Bit_Offset (Comp);
578
579 if Rep_Not_Constant (Cfbit) then
580 UI_Image_Length := 2;
581
582 else
583 -- Complete annotation in case not done
584
585 Set_Normalized_Position (Comp, Cfbit / SSU);
586 Set_Normalized_First_Bit (Comp, Cfbit mod SSU);
587
588 Esiz := Esize (Comp);
589 Sunit := Cfbit / SSU;
590 UI_Image (Sunit);
591 end if;
592
593 -- If the record is not packed, then we know that all
594 -- fields whose position is not specified have a starting
595 -- normalized bit position of zero
596
597 if Unknown_Normalized_First_Bit (Comp)
598 and then not Is_Packed (Ent)
599 then
600 Set_Normalized_First_Bit (Comp, Uint_0);
601 end if;
602
603 Max_Suni_Length :=
604 Natural'Max (Max_Suni_Length, UI_Image_Length);
605 end if;
606
607 Comp := Next_Entity (Comp);
608 end loop;
609
610 -- Second loop does actual output based on those values
611
612 Comp := First_Entity (Ent);
613 while Present (Comp) loop
614 if Ekind (Comp) = E_Component
615 or else Ekind (Comp) = E_Discriminant
616 then
617 declare
618 Esiz : constant Uint := Esize (Comp);
619 Bofs : constant Uint := Component_Bit_Offset (Comp);
620 Npos : constant Uint := Normalized_Position (Comp);
621 Fbit : constant Uint := Normalized_First_Bit (Comp);
622 Lbit : Uint;
623
624 begin
625 Write_Str (" ");
626 Get_Decoded_Name_String (Chars (Comp));
627 Set_Casing (Unit_Casing);
628 Write_Str (Name_Buffer (1 .. Name_Len));
629
630 for J in 1 .. Max_Name_Length - Name_Len loop
631 Write_Char (' ');
632 end loop;
633
634 Write_Str (" at ");
635
636 if Known_Static_Normalized_Position (Comp) then
637 UI_Image (Npos);
638 Spaces (Max_Suni_Length - UI_Image_Length);
639 Write_Str (UI_Image_Buffer (1 .. UI_Image_Length));
640
641 elsif Known_Component_Bit_Offset (Comp)
642 and then List_Representation_Info = 3
643 then
644 Spaces (Max_Suni_Length - 2);
645 Write_Str ("bit offset");
646 Write_Val (Bofs, Paren => True);
647 Write_Str (" size in bits = ");
648 Write_Val (Esiz, Paren => True);
649 Write_Eol;
650 goto Continue;
651
652 elsif Known_Normalized_Position (Comp)
653 and then List_Representation_Info = 3
654 then
655 Spaces (Max_Suni_Length - 2);
656 Write_Val (Npos);
657
658 else
659 -- For the packed case, we don't know the bit positions
660 -- if we don't know the starting position!
661
662 if Is_Packed (Ent) then
663 Write_Line ("?? range ? .. ??;");
664 goto Continue;
665
666 -- Otherwise we can continue
667
668 else
669 Write_Str ("??");
670 end if;
671 end if;
672
673 Write_Str (" range ");
674 UI_Write (Fbit);
675 Write_Str (" .. ");
676
677 -- Allowing Uint_0 here is a kludge, really this should be
678 -- a fine Esize value but currently it means unknown, except
679 -- that we know after gigi has back annotated that a size of
680 -- zero is real, since otherwise gigi back annotates using
681 -- No_Uint as the value to indicate unknown).
682
683 if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp))
684 and then Known_Static_Normalized_First_Bit (Comp)
685 then
686 Lbit := Fbit + Esiz - 1;
687
688 if Lbit < 10 then
689 Write_Char (' ');
690 end if;
691
692 UI_Write (Lbit);
693
694 -- The test for Esize (Comp) not being Uint_0 here is a kludge.
695 -- Officially a value of zero for Esize means unknown, but here
696 -- we use the fact that we know that gigi annotates Esize with
697 -- No_Uint, not Uint_0. Really everyone should use No_Uint???
698
699 elsif List_Representation_Info < 3
700 or else (Esize (Comp) /= Uint_0 and then Unknown_Esize (Comp))
701 then
702 Write_Str ("??");
703
704 else -- List_Representation >= 3 and Known_Esize (Comp)
705
706 Write_Val (Esiz, Paren => True);
707
708 -- If in front end layout mode, then dynamic size is
709 -- stored in storage units, so renormalize for output
710
711 if not Back_End_Layout then
712 Write_Str (" * ");
713 Write_Int (SSU);
714 end if;
715
716 -- Add appropriate first bit offset
717
718 if Fbit = 0 then
719 Write_Str (" - 1");
720
721 elsif Fbit = 1 then
722 null;
723
724 else
725 Write_Str (" + ");
726 Write_Int (UI_To_Int (Fbit) - 1);
727 end if;
728 end if;
729
730 Write_Line (";");
731 end;
732 end if;
733
734 <<Continue>>
735 Comp := Next_Entity (Comp);
736 end loop;
737
738 Write_Line ("end record;");
739 end List_Record_Info;
740
741 -------------------
742 -- List_Rep_Info --
743 -------------------
744
745 procedure List_Rep_Info is
746 Col : Nat;
747
748 begin
749 for U in Main_Unit .. Last_Unit loop
750 if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
751
752 -- Normal case, list to standard output
753
754 if not List_Representation_Info_To_File then
755 Unit_Casing := Identifier_Casing (Source_Index (U));
756 Write_Eol;
757 Write_Str ("Representation information for unit ");
758 Write_Unit_Name (Unit_Name (U));
759 Col := Column;
760 Write_Eol;
761
762 for J in 1 .. Col - 1 loop
763 Write_Char ('-');
764 end loop;
765
766 Write_Eol;
767 List_Entities (Cunit_Entity (U));
768
769 -- List representation information to file
770
771 else
772 Creat_Repinfo_File_Access.all (File_Name (Source_Index (U)));
773 Set_Special_Output (Write_Info_Line'Access);
774 List_Entities (Cunit_Entity (U));
775 Set_Special_Output (null);
776 Close_Repinfo_File_Access.all;
777 end if;
778 end if;
779 end loop;
780 end List_Rep_Info;
781
782 ---------------------
783 -- Write_Info_Line --
784 ---------------------
785
786 procedure Write_Info_Line (S : String) is
787 begin
788 Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1));
789 end Write_Info_Line;
790
791 --------------------
792 -- List_Type_Info --
793 --------------------
794
795 procedure List_Type_Info (Ent : Entity_Id) is
796 begin
797 Write_Eol;
798
799 -- Do not list size info for unconstrained arrays, not meaningful
800
801 if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then
802 null;
803
804 else
805 -- If Esize and RM_Size are the same and known, list as Size. This
806 -- is a common case, which we may as well list in simple form.
807
808 if Esize (Ent) = RM_Size (Ent) then
809 Write_Str ("for ");
810 List_Name (Ent);
811 Write_Str ("'Size use ");
812 Write_Val (Esize (Ent));
813 Write_Line (";");
814
815 -- For now, temporary case, to be removed when gigi properly back
816 -- annotates RM_Size, if RM_Size is not set, then list Esize as
817 -- Size. This avoids odd Object_Size output till we fix things???
818
819 elsif Unknown_RM_Size (Ent) then
820 Write_Str ("for ");
821 List_Name (Ent);
822 Write_Str ("'Size use ");
823 Write_Val (Esize (Ent));
824 Write_Line (";");
825
826 -- Otherwise list size values separately if they are set
827
828 else
829 Write_Str ("for ");
830 List_Name (Ent);
831 Write_Str ("'Object_Size use ");
832 Write_Val (Esize (Ent));
833 Write_Line (";");
834
835 -- Note on following check: The RM_Size of a discrete type can
836 -- legitimately be set to zero, so a special check is needed.
837
838 Write_Str ("for ");
839 List_Name (Ent);
840 Write_Str ("'Value_Size use ");
841 Write_Val (RM_Size (Ent));
842 Write_Line (";");
843 end if;
844 end if;
845
846 Write_Str ("for ");
847 List_Name (Ent);
848 Write_Str ("'Alignment use ");
849 Write_Val (Alignment (Ent));
850 Write_Line (";");
851 end List_Type_Info;
852
853 ----------------------
854 -- Rep_Not_Constant --
855 ----------------------
856
857 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is
858 begin
859 if Val = No_Uint or else Val < 0 then
860 return True;
861 else
862 return False;
863 end if;
864 end Rep_Not_Constant;
865
866 ---------------
867 -- Rep_Value --
868 ---------------
869
870 function Rep_Value
871 (Val : Node_Ref_Or_Val;
872 D : Discrim_List)
873 return Uint
874 is
875 function B (Val : Boolean) return Uint;
876 -- Returns Uint_0 for False, Uint_1 for True
877
878 function T (Val : Node_Ref_Or_Val) return Boolean;
879 -- Returns True for 0, False for any non-zero (i.e. True)
880
881 function V (Val : Node_Ref_Or_Val) return Uint;
882 -- Internal recursive routine to evaluate tree
883
884 -------
885 -- B --
886 -------
887
888 function B (Val : Boolean) return Uint is
889 begin
890 if Val then
891 return Uint_1;
892 else
893 return Uint_0;
894 end if;
895 end B;
896
897 -------
898 -- T --
899 -------
900
901 function T (Val : Node_Ref_Or_Val) return Boolean is
902 begin
903 if V (Val) = 0 then
904 return False;
905 else
906 return True;
907 end if;
908 end T;
909
910 -------
911 -- V --
912 -------
913
914 function V (Val : Node_Ref_Or_Val) return Uint is
915 L, R, Q : Uint;
916
917 begin
918 if Val >= 0 then
919 return Val;
920
921 else
922 declare
923 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
924
925 begin
926 case Node.Expr is
927 when Cond_Expr =>
928 if T (Node.Op1) then
929 return V (Node.Op2);
930 else
931 return V (Node.Op3);
932 end if;
933
934 when Plus_Expr =>
935 return V (Node.Op1) + V (Node.Op2);
936
937 when Minus_Expr =>
938 return V (Node.Op1) - V (Node.Op2);
939
940 when Mult_Expr =>
941 return V (Node.Op1) * V (Node.Op2);
942
943 when Trunc_Div_Expr =>
944 return V (Node.Op1) / V (Node.Op2);
945
946 when Ceil_Div_Expr =>
947 return
948 UR_Ceiling
949 (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
950
951 when Floor_Div_Expr =>
952 return
953 UR_Floor
954 (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
955
956 when Trunc_Mod_Expr =>
957 return V (Node.Op1) rem V (Node.Op2);
958
959 when Floor_Mod_Expr =>
960 return V (Node.Op1) mod V (Node.Op2);
961
962 when Ceil_Mod_Expr =>
963 L := V (Node.Op1);
964 R := V (Node.Op2);
965 Q := UR_Ceiling (L / UR_From_Uint (R));
966 return L - R * Q;
967
968 when Exact_Div_Expr =>
969 return V (Node.Op1) / V (Node.Op2);
970
971 when Negate_Expr =>
972 return -V (Node.Op1);
973
974 when Min_Expr =>
975 return UI_Min (V (Node.Op1), V (Node.Op2));
976
977 when Max_Expr =>
978 return UI_Max (V (Node.Op1), V (Node.Op2));
979
980 when Abs_Expr =>
981 return UI_Abs (V (Node.Op1));
982
983 when Truth_Andif_Expr =>
984 return B (T (Node.Op1) and then T (Node.Op2));
985
986 when Truth_Orif_Expr =>
987 return B (T (Node.Op1) or else T (Node.Op2));
988
989 when Truth_And_Expr =>
990 return B (T (Node.Op1) and T (Node.Op2));
991
992 when Truth_Or_Expr =>
993 return B (T (Node.Op1) or T (Node.Op2));
994
995 when Truth_Xor_Expr =>
996 return B (T (Node.Op1) xor T (Node.Op2));
997
998 when Truth_Not_Expr =>
999 return B (not T (Node.Op1));
1000
1001 when Lt_Expr =>
1002 return B (V (Node.Op1) < V (Node.Op2));
1003
1004 when Le_Expr =>
1005 return B (V (Node.Op1) <= V (Node.Op2));
1006
1007 when Gt_Expr =>
1008 return B (V (Node.Op1) > V (Node.Op2));
1009
1010 when Ge_Expr =>
1011 return B (V (Node.Op1) >= V (Node.Op2));
1012
1013 when Eq_Expr =>
1014 return B (V (Node.Op1) = V (Node.Op2));
1015
1016 when Ne_Expr =>
1017 return B (V (Node.Op1) /= V (Node.Op2));
1018
1019 when Discrim_Val =>
1020 declare
1021 Sub : constant Int := UI_To_Int (Node.Op1);
1022
1023 begin
1024 pragma Assert (Sub in D'Range);
1025 return D (Sub);
1026 end;
1027
1028 end case;
1029 end;
1030 end if;
1031 end V;
1032
1033 -- Start of processing for Rep_Value
1034
1035 begin
1036 if Val = No_Uint then
1037 return No_Uint;
1038
1039 else
1040 return V (Val);
1041 end if;
1042 end Rep_Value;
1043
1044 ------------
1045 -- Spaces --
1046 ------------
1047
1048 procedure Spaces (N : Natural) is
1049 begin
1050 for J in 1 .. N loop
1051 Write_Char (' ');
1052 end loop;
1053 end Spaces;
1054
1055 ---------------
1056 -- Tree_Read --
1057 ---------------
1058
1059 procedure Tree_Read is
1060 begin
1061 Rep_Table.Tree_Read;
1062 end Tree_Read;
1063
1064 ----------------
1065 -- Tree_Write --
1066 ----------------
1067
1068 procedure Tree_Write is
1069 begin
1070 Rep_Table.Tree_Write;
1071 end Tree_Write;
1072
1073 ---------------
1074 -- Write_Val --
1075 ---------------
1076
1077 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is
1078 begin
1079 if Rep_Not_Constant (Val) then
1080 if List_Representation_Info < 3 or else Val = No_Uint then
1081 Write_Str ("??");
1082
1083 else
1084 if Back_End_Layout then
1085 Write_Char (' ');
1086
1087 if Paren then
1088 Write_Char ('(');
1089 List_GCC_Expression (Val);
1090 Write_Char (')');
1091 else
1092 List_GCC_Expression (Val);
1093 end if;
1094
1095 Write_Char (' ');
1096
1097 else
1098 if Paren then
1099 Write_Char ('(');
1100 Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
1101 Write_Char (')');
1102 else
1103 Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
1104 end if;
1105 end if;
1106 end if;
1107
1108 else
1109 UI_Write (Val);
1110 end if;
1111 end Write_Val;
1112
1113 end Repinfo;
Mirror of the offical gcc git repository hosted at gcc.gnu.org