OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [repinfo.adb] - Blame information for rev 290

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
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-2009, 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 Opt;    use Opt;
40
with Output; use Output;
41
with Sinfo;  use Sinfo;
42
with Sinput; use Sinput;
43
with Snames; use Snames;
44
with Stand;  use Stand;
45
with Table;  use Table;
46
with Uname;  use Uname;
47
with Urealp; use Urealp;
48
 
49
with Ada.Unchecked_Conversion;
50
 
51
package body Repinfo is
52
 
53
   SSU : constant := 8;
54
   --  Value for Storage_Unit, we do not want to get this from TTypes, since
55
   --  this introduces problematic dependencies in ASIS, and in any case this
56
   --  value is assumed to be 8 for the implementation of the DDA.
57
 
58
   --  This is wrong for AAMP???
59
 
60
   ---------------------------------------
61
   -- Representation of gcc Expressions --
62
   ---------------------------------------
63
 
64
   --    This table is used only if Frontend_Layout_On_Target is False, so gigi
65
   --    lays out dynamic size/offset fields using encoded gcc expressions.
66
 
67
   --    A table internal to this unit is used to hold the values of back
68
   --    annotated expressions. This table is written out by -gnatt and read
69
   --    back in for ASIS processing.
70
 
71
   --    Node values are stored as Uint values using the negative of the node
72
   --    index in this table. Constants appear as non-negative Uint values.
73
 
74
   type Exp_Node is record
75
      Expr : TCode;
76
      Op1  : Node_Ref_Or_Val;
77
      Op2  : Node_Ref_Or_Val;
78
      Op3  : Node_Ref_Or_Val;
79
   end record;
80
 
81
   --  The following representation clause ensures that the above record
82
   --  has no holes. We do this so that when instances of this record are
83
   --  written by Tree_Gen, we do not write uninitialized values to the file.
84
 
85
   for Exp_Node use record
86
      Expr at  0 range 0 .. 31;
87
      Op1  at  4 range 0 .. 31;
88
      Op2  at  8 range 0 .. 31;
89
      Op3  at 12 range 0 .. 31;
90
   end record;
91
 
92
   for Exp_Node'Size use 16 * 8;
93
   --  This ensures that we did not leave out any fields
94
 
95
   package Rep_Table is new Table.Table (
96
      Table_Component_Type => Exp_Node,
97
      Table_Index_Type     => Nat,
98
      Table_Low_Bound      => 1,
99
      Table_Initial        => Alloc.Rep_Table_Initial,
100
      Table_Increment      => Alloc.Rep_Table_Increment,
101
      Table_Name           => "BE_Rep_Table");
102
 
103
   --------------------------------------------------------------
104
   -- Representation of Front-End Dynamic Size/Offset Entities --
105
   --------------------------------------------------------------
106
 
107
   package Dynamic_SO_Entity_Table is new Table.Table (
108
      Table_Component_Type => Entity_Id,
109
      Table_Index_Type     => Nat,
110
      Table_Low_Bound      => 1,
111
      Table_Initial        => Alloc.Rep_Table_Initial,
112
      Table_Increment      => Alloc.Rep_Table_Increment,
113
      Table_Name           => "FE_Rep_Table");
114
 
115
   Unit_Casing : Casing_Type;
116
   --  Identifier casing for current unit
117
 
118
   Need_Blank_Line : Boolean;
119
   --  Set True if a blank line is needed before outputting any information for
120
   --  the current entity. Set True when a new entity is processed, and false
121
   --  when the blank line is output.
122
 
123
   -----------------------
124
   -- Local Subprograms --
125
   -----------------------
126
 
127
   function Back_End_Layout return Boolean;
128
   --  Test for layout mode, True = back end, False = front end. This function
129
   --  is used rather than checking the configuration parameter because we do
130
   --  not want Repinfo to depend on Targparm (for ASIS)
131
 
132
   procedure Blank_Line;
133
   --  Called before outputting anything for an entity. Ensures that
134
   --  a blank line precedes the output for a particular entity.
135
 
136
   procedure List_Entities (Ent : Entity_Id);
137
   --  This procedure lists the entities associated with the entity E, starting
138
   --  with the First_Entity and using the Next_Entity link. If a nested
139
   --  package is found, entities within the package are recursively processed.
140
 
141
   procedure List_Name (Ent : Entity_Id);
142
   --  List name of entity Ent in appropriate case. The name is listed with
143
   --  full qualification up to but not including the compilation unit name.
144
 
145
   procedure List_Array_Info (Ent : Entity_Id);
146
   --  List representation info for array type Ent
147
 
148
   procedure List_Mechanisms (Ent : Entity_Id);
149
   --  List mechanism information for parameters of Ent, which is subprogram,
150
   --  subprogram type, or an entry or entry family.
151
 
152
   procedure List_Object_Info (Ent : Entity_Id);
153
   --  List representation info for object Ent
154
 
155
   procedure List_Record_Info (Ent : Entity_Id);
156
   --  List representation info for record type Ent
157
 
158
   procedure List_Type_Info (Ent : Entity_Id);
159
   --  List type info for type Ent
160
 
161
   function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean;
162
   --  Returns True if Val represents a variable value, and False if it
163
   --  represents a value that is fixed at compile time.
164
 
165
   procedure Spaces (N : Natural);
166
   --  Output given number of spaces
167
 
168
   procedure Write_Info_Line (S : String);
169
   --  Routine to write a line to Repinfo output file. This routine is passed
170
   --  as a special output procedure to Output.Set_Special_Output. Note that
171
   --  Write_Info_Line is called with an EOL character at the end of each line,
172
   --  as per the Output spec, but the internal call to the appropriate routine
173
   --  in Osint requires that the end of line sequence be stripped off.
174
 
175
   procedure Write_Mechanism (M : Mechanism_Type);
176
   --  Writes symbolic string for mechanism represented by M
177
 
178
   procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
179
   --  Given a representation value, write it out. No_Uint values or values
180
   --  dependent on discriminants are written as two question marks. If the
181
   --  flag Paren is set, then the output is surrounded in parentheses if it is
182
   --  other than a simple value.
183
 
184
   ---------------------
185
   -- Back_End_Layout --
186
   ---------------------
187
 
188
   function Back_End_Layout return Boolean is
189
   begin
190
      --  We have back end layout if the back end has made any entries in the
191
      --  table of GCC expressions, otherwise we have front end layout.
192
 
193
      return Rep_Table.Last > 0;
194
   end Back_End_Layout;
195
 
196
   ----------------
197
   -- Blank_Line --
198
   ----------------
199
 
200
   procedure Blank_Line is
201
   begin
202
      if Need_Blank_Line then
203
         Write_Eol;
204
         Need_Blank_Line := False;
205
      end if;
206
   end Blank_Line;
207
 
208
   ------------------------
209
   -- Create_Discrim_Ref --
210
   ------------------------
211
 
212
   function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref is
213
   begin
214
      return Create_Node
215
        (Expr => Discrim_Val,
216
         Op1  => Discriminant_Number (Discr));
217
   end Create_Discrim_Ref;
218
 
219
   ---------------------------
220
   -- Create_Dynamic_SO_Ref --
221
   ---------------------------
222
 
223
   function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is
224
   begin
225
      Dynamic_SO_Entity_Table.Append (E);
226
      return UI_From_Int (-Dynamic_SO_Entity_Table.Last);
227
   end Create_Dynamic_SO_Ref;
228
 
229
   -----------------
230
   -- Create_Node --
231
   -----------------
232
 
233
   function Create_Node
234
     (Expr : TCode;
235
      Op1  : Node_Ref_Or_Val;
236
      Op2  : Node_Ref_Or_Val := No_Uint;
237
      Op3  : Node_Ref_Or_Val := No_Uint) return Node_Ref
238
   is
239
   begin
240
      Rep_Table.Append (
241
        (Expr => Expr,
242
         Op1  => Op1,
243
         Op2  => Op2,
244
         Op3  => Op3));
245
      return UI_From_Int (-Rep_Table.Last);
246
   end Create_Node;
247
 
248
   ---------------------------
249
   -- Get_Dynamic_SO_Entity --
250
   ---------------------------
251
 
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;
256
 
257
   -----------------------
258
   -- Is_Dynamic_SO_Ref --
259
   -----------------------
260
 
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;
265
 
266
   ----------------------
267
   -- Is_Static_SO_Ref --
268
   ----------------------
269
 
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;
274
 
275
   ---------
276
   -- lgx --
277
   ---------
278
 
279
   procedure lgx (U : Node_Ref_Or_Val) is
280
   begin
281
      List_GCC_Expression (U);
282
      Write_Eol;
283
   end lgx;
284
 
285
   ----------------------
286
   -- List_Array_Info --
287
   ----------------------
288
 
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;
298
 
299
   -------------------
300
   -- List_Entities --
301
   -------------------
302
 
303
   procedure List_Entities (Ent : Entity_Id) is
304
      Body_E : Entity_Id;
305
      E      : Entity_Id;
306
 
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.
310
 
311
      ----------------------
312
      -- Find_Declaration --
313
      ----------------------
314
 
315
      function Find_Declaration (E : Entity_Id) return Node_Id is
316
         Decl : Node_Id;
317
 
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;
327
 
328
         return Decl;
329
      end Find_Declaration;
330
 
331
   --  Start of processing for List_Entities
332
 
333
   begin
334
      --  List entity if we have one, and it is not a renaming declaration.
335
      --  For renamings, we don't get proper information, and really it makes
336
      --  sense to restrict the output to the renamed entity.
337
 
338
      if Present (Ent)
339
        and then Nkind (Declaration_Node (Ent)) not in N_Renaming_Declaration
340
      then
341
         --  If entity is a subprogram and we are listing mechanisms,
342
         --  then we need to list mechanisms for this entity.
343
 
344
         if List_Representation_Info_Mechanisms
345
           and then (Is_Subprogram (Ent)
346
                       or else Ekind (Ent) = E_Entry
347
                       or else Ekind (Ent) = E_Entry_Family)
348
         then
349
            Need_Blank_Line := True;
350
            List_Mechanisms (Ent);
351
         end if;
352
 
353
         E := First_Entity (Ent);
354
         while Present (E) loop
355
            Need_Blank_Line := True;
356
 
357
            --  We list entities that come from source (excluding private or
358
            --  incomplete types or deferred constants, where we will list the
359
            --  info for the full view). If debug flag A is set, then all
360
            --  entities are listed
361
 
362
            if (Comes_From_Source (E)
363
              and then not Is_Incomplete_Or_Private_Type (E)
364
              and then not (Ekind (E) = E_Constant
365
                              and then Present (Full_View (E))))
366
              or else Debug_Flag_AA
367
            then
368
               if Is_Subprogram (E)
369
                       or else
370
                     Ekind (E) = E_Entry
371
                       or else
372
                     Ekind (E) = E_Entry_Family
373
                       or else
374
                     Ekind (E) = E_Subprogram_Type
375
               then
376
                  if List_Representation_Info_Mechanisms then
377
                     List_Mechanisms (E);
378
                  end if;
379
 
380
               elsif Is_Record_Type (E) then
381
                  if List_Representation_Info >= 1 then
382
                     List_Record_Info (E);
383
                  end if;
384
 
385
               elsif Is_Array_Type (E) then
386
                  if List_Representation_Info >= 1 then
387
                     List_Array_Info (E);
388
                  end if;
389
 
390
               elsif Is_Type (E) then
391
                  if List_Representation_Info >= 2 then
392
                     List_Type_Info (E);
393
                  end if;
394
 
395
               elsif Ekind (E) = E_Variable
396
                       or else
397
                     Ekind (E) = E_Constant
398
                       or else
399
                     Ekind (E) = E_Loop_Parameter
400
                       or else
401
                     Is_Formal (E)
402
               then
403
                  if List_Representation_Info >= 2 then
404
                     List_Object_Info (E);
405
                  end if;
406
 
407
               end if;
408
 
409
               --  Recurse into nested package, but not if they are package
410
               --  renamings (in particular renamings of the enclosing package,
411
               --  as for some Java bindings and for generic instances).
412
 
413
               if Ekind (E) = E_Package then
414
                  if No (Renamed_Object (E)) then
415
                     List_Entities (E);
416
                  end if;
417
 
418
               --  Recurse into bodies
419
 
420
               elsif Ekind (E) = E_Protected_Type
421
                       or else
422
                     Ekind (E) = E_Task_Type
423
                       or else
424
                     Ekind (E) = E_Subprogram_Body
425
                       or else
426
                     Ekind (E) = E_Package_Body
427
                       or else
428
                     Ekind (E) = E_Task_Body
429
                       or else
430
                     Ekind (E) = E_Protected_Body
431
               then
432
                  List_Entities (E);
433
 
434
               --  Recurse into blocks
435
 
436
               elsif Ekind (E) = E_Block then
437
                  List_Entities (E);
438
               end if;
439
            end if;
440
 
441
            E := Next_Entity (E);
442
         end loop;
443
 
444
         --  For a package body, the entities of the visible subprograms are
445
         --  declared in the corresponding spec. Iterate over its entities in
446
         --  order to handle properly the subprogram bodies. Skip bodies in
447
         --  subunits, which are listed independently.
448
 
449
         if Ekind (Ent) = E_Package_Body
450
           and then Present (Corresponding_Spec (Find_Declaration (Ent)))
451
         then
452
            E := First_Entity (Corresponding_Spec (Find_Declaration (Ent)));
453
 
454
            while Present (E) loop
455
               if Is_Subprogram (E)
456
                 and then
457
                   Nkind (Find_Declaration (E)) = N_Subprogram_Declaration
458
               then
459
                  Body_E := Corresponding_Body (Find_Declaration (E));
460
 
461
                  if Present (Body_E)
462
                    and then
463
                      Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit
464
                  then
465
                     List_Entities (Body_E);
466
                  end if;
467
               end if;
468
 
469
               Next_Entity (E);
470
            end loop;
471
         end if;
472
      end if;
473
   end List_Entities;
474
 
475
   -------------------------
476
   -- List_GCC_Expression --
477
   -------------------------
478
 
479
   procedure List_GCC_Expression (U : Node_Ref_Or_Val) is
480
 
481
      procedure Print_Expr (Val : Node_Ref_Or_Val);
482
      --  Internal recursive procedure to print expression
483
 
484
      ----------------
485
      -- Print_Expr --
486
      ----------------
487
 
488
      procedure Print_Expr (Val : Node_Ref_Or_Val) is
489
      begin
490
         if Val >= 0 then
491
            UI_Write (Val, Decimal);
492
 
493
         else
494
            declare
495
               Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
496
 
497
               procedure Binop (S : String);
498
               --  Output text for binary operator with S being operator name
499
 
500
               -----------
501
               -- Binop --
502
               -----------
503
 
504
               procedure Binop (S : String) is
505
               begin
506
                  Write_Char ('(');
507
                  Print_Expr (Node.Op1);
508
                  Write_Str (S);
509
                  Print_Expr (Node.Op2);
510
                  Write_Char (')');
511
               end Binop;
512
 
513
            --  Start of processing for Print_Expr
514
 
515
            begin
516
               case Node.Expr is
517
                  when Cond_Expr =>
518
                     Write_Str ("(if ");
519
                     Print_Expr (Node.Op1);
520
                     Write_Str (" then ");
521
                     Print_Expr (Node.Op2);
522
                     Write_Str (" else ");
523
                     Print_Expr (Node.Op3);
524
                     Write_Str (" end)");
525
 
526
                  when Plus_Expr =>
527
                     Binop (" + ");
528
 
529
                  when Minus_Expr =>
530
                     Binop (" - ");
531
 
532
                  when Mult_Expr =>
533
                     Binop (" * ");
534
 
535
                  when Trunc_Div_Expr =>
536
                     Binop (" /t ");
537
 
538
                  when Ceil_Div_Expr =>
539
                     Binop (" /c ");
540
 
541
                  when Floor_Div_Expr =>
542
                     Binop (" /f ");
543
 
544
                  when Trunc_Mod_Expr =>
545
                     Binop (" modt ");
546
 
547
                  when Floor_Mod_Expr =>
548
                     Binop (" modf ");
549
 
550
                  when Ceil_Mod_Expr =>
551
                     Binop (" modc ");
552
 
553
                  when Exact_Div_Expr =>
554
                     Binop (" /e ");
555
 
556
                  when Negate_Expr =>
557
                     Write_Char ('-');
558
                     Print_Expr (Node.Op1);
559
 
560
                  when Min_Expr =>
561
                     Binop (" min ");
562
 
563
                  when Max_Expr =>
564
                     Binop (" max ");
565
 
566
                  when Abs_Expr =>
567
                     Write_Str ("abs ");
568
                     Print_Expr (Node.Op1);
569
 
570
                  when Truth_Andif_Expr =>
571
                     Binop (" and if ");
572
 
573
                  when Truth_Orif_Expr =>
574
                     Binop (" or if ");
575
 
576
                  when Truth_And_Expr =>
577
                     Binop (" and ");
578
 
579
                  when Truth_Or_Expr =>
580
                     Binop (" or ");
581
 
582
                  when Truth_Xor_Expr =>
583
                     Binop (" xor ");
584
 
585
                  when Truth_Not_Expr =>
586
                     Write_Str ("not ");
587
                     Print_Expr (Node.Op1);
588
 
589
                  when Bit_And_Expr =>
590
                     Binop (" & ");
591
 
592
                  when Lt_Expr =>
593
                     Binop (" < ");
594
 
595
                  when Le_Expr =>
596
                     Binop (" <= ");
597
 
598
                  when Gt_Expr =>
599
                     Binop (" > ");
600
 
601
                  when Ge_Expr =>
602
                     Binop (" >= ");
603
 
604
                  when Eq_Expr =>
605
                     Binop (" == ");
606
 
607
                  when Ne_Expr =>
608
                     Binop (" != ");
609
 
610
                  when Discrim_Val =>
611
                     Write_Char ('#');
612
                     UI_Write (Node.Op1);
613
 
614
               end case;
615
            end;
616
         end if;
617
      end Print_Expr;
618
 
619
   --  Start of processing for List_GCC_Expression
620
 
621
   begin
622
      if U = No_Uint then
623
         Write_Str ("??");
624
      else
625
         Print_Expr (U);
626
      end if;
627
   end List_GCC_Expression;
628
 
629
   ---------------------
630
   -- List_Mechanisms --
631
   ---------------------
632
 
633
   procedure List_Mechanisms (Ent : Entity_Id) is
634
      Plen : Natural;
635
      Form : Entity_Id;
636
 
637
   begin
638
      Blank_Line;
639
 
640
      case Ekind (Ent) is
641
         when E_Function =>
642
            Write_Str ("function ");
643
 
644
         when E_Operator =>
645
            Write_Str ("operator ");
646
 
647
         when E_Procedure =>
648
            Write_Str ("procedure ");
649
 
650
         when E_Subprogram_Type =>
651
            Write_Str ("type ");
652
 
653
         when E_Entry | E_Entry_Family =>
654
            Write_Str ("entry ");
655
 
656
         when others =>
657
            raise Program_Error;
658
      end case;
659
 
660
      Get_Unqualified_Decoded_Name_String (Chars (Ent));
661
      Write_Str (Name_Buffer (1 .. Name_Len));
662
      Write_Str (" declared at ");
663
      Write_Location (Sloc (Ent));
664
      Write_Eol;
665
 
666
      Write_Str ("  convention : ");
667
 
668
      case Convention (Ent) is
669
         when Convention_Ada       => Write_Line ("Ada");
670
         when Convention_Intrinsic => Write_Line ("InLineinsic");
671
         when Convention_Entry     => Write_Line ("Entry");
672
         when Convention_Protected => Write_Line ("Protected");
673
         when Convention_Assembler => Write_Line ("Assembler");
674
         when Convention_C         => Write_Line ("C");
675
         when Convention_CIL       => Write_Line ("CIL");
676
         when Convention_COBOL     => Write_Line ("COBOL");
677
         when Convention_CPP       => Write_Line ("C++");
678
         when Convention_Fortran   => Write_Line ("Fortran");
679
         when Convention_Java      => Write_Line ("Java");
680
         when Convention_Stdcall   => Write_Line ("Stdcall");
681
         when Convention_Stubbed   => Write_Line ("Stubbed");
682
      end case;
683
 
684
      --  Find max length of formal name
685
 
686
      Plen := 0;
687
      Form := First_Formal (Ent);
688
      while Present (Form) loop
689
         Get_Unqualified_Decoded_Name_String (Chars (Form));
690
 
691
         if Name_Len > Plen then
692
            Plen := Name_Len;
693
         end if;
694
 
695
         Next_Formal (Form);
696
      end loop;
697
 
698
      --  Output formals and mechanisms
699
 
700
      Form := First_Formal (Ent);
701
      while Present (Form) loop
702
         Get_Unqualified_Decoded_Name_String (Chars (Form));
703
 
704
         while Name_Len <= Plen loop
705
            Name_Len := Name_Len + 1;
706
            Name_Buffer (Name_Len) := ' ';
707
         end loop;
708
 
709
         Write_Str ("  ");
710
         Write_Str (Name_Buffer (1 .. Plen + 1));
711
         Write_Str (": passed by ");
712
 
713
         Write_Mechanism (Mechanism (Form));
714
         Write_Eol;
715
         Next_Formal (Form);
716
      end loop;
717
 
718
      if Etype (Ent) /= Standard_Void_Type then
719
         Write_Str ("  returns by ");
720
         Write_Mechanism (Mechanism (Ent));
721
         Write_Eol;
722
      end if;
723
   end List_Mechanisms;
724
 
725
   ---------------
726
   -- List_Name --
727
   ---------------
728
 
729
   procedure List_Name (Ent : Entity_Id) is
730
   begin
731
      if not Is_Compilation_Unit (Scope (Ent)) then
732
         List_Name (Scope (Ent));
733
         Write_Char ('.');
734
      end if;
735
 
736
      Get_Unqualified_Decoded_Name_String (Chars (Ent));
737
      Set_Casing (Unit_Casing);
738
      Write_Str (Name_Buffer (1 .. Name_Len));
739
   end List_Name;
740
 
741
   ---------------------
742
   -- List_Object_Info --
743
   ---------------------
744
 
745
   procedure List_Object_Info (Ent : Entity_Id) is
746
   begin
747
      Blank_Line;
748
 
749
      Write_Str ("for ");
750
      List_Name (Ent);
751
      Write_Str ("'Size use ");
752
      Write_Val (Esize (Ent));
753
      Write_Line (";");
754
 
755
      Write_Str ("for ");
756
      List_Name (Ent);
757
      Write_Str ("'Alignment use ");
758
      Write_Val (Alignment (Ent));
759
      Write_Line (";");
760
   end List_Object_Info;
761
 
762
   ----------------------
763
   -- List_Record_Info --
764
   ----------------------
765
 
766
   procedure List_Record_Info (Ent : Entity_Id) is
767
      Comp  : Entity_Id;
768
      Cfbit : Uint;
769
      Sunit : Uint;
770
 
771
      Max_Name_Length : Natural;
772
      Max_Suni_Length : Natural;
773
 
774
   begin
775
      Blank_Line;
776
      List_Type_Info (Ent);
777
 
778
      Write_Str ("for ");
779
      List_Name (Ent);
780
      Write_Line (" use record");
781
 
782
      --  First loop finds out max line length and max starting position
783
      --  length, for the purpose of lining things up nicely.
784
 
785
      Max_Name_Length := 0;
786
      Max_Suni_Length := 0;
787
 
788
      Comp := First_Component_Or_Discriminant (Ent);
789
      while Present (Comp) loop
790
         Get_Decoded_Name_String (Chars (Comp));
791
         Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len);
792
 
793
         Cfbit := Component_Bit_Offset (Comp);
794
 
795
         if Rep_Not_Constant (Cfbit) then
796
            UI_Image_Length := 2;
797
 
798
         else
799
            --  Complete annotation in case not done
800
 
801
            Set_Normalized_Position (Comp, Cfbit / SSU);
802
            Set_Normalized_First_Bit (Comp, Cfbit mod SSU);
803
 
804
            Sunit := Cfbit / SSU;
805
            UI_Image (Sunit);
806
         end if;
807
 
808
         --  If the record is not packed, then we know that all fields whose
809
         --  position is not specified have a starting normalized bit position
810
         --  of zero.
811
 
812
         if Unknown_Normalized_First_Bit (Comp)
813
           and then not Is_Packed (Ent)
814
         then
815
            Set_Normalized_First_Bit (Comp, Uint_0);
816
         end if;
817
 
818
         Max_Suni_Length :=
819
           Natural'Max (Max_Suni_Length, UI_Image_Length);
820
 
821
         Next_Component_Or_Discriminant (Comp);
822
      end loop;
823
 
824
      --  Second loop does actual output based on those values
825
 
826
      Comp := First_Component_Or_Discriminant (Ent);
827
      while Present (Comp) loop
828
         declare
829
            Esiz : constant Uint := Esize (Comp);
830
            Bofs : constant Uint := Component_Bit_Offset (Comp);
831
            Npos : constant Uint := Normalized_Position (Comp);
832
            Fbit : constant Uint := Normalized_First_Bit (Comp);
833
            Lbit : Uint;
834
 
835
         begin
836
            Write_Str ("   ");
837
            Get_Decoded_Name_String (Chars (Comp));
838
            Set_Casing (Unit_Casing);
839
            Write_Str (Name_Buffer (1 .. Name_Len));
840
 
841
            for J in 1 .. Max_Name_Length - Name_Len loop
842
               Write_Char (' ');
843
            end loop;
844
 
845
            Write_Str (" at ");
846
 
847
            if Known_Static_Normalized_Position (Comp) then
848
               UI_Image (Npos);
849
               Spaces (Max_Suni_Length - UI_Image_Length);
850
               Write_Str (UI_Image_Buffer (1 .. UI_Image_Length));
851
 
852
            elsif Known_Component_Bit_Offset (Comp)
853
              and then List_Representation_Info = 3
854
            then
855
               Spaces (Max_Suni_Length - 2);
856
               Write_Str ("bit offset");
857
               Write_Val (Bofs, Paren => True);
858
               Write_Str (" size in bits = ");
859
               Write_Val (Esiz, Paren => True);
860
               Write_Eol;
861
               goto Continue;
862
 
863
            elsif Known_Normalized_Position (Comp)
864
              and then List_Representation_Info = 3
865
            then
866
               Spaces (Max_Suni_Length - 2);
867
               Write_Val (Npos);
868
 
869
            else
870
               --  For the packed case, we don't know the bit positions if we
871
               --  don't know the starting position!
872
 
873
               if Is_Packed (Ent) then
874
                  Write_Line ("?? range  ? .. ??;");
875
                  goto Continue;
876
 
877
               --  Otherwise we can continue
878
 
879
               else
880
                  Write_Str ("??");
881
               end if;
882
            end if;
883
 
884
            Write_Str (" range  ");
885
            UI_Write (Fbit);
886
            Write_Str (" .. ");
887
 
888
            --  Allowing Uint_0 here is a kludge, really this should be a
889
            --  fine Esize value but currently it means unknown, except that
890
            --  we know after gigi has back annotated that a size of zero is
891
            --  real, since otherwise gigi back annotates using No_Uint as
892
            --  the value to indicate unknown).
893
 
894
            if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp))
895
              and then Known_Static_Normalized_First_Bit (Comp)
896
            then
897
               Lbit := Fbit + Esiz - 1;
898
 
899
               if Lbit < 10 then
900
                  Write_Char (' ');
901
               end if;
902
 
903
               UI_Write (Lbit);
904
 
905
            --  The test for Esize (Comp) not being Uint_0 here is a kludge.
906
            --  Officially a value of zero for Esize means unknown, but here
907
            --  we use the fact that we know that gigi annotates Esize with
908
            --  No_Uint, not Uint_0. Really everyone should use No_Uint???
909
 
910
            elsif List_Representation_Info < 3
911
              or else (Esize (Comp) /= Uint_0 and then Unknown_Esize (Comp))
912
            then
913
               Write_Str ("??");
914
 
915
            --  List_Representation >= 3 and Known_Esize (Comp)
916
 
917
            else
918
               Write_Val (Esiz, Paren => True);
919
 
920
               --  If in front end layout mode, then dynamic size is stored
921
               --  in storage units, so renormalize for output
922
 
923
               if not Back_End_Layout then
924
                  Write_Str (" * ");
925
                  Write_Int (SSU);
926
               end if;
927
 
928
               --  Add appropriate first bit offset
929
 
930
               if Fbit = 0 then
931
                  Write_Str (" - 1");
932
 
933
               elsif Fbit = 1 then
934
                  null;
935
 
936
               else
937
                  Write_Str (" + ");
938
                  Write_Int (UI_To_Int (Fbit) - 1);
939
               end if;
940
            end if;
941
 
942
            Write_Line (";");
943
         end;
944
 
945
      <<Continue>>
946
         Next_Component_Or_Discriminant (Comp);
947
      end loop;
948
 
949
      Write_Line ("end record;");
950
   end List_Record_Info;
951
 
952
   -------------------
953
   -- List_Rep_Info --
954
   -------------------
955
 
956
   procedure List_Rep_Info is
957
      Col : Nat;
958
 
959
   begin
960
      if List_Representation_Info /= 0
961
        or else List_Representation_Info_Mechanisms
962
      then
963
         for U in Main_Unit .. Last_Unit loop
964
            if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
965
 
966
               --  Normal case, list to standard output
967
 
968
               if not List_Representation_Info_To_File then
969
                  Unit_Casing := Identifier_Casing (Source_Index (U));
970
                  Write_Eol;
971
                  Write_Str ("Representation information for unit ");
972
                  Write_Unit_Name (Unit_Name (U));
973
                  Col := Column;
974
                  Write_Eol;
975
 
976
                  for J in 1 .. Col - 1 loop
977
                     Write_Char ('-');
978
                  end loop;
979
 
980
                  Write_Eol;
981
                  List_Entities (Cunit_Entity (U));
982
 
983
               --  List representation information to file
984
 
985
               else
986
                  Create_Repinfo_File_Access.all
987
                    (Get_Name_String (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;
997
 
998
   --------------------
999
   -- List_Type_Info --
1000
   --------------------
1001
 
1002
   procedure List_Type_Info (Ent : Entity_Id) is
1003
   begin
1004
      Blank_Line;
1005
 
1006
      --  Do not list size info for unconstrained arrays, not meaningful
1007
 
1008
      if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then
1009
         null;
1010
 
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.
1014
 
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 (";");
1021
 
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???
1025
 
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 (";");
1032
 
1033
         --  Otherwise list size values separately if they are set
1034
 
1035
         else
1036
            Write_Str ("for ");
1037
            List_Name (Ent);
1038
            Write_Str ("'Object_Size use ");
1039
            Write_Val (Esize (Ent));
1040
            Write_Line (";");
1041
 
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.
1044
 
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;
1052
 
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;
1059
 
1060
   ----------------------
1061
   -- Rep_Not_Constant --
1062
   ----------------------
1063
 
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;
1072
 
1073
   ---------------
1074
   -- Rep_Value --
1075
   ---------------
1076
 
1077
   function Rep_Value
1078
     (Val : Node_Ref_Or_Val;
1079
      D   : Discrim_List) return Uint
1080
   is
1081
      function B (Val : Boolean) return Uint;
1082
      --  Returns Uint_0 for False, Uint_1 for True
1083
 
1084
      function T (Val : Node_Ref_Or_Val) return Boolean;
1085
      --  Returns True for 0, False for any non-zero (i.e. True)
1086
 
1087
      function V (Val : Node_Ref_Or_Val) return Uint;
1088
      --  Internal recursive routine to evaluate tree
1089
 
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 unreliabilities in computations anyway.
1097
 
1098
      -------
1099
      -- B --
1100
      -------
1101
 
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;
1110
 
1111
      -------
1112
      -- T --
1113
      -------
1114
 
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;
1123
 
1124
      -------
1125
      -- V --
1126
      -------
1127
 
1128
      function V (Val : Node_Ref_Or_Val) return Uint is
1129
         L, R, Q : Uint;
1130
 
1131
      begin
1132
         if Val >= 0 then
1133
            return Val;
1134
 
1135
         else
1136
            declare
1137
               Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
1138
 
1139
            begin
1140
               case Node.Expr is
1141
                  when Cond_Expr =>
1142
                     if T (Node.Op1) then
1143
                        return V (Node.Op2);
1144
                     else
1145
                        return V (Node.Op3);
1146
                     end if;
1147
 
1148
                  when Plus_Expr =>
1149
                     return V (Node.Op1) + V (Node.Op2);
1150
 
1151
                  when Minus_Expr =>
1152
                     return V (Node.Op1) - V (Node.Op2);
1153
 
1154
                  when Mult_Expr =>
1155
                     return V (Node.Op1) * V (Node.Op2);
1156
 
1157
                  when Trunc_Div_Expr =>
1158
                     return V (Node.Op1) / V (Node.Op2);
1159
 
1160
                  when Ceil_Div_Expr =>
1161
                     return
1162
                       UR_Ceiling
1163
                         (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
1164
 
1165
                  when Floor_Div_Expr =>
1166
                     return
1167
                       UR_Floor
1168
                         (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
1169
 
1170
                  when Trunc_Mod_Expr =>
1171
                     return V (Node.Op1) rem V (Node.Op2);
1172
 
1173
                  when Floor_Mod_Expr =>
1174
                     return V (Node.Op1) mod V (Node.Op2);
1175
 
1176
                  when Ceil_Mod_Expr =>
1177
                     L := V (Node.Op1);
1178
                     R := V (Node.Op2);
1179
                     Q := UR_Ceiling (L / UR_From_Uint (R));
1180
                     return L - R * Q;
1181
 
1182
                  when Exact_Div_Expr =>
1183
                     return V (Node.Op1) / V (Node.Op2);
1184
 
1185
                  when Negate_Expr =>
1186
                     return -V (Node.Op1);
1187
 
1188
                  when Min_Expr =>
1189
                     return UI_Min (V (Node.Op1), V (Node.Op2));
1190
 
1191
                  when Max_Expr =>
1192
                     return UI_Max (V (Node.Op1), V (Node.Op2));
1193
 
1194
                  when Abs_Expr =>
1195
                     return UI_Abs (V (Node.Op1));
1196
 
1197
                  when Truth_Andif_Expr =>
1198
                     return B (T (Node.Op1) and then T (Node.Op2));
1199
 
1200
                  when Truth_Orif_Expr =>
1201
                     return B (T (Node.Op1) or else T (Node.Op2));
1202
 
1203
                  when Truth_And_Expr =>
1204
                     return B (T (Node.Op1) and then T (Node.Op2));
1205
 
1206
                  when Truth_Or_Expr =>
1207
                     return B (T (Node.Op1) or else T (Node.Op2));
1208
 
1209
                  when Truth_Xor_Expr =>
1210
                     return B (T (Node.Op1) xor T (Node.Op2));
1211
 
1212
                  when Truth_Not_Expr =>
1213
                     return B (not T (Node.Op1));
1214
 
1215
                  when Bit_And_Expr =>
1216
                     L := V (Node.Op1);
1217
                     R := V (Node.Op2);
1218
                     return UI_From_Int (Int (W (L) and W (R)));
1219
 
1220
                  when Lt_Expr =>
1221
                     return B (V (Node.Op1) < V (Node.Op2));
1222
 
1223
                  when Le_Expr =>
1224
                     return B (V (Node.Op1) <= V (Node.Op2));
1225
 
1226
                  when Gt_Expr =>
1227
                     return B (V (Node.Op1) > V (Node.Op2));
1228
 
1229
                  when Ge_Expr =>
1230
                     return B (V (Node.Op1) >= V (Node.Op2));
1231
 
1232
                  when Eq_Expr =>
1233
                     return B (V (Node.Op1) = V (Node.Op2));
1234
 
1235
                  when Ne_Expr =>
1236
                     return B (V (Node.Op1) /= V (Node.Op2));
1237
 
1238
                  when Discrim_Val =>
1239
                     declare
1240
                        Sub : constant Int := UI_To_Int (Node.Op1);
1241
 
1242
                     begin
1243
                        pragma Assert (Sub in D'Range);
1244
                        return D (Sub);
1245
                     end;
1246
 
1247
               end case;
1248
            end;
1249
         end if;
1250
      end V;
1251
 
1252
      -------
1253
      -- W --
1254
      -------
1255
 
1256
      --  We use an unchecked conversion to map Int values to their Word
1257
      --  bitwise equivalent, which we could not achieve with a normal type
1258
      --  conversion for negative Ints. We want bitwise equivalents because W
1259
      --  is used as a helper for bit operators like Bit_And_Expr, and can be
1260
      --  called for negative Ints in the context of aligning expressions like
1261
      --  X+Align & -Align.
1262
 
1263
      function W (Val : Uint) return Word is
1264
         function To_Word is new Ada.Unchecked_Conversion (Int, Word);
1265
      begin
1266
         return To_Word (UI_To_Int (Val));
1267
      end W;
1268
 
1269
   --  Start of processing for Rep_Value
1270
 
1271
   begin
1272
      if Val = No_Uint then
1273
         return No_Uint;
1274
 
1275
      else
1276
         return V (Val);
1277
      end if;
1278
   end Rep_Value;
1279
 
1280
   ------------
1281
   -- Spaces --
1282
   ------------
1283
 
1284
   procedure Spaces (N : Natural) is
1285
   begin
1286
      for J in 1 .. N loop
1287
         Write_Char (' ');
1288
      end loop;
1289
   end Spaces;
1290
 
1291
   ---------------
1292
   -- Tree_Read --
1293
   ---------------
1294
 
1295
   procedure Tree_Read is
1296
   begin
1297
      Rep_Table.Tree_Read;
1298
   end Tree_Read;
1299
 
1300
   ----------------
1301
   -- Tree_Write --
1302
   ----------------
1303
 
1304
   procedure Tree_Write is
1305
   begin
1306
      Rep_Table.Tree_Write;
1307
   end Tree_Write;
1308
 
1309
   ---------------------
1310
   -- Write_Info_Line --
1311
   ---------------------
1312
 
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;
1317
 
1318
   ---------------------
1319
   -- Write_Mechanism --
1320
   ---------------------
1321
 
1322
   procedure Write_Mechanism (M : Mechanism_Type) is
1323
   begin
1324
      case M is
1325
         when 0 =>
1326
            Write_Str ("default");
1327
 
1328
         when -1 =>
1329
            Write_Str ("copy");
1330
 
1331
         when -2 =>
1332
            Write_Str ("reference");
1333
 
1334
         when -3 =>
1335
            Write_Str ("descriptor");
1336
 
1337
         when -4 =>
1338
            Write_Str ("descriptor (UBS)");
1339
 
1340
         when -5 =>
1341
            Write_Str ("descriptor (UBSB)");
1342
 
1343
         when -6 =>
1344
            Write_Str ("descriptor (UBA)");
1345
 
1346
         when -7 =>
1347
            Write_Str ("descriptor (S)");
1348
 
1349
         when -8 =>
1350
            Write_Str ("descriptor (SB)");
1351
 
1352
         when -9 =>
1353
            Write_Str ("descriptor (A)");
1354
 
1355
         when -10 =>
1356
            Write_Str ("descriptor (NCA)");
1357
 
1358
         when others =>
1359
            raise Program_Error;
1360
      end case;
1361
   end Write_Mechanism;
1362
 
1363
   ---------------
1364
   -- Write_Val --
1365
   ---------------
1366
 
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 ("??");
1372
 
1373
         else
1374
            if Back_End_Layout then
1375
               Write_Char (' ');
1376
 
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;
1384
 
1385
               Write_Char (' ');
1386
 
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;
1397
 
1398
      else
1399
         UI_Write (Val);
1400
      end if;
1401
   end Write_Val;
1402
 
1403
end Repinfo;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.