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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [lib-xref-alfa.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                        L I B . X R E F . A L F A                         --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--             Copyright (C) 2011, 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.  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 COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Alfa;     use Alfa;
27
with Einfo;    use Einfo;
28
with Nmake;    use Nmake;
29
with Put_Alfa;
30
 
31
with GNAT.HTable;
32
 
33
separate (Lib.Xref)
34
package body Alfa is
35
 
36
   ---------------------
37
   -- Local Constants --
38
   ---------------------
39
 
40
   --  Table of Alfa_Entities, True for each entity kind used in Alfa
41
 
42
   Alfa_Entities : constant array (Entity_Kind) of Boolean :=
43
     (E_Void                                       => False,
44
      E_Variable                                   => True,
45
      E_Component                                  => False,
46
      E_Constant                                   => True,
47
      E_Discriminant                               => False,
48
 
49
      E_Loop_Parameter                             => True,
50
      E_In_Parameter                               => True,
51
      E_Out_Parameter                              => True,
52
      E_In_Out_Parameter                           => True,
53
      E_Generic_In_Out_Parameter                   => False,
54
 
55
      E_Generic_In_Parameter                       => False,
56
      E_Named_Integer                              => False,
57
      E_Named_Real                                 => False,
58
      E_Enumeration_Type                           => False,
59
      E_Enumeration_Subtype                        => False,
60
 
61
      E_Signed_Integer_Type                        => False,
62
      E_Signed_Integer_Subtype                     => False,
63
      E_Modular_Integer_Type                       => False,
64
      E_Modular_Integer_Subtype                    => False,
65
      E_Ordinary_Fixed_Point_Type                  => False,
66
 
67
      E_Ordinary_Fixed_Point_Subtype               => False,
68
      E_Decimal_Fixed_Point_Type                   => False,
69
      E_Decimal_Fixed_Point_Subtype                => False,
70
      E_Floating_Point_Type                        => False,
71
      E_Floating_Point_Subtype                     => False,
72
 
73
      E_Access_Type                                => False,
74
      E_Access_Subtype                             => False,
75
      E_Access_Attribute_Type                      => False,
76
      E_Allocator_Type                             => False,
77
      E_General_Access_Type                        => False,
78
 
79
      E_Access_Subprogram_Type                     => False,
80
      E_Access_Protected_Subprogram_Type           => False,
81
      E_Anonymous_Access_Subprogram_Type           => False,
82
      E_Anonymous_Access_Protected_Subprogram_Type => False,
83
      E_Anonymous_Access_Type                      => False,
84
 
85
      E_Array_Type                                 => False,
86
      E_Array_Subtype                              => False,
87
      E_String_Type                                => False,
88
      E_String_Subtype                             => False,
89
      E_String_Literal_Subtype                     => False,
90
 
91
      E_Class_Wide_Type                            => False,
92
      E_Class_Wide_Subtype                         => False,
93
      E_Record_Type                                => False,
94
      E_Record_Subtype                             => False,
95
      E_Record_Type_With_Private                   => False,
96
 
97
      E_Record_Subtype_With_Private                => False,
98
      E_Private_Type                               => False,
99
      E_Private_Subtype                            => False,
100
      E_Limited_Private_Type                       => False,
101
      E_Limited_Private_Subtype                    => False,
102
 
103
      E_Incomplete_Type                            => False,
104
      E_Incomplete_Subtype                         => False,
105
      E_Task_Type                                  => False,
106
      E_Task_Subtype                               => False,
107
      E_Protected_Type                             => False,
108
 
109
      E_Protected_Subtype                          => False,
110
      E_Exception_Type                             => False,
111
      E_Subprogram_Type                            => False,
112
      E_Enumeration_Literal                        => False,
113
      E_Function                                   => True,
114
 
115
      E_Operator                                   => True,
116
      E_Procedure                                  => True,
117
      E_Entry                                      => False,
118
      E_Entry_Family                               => False,
119
      E_Block                                      => False,
120
 
121
      E_Entry_Index_Parameter                      => False,
122
      E_Exception                                  => False,
123
      E_Generic_Function                           => False,
124
      E_Generic_Package                            => False,
125
      E_Generic_Procedure                          => False,
126
 
127
      E_Label                                      => False,
128
      E_Loop                                       => False,
129
      E_Return_Statement                           => False,
130
      E_Package                                    => False,
131
 
132
      E_Package_Body                               => False,
133
      E_Protected_Object                           => False,
134
      E_Protected_Body                             => False,
135
      E_Task_Body                                  => False,
136
      E_Subprogram_Body                            => False);
137
 
138
   --  True for each reference type used in Alfa
139
   Alfa_References : constant array (Character) of Boolean :=
140
     ('m' => True,
141
      'r' => True,
142
      's' => True,
143
      others => False);
144
 
145
   type Entity_Hashed_Range is range 0 .. 255;
146
   --  Size of hash table headers
147
 
148
   ---------------------
149
   -- Local Variables --
150
   ---------------------
151
 
152
   package Drefs is new Table.Table (
153
     Table_Component_Type => Xref_Entry,
154
     Table_Index_Type     => Xref_Entry_Number,
155
     Table_Low_Bound      => 1,
156
     Table_Initial        => Alloc.Xrefs_Initial,
157
     Table_Increment      => Alloc.Xrefs_Increment,
158
     Table_Name           => "Drefs");
159
   --  Table of cross-references for reads and writes through explicit
160
   --  dereferences, that are output as reads/writes to the special variable
161
   --  "Heap". These references are added to the regular references when
162
   --  computing Alfa cross-references.
163
 
164
   -----------------------
165
   -- Local Subprograms --
166
   -----------------------
167
 
168
   procedure Add_Alfa_File (U : Unit_Number_Type; D : Nat);
169
   --  Add file U and all scopes in U to the tables Alfa_File_Table and
170
   --  Alfa_Scope_Table.
171
 
172
   procedure Add_Alfa_Scope (N : Node_Id);
173
   --  Add scope N to the table Alfa_Scope_Table
174
 
175
   procedure Add_Alfa_Xrefs;
176
   --  Filter table Xrefs to add all references used in Alfa to the table
177
   --  Alfa_Xref_Table.
178
 
179
   procedure Detect_And_Add_Alfa_Scope (N : Node_Id);
180
   --  Call Add_Alfa_Scope on scopes
181
 
182
   function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range;
183
   --  Hash function for hash table
184
 
185
   procedure Traverse_Declarations_Or_Statements
186
     (L            : List_Id;
187
      Process      : Node_Processing;
188
      Inside_Stubs : Boolean);
189
   procedure Traverse_Handled_Statement_Sequence
190
     (N            : Node_Id;
191
      Process      : Node_Processing;
192
      Inside_Stubs : Boolean);
193
   procedure Traverse_Package_Body
194
     (N            : Node_Id;
195
      Process      : Node_Processing;
196
      Inside_Stubs : Boolean);
197
   procedure Traverse_Package_Declaration
198
     (N            : Node_Id;
199
      Process      : Node_Processing;
200
      Inside_Stubs : Boolean);
201
   procedure Traverse_Subprogram_Body
202
     (N            : Node_Id;
203
      Process      : Node_Processing;
204
      Inside_Stubs : Boolean);
205
   --  Traverse the corresponding constructs, calling Process on all
206
   --  declarations.
207
 
208
   -------------------
209
   -- Add_Alfa_File --
210
   -------------------
211
 
212
   procedure Add_Alfa_File (U : Unit_Number_Type; D : Nat) is
213
      From : Scope_Index;
214
 
215
      S : constant Source_File_Index := Source_Index (U);
216
 
217
   begin
218
      --  Source file could be inexistant as a result of an error, if option
219
      --  gnatQ is used.
220
 
221
      if S = No_Source_File then
222
         return;
223
      end if;
224
 
225
      From := Alfa_Scope_Table.Last + 1;
226
 
227
      Traverse_Compilation_Unit (Cunit (U), Detect_And_Add_Alfa_Scope'Access,
228
                                 Inside_Stubs => False);
229
 
230
      --  Update scope numbers
231
 
232
      declare
233
         Count : Nat;
234
 
235
      begin
236
         Count := 1;
237
         for S in From .. Alfa_Scope_Table.Last loop
238
            declare
239
               E : Entity_Id renames Alfa_Scope_Table.Table (S).Scope_Entity;
240
 
241
            begin
242
               if Lib.Get_Source_Unit (E) = U then
243
                  Alfa_Scope_Table.Table (S).Scope_Num := Count;
244
                  Alfa_Scope_Table.Table (S).File_Num  := D;
245
                  Count                                := Count + 1;
246
 
247
               else
248
                  --  Mark for removal a scope S which is not located in unit
249
                  --  U, for example for scope inside generics that get
250
                  --  instantiated.
251
 
252
                  Alfa_Scope_Table.Table (S).Scope_Num := 0;
253
               end if;
254
            end;
255
         end loop;
256
      end;
257
 
258
      declare
259
         Snew : Scope_Index;
260
 
261
      begin
262
         Snew := From;
263
         for S in From .. Alfa_Scope_Table.Last loop
264
            --  Remove those scopes previously marked for removal
265
 
266
            if Alfa_Scope_Table.Table (S).Scope_Num /= 0 then
267
               Alfa_Scope_Table.Table (Snew) := Alfa_Scope_Table.Table (S);
268
               Snew := Snew + 1;
269
            end if;
270
         end loop;
271
 
272
         Alfa_Scope_Table.Set_Last (Snew - 1);
273
      end;
274
 
275
      --  Make entry for new file in file table
276
 
277
      Get_Name_String (Reference_Name (S));
278
 
279
      Alfa_File_Table.Append (
280
        (File_Name  => new String'(Name_Buffer (1 .. Name_Len)),
281
         File_Num   => D,
282
         From_Scope => From,
283
         To_Scope   => Alfa_Scope_Table.Last));
284
   end Add_Alfa_File;
285
 
286
   --------------------
287
   -- Add_Alfa_Scope --
288
   --------------------
289
 
290
   procedure Add_Alfa_Scope (N : Node_Id) is
291
      E   : constant Entity_Id  := Defining_Entity (N);
292
      Loc : constant Source_Ptr := Sloc (E);
293
      Typ : Character;
294
 
295
   begin
296
      --  Ignore scopes without a proper location
297
 
298
      if Sloc (N) = No_Location then
299
         return;
300
      end if;
301
 
302
      case Ekind (E) is
303
         when E_Function | E_Generic_Function =>
304
            Typ := 'V';
305
 
306
         when E_Procedure | E_Generic_Procedure =>
307
            Typ := 'U';
308
 
309
         when E_Subprogram_Body =>
310
            declare
311
               Spec : Node_Id;
312
 
313
            begin
314
               Spec := Parent (E);
315
 
316
               if Nkind (Spec) = N_Defining_Program_Unit_Name then
317
                  Spec := Parent (Spec);
318
               end if;
319
 
320
               if Nkind (Spec) = N_Function_Specification then
321
                  Typ := 'V';
322
               else
323
                  pragma Assert
324
                    (Nkind (Spec) = N_Procedure_Specification);
325
                  Typ := 'U';
326
               end if;
327
            end;
328
 
329
         when E_Package | E_Package_Body | E_Generic_Package =>
330
            Typ := 'K';
331
 
332
         when E_Void =>
333
            --  Compilation of prj-attr.adb with -gnatn creates a node with
334
            --  entity E_Void for the package defined at a-charac.ads16:13
335
 
336
            --  ??? TBD
337
 
338
            return;
339
 
340
         when others =>
341
            raise Program_Error;
342
      end case;
343
 
344
      --  File_Num and Scope_Num are filled later. From_Xref and To_Xref are
345
      --  filled even later, but are initialized to represent an empty range.
346
 
347
      Alfa_Scope_Table.Append (
348
        (Scope_Name     => new String'(Unique_Name (E)),
349
         File_Num       => 0,
350
         Scope_Num      => 0,
351
         Spec_File_Num  => 0,
352
         Spec_Scope_Num => 0,
353
         Line           => Nat (Get_Logical_Line_Number (Loc)),
354
         Stype          => Typ,
355
         Col            => Nat (Get_Column_Number (Loc)),
356
         From_Xref      => 1,
357
         To_Xref        => 0,
358
         Scope_Entity   => E));
359
   end Add_Alfa_Scope;
360
 
361
   --------------------
362
   -- Add_Alfa_Xrefs --
363
   --------------------
364
 
365
   procedure Add_Alfa_Xrefs is
366
      Cur_Scope_Idx   : Scope_Index;
367
      From_Xref_Idx   : Xref_Index;
368
      Cur_Entity      : Entity_Id;
369
      Cur_Entity_Name : String_Ptr;
370
 
371
      package Scopes is
372
         No_Scope : constant Nat := 0;
373
         function Get_Scope_Num (N : Entity_Id) return Nat;
374
         procedure Set_Scope_Num (N : Entity_Id; Num : Nat);
375
      end Scopes;
376
 
377
      ------------
378
      -- Scopes --
379
      ------------
380
 
381
      package body Scopes is
382
         type Scope is record
383
            Num    : Nat;
384
            Entity : Entity_Id;
385
         end record;
386
 
387
         package Scopes is new GNAT.HTable.Simple_HTable
388
           (Header_Num => Entity_Hashed_Range,
389
            Element    => Scope,
390
            No_Element => (Num => No_Scope, Entity => Empty),
391
            Key        => Entity_Id,
392
            Hash       => Entity_Hash,
393
            Equal      => "=");
394
 
395
         -------------------
396
         -- Get_Scope_Num --
397
         -------------------
398
 
399
         function Get_Scope_Num (N : Entity_Id) return Nat is
400
         begin
401
            return Scopes.Get (N).Num;
402
         end Get_Scope_Num;
403
 
404
         -------------------
405
         -- Set_Scope_Num --
406
         -------------------
407
 
408
         procedure Set_Scope_Num (N : Entity_Id; Num : Nat) is
409
         begin
410
            Scopes.Set (K => N, E => Scope'(Num => Num, Entity => N));
411
         end Set_Scope_Num;
412
      end Scopes;
413
 
414
      use Scopes;
415
 
416
      Nrefs : Nat := Xrefs.Last;
417
      --  Number of references in table. This value may get reset (reduced)
418
      --  when we eliminate duplicate reference entries as well as references
419
      --  not suitable for local cross-references.
420
 
421
      Nrefs_Add : constant Nat := Drefs.Last;
422
 
423
      Rnums : array (0 .. Nrefs + Nrefs_Add) of Nat;
424
      --  This array contains numbers of references in the Xrefs table. This
425
      --  list is sorted in output order. The extra 0'th entry is convenient
426
      --  for the call to sort. When we sort the table, we move the entries in
427
      --  Rnums around, but we do not move the original table entries.
428
 
429
      function Lt (Op1, Op2 : Natural) return Boolean;
430
      --  Comparison function for Sort call
431
 
432
      procedure Move (From : Natural; To : Natural);
433
      --  Move procedure for Sort call
434
 
435
      package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
436
 
437
      --------
438
      -- Lt --
439
      --------
440
 
441
      function Lt (Op1, Op2 : Natural) return Boolean is
442
         T1 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op1)));
443
         T2 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op2)));
444
 
445
      begin
446
         --  First test: if entity is in different unit, sort by unit. Note:
447
         --  that we use Ent_Scope_File rather than Eun, as Eun may refer to
448
         --  the file where the generic scope is defined, which may differ from
449
         --  the file where the enclosing scope is defined. It is the latter
450
         --  which matters for a correct order here.
451
 
452
         if T1.Ent_Scope_File /= T2.Ent_Scope_File then
453
            return Dependency_Num (T1.Ent_Scope_File) <
454
              Dependency_Num (T2.Ent_Scope_File);
455
 
456
         --  Second test: within same unit, sort by location of the scope of
457
         --  the entity definition.
458
 
459
         elsif Get_Scope_Num (T1.Key.Ent_Scope) /=
460
               Get_Scope_Num (T2.Key.Ent_Scope)
461
         then
462
            return Get_Scope_Num (T1.Key.Ent_Scope) <
463
              Get_Scope_Num (T2.Key.Ent_Scope);
464
 
465
         --  Third test: within same unit and scope, sort by location of
466
         --  entity definition.
467
 
468
         elsif T1.Def /= T2.Def then
469
            return T1.Def < T2.Def;
470
 
471
         --  Fourth test: if reference is in same unit as entity definition,
472
         --  sort first.
473
 
474
         elsif
475
           T1.Key.Lun /= T2.Key.Lun and then T1.Ent_Scope_File = T1.Key.Lun
476
         then
477
            return True;
478
 
479
         elsif
480
           T1.Key.Lun /= T2.Key.Lun and then T2.Ent_Scope_File = T2.Key.Lun
481
         then
482
            return False;
483
 
484
         --  Fifth test: if reference is in same unit and same scope as entity
485
         --  definition, sort first.
486
 
487
         elsif T1.Ent_Scope_File = T1.Key.Lun
488
           and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope
489
           and then T1.Key.Ent_Scope = T1.Key.Ref_Scope
490
         then
491
            return True;
492
         elsif T1.Ent_Scope_File = T1.Key.Lun
493
           and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope
494
           and then T2.Key.Ent_Scope = T2.Key.Ref_Scope
495
         then
496
            return False;
497
 
498
         --  Sixth test: for same entity, sort by reference location unit
499
 
500
         elsif T1.Key.Lun /= T2.Key.Lun then
501
            return Dependency_Num (T1.Key.Lun) < Dependency_Num (T2.Key.Lun);
502
 
503
         --  Seventh test: for same entity, sort by reference location scope
504
 
505
         elsif Get_Scope_Num (T1.Key.Ref_Scope) /=
506
               Get_Scope_Num (T2.Key.Ref_Scope)
507
         then
508
            return Get_Scope_Num (T1.Key.Ref_Scope) <
509
              Get_Scope_Num (T2.Key.Ref_Scope);
510
 
511
         --  Eighth test: order of location within referencing unit
512
 
513
         elsif T1.Key.Loc /= T2.Key.Loc then
514
            return T1.Key.Loc < T2.Key.Loc;
515
 
516
         --  Finally, for two locations at the same address prefer the one that
517
         --  does NOT have the type 'r', so that a modification or extension
518
         --  takes preference, when there are more than one reference at the
519
         --  same location. As a result, in the case of entities that are
520
         --  in-out actuals, the read reference follows the modify reference.
521
 
522
         else
523
            return T2.Key.Typ = 'r';
524
         end if;
525
      end Lt;
526
 
527
      ----------
528
      -- Move --
529
      ----------
530
 
531
      procedure Move (From : Natural; To : Natural) is
532
      begin
533
         Rnums (Nat (To)) := Rnums (Nat (From));
534
      end Move;
535
 
536
      Heap : Entity_Id;
537
 
538
   --  Start of processing for Add_Alfa_Xrefs
539
 
540
   begin
541
      for J in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop
542
         Set_Scope_Num (N   => Alfa_Scope_Table.Table (J).Scope_Entity,
543
                        Num => Alfa_Scope_Table.Table (J).Scope_Num);
544
      end loop;
545
 
546
      --  Set up the pointer vector for the sort
547
 
548
      for J in 1 .. Nrefs loop
549
         Rnums (J) := J;
550
      end loop;
551
 
552
      --  Add dereferences to the set of regular references, by creating a
553
      --  special "Heap" variable for these special references.
554
 
555
      Name_Len := Name_Of_Heap_Variable'Length;
556
      Name_Buffer (1 .. Name_Len) := Name_Of_Heap_Variable;
557
 
558
      Atree.Unlock;
559
      Nlists.Unlock;
560
      Heap := Make_Defining_Identifier (Standard_Location, Name_Enter);
561
      Atree.Lock;
562
      Nlists.Lock;
563
 
564
      Set_Ekind         (Heap, E_Variable);
565
      Set_Is_Internal   (Heap, True);
566
      Set_Has_Fully_Qualified_Name (Heap);
567
 
568
      for J in Drefs.First .. Drefs.Last loop
569
         Xrefs.Append (Drefs.Table (J));
570
 
571
         --  Set entity at this point with newly created "Heap" variable
572
 
573
         Xrefs.Table (Xrefs.Last).Key.Ent := Heap;
574
 
575
         Nrefs         := Nrefs + 1;
576
         Rnums (Nrefs) := Xrefs.Last;
577
      end loop;
578
 
579
      --  Eliminate entries not appropriate for Alfa. Done prior to sorting
580
      --  cross-references, as it discards useless references which do not have
581
      --  a proper format for the comparison function (like no location).
582
 
583
      Eliminate_Before_Sort : declare
584
         NR : Nat;
585
 
586
         function Is_Alfa_Reference
587
           (E   : Entity_Id;
588
            Typ : Character) return Boolean;
589
         --  Return whether entity reference E meets Alfa requirements. Typ
590
         --  is the reference type.
591
 
592
         function Is_Alfa_Scope (E : Entity_Id) return Boolean;
593
         --  Return whether the entity or reference scope meets requirements
594
         --  for being an Alfa scope.
595
 
596
         function Is_Global_Constant (E : Entity_Id) return Boolean;
597
         --  Return True if E is a global constant for which we should ignore
598
         --  reads in Alfa.
599
 
600
         -----------------------
601
         -- Is_Alfa_Reference --
602
         -----------------------
603
 
604
         function Is_Alfa_Reference
605
           (E   : Entity_Id;
606
            Typ : Character) return Boolean
607
         is
608
         begin
609
            --  The only references of interest on callable entities are calls.
610
            --  On non-callable entities, the only references of interest are
611
            --  reads and writes.
612
 
613
            if Ekind (E) in Overloadable_Kind then
614
               return Typ = 's';
615
 
616
            --  References to constant objects are not considered in Alfa
617
            --  section, as these will be translated as constants in the
618
            --  intermediate language for formal verification, and should
619
            --  therefore never appear in frame conditions.
620
 
621
            elsif Is_Constant_Object (E) then
622
                  return False;
623
 
624
            --  Objects of Task type or protected type are not Alfa references
625
 
626
            elsif Present (Etype (E))
627
              and then Ekind (Etype (E)) in Concurrent_Kind
628
            then
629
               return False;
630
 
631
            --  In all other cases, result is true for reference/modify cases,
632
            --  and false for all other cases.
633
 
634
            else
635
               return Typ = 'r' or else Typ = 'm';
636
            end if;
637
         end Is_Alfa_Reference;
638
 
639
         -------------------
640
         -- Is_Alfa_Scope --
641
         -------------------
642
 
643
         function Is_Alfa_Scope (E : Entity_Id) return Boolean is
644
         begin
645
            return Present (E)
646
              and then not Is_Generic_Unit (E)
647
              and then Renamed_Entity (E) = Empty
648
              and then Get_Scope_Num (E) /= No_Scope;
649
         end Is_Alfa_Scope;
650
 
651
         ------------------------
652
         -- Is_Global_Constant --
653
         ------------------------
654
 
655
         function Is_Global_Constant (E : Entity_Id) return Boolean is
656
         begin
657
            return Ekind (E) = E_Constant
658
              and then Ekind_In (Scope (E), E_Package, E_Package_Body);
659
         end Is_Global_Constant;
660
 
661
      --  Start of processing for Eliminate_Before_Sort
662
 
663
      begin
664
         NR    := Nrefs;
665
         Nrefs := 0;
666
 
667
         for J in 1 .. NR loop
668
            if Alfa_Entities (Ekind (Xrefs.Table (Rnums (J)).Key.Ent))
669
              and then Alfa_References (Xrefs.Table (Rnums (J)).Key.Typ)
670
              and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ent_Scope)
671
              and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ref_Scope)
672
              and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Key.Ent)
673
              and then Is_Alfa_Reference (Xrefs.Table (Rnums (J)).Key.Ent,
674
                                          Xrefs.Table (Rnums (J)).Key.Typ)
675
            then
676
               Nrefs         := Nrefs + 1;
677
               Rnums (Nrefs) := Rnums (J);
678
            end if;
679
         end loop;
680
      end Eliminate_Before_Sort;
681
 
682
      --  Sort the references
683
 
684
      Sorting.Sort (Integer (Nrefs));
685
 
686
      Eliminate_After_Sort : declare
687
         NR : Nat;
688
 
689
         Crloc : Source_Ptr;
690
         --  Current reference location
691
 
692
         Prevt : Character;
693
         --  reference kind of previous reference
694
 
695
      begin
696
         --  Eliminate duplicate entries
697
 
698
         --  We need this test for NR because if we force ALI file generation
699
         --  in case of errors detected, it may be the case that Nrefs is 0, so
700
         --  we should not reset it here
701
 
702
         if Nrefs >= 2 then
703
            NR    := Nrefs;
704
            Nrefs := 1;
705
 
706
            for J in 2 .. NR loop
707
               if Xrefs.Table (Rnums (J)) /=
708
                 Xrefs.Table (Rnums (Nrefs))
709
               then
710
                  Nrefs := Nrefs + 1;
711
                  Rnums (Nrefs) := Rnums (J);
712
               end if;
713
            end loop;
714
         end if;
715
 
716
         --  Eliminate the reference if it is at the same location as the
717
         --  previous one, unless it is a read-reference indicating that the
718
         --  entity is an in-out actual in a call.
719
 
720
         NR    := Nrefs;
721
         Nrefs := 0;
722
         Crloc := No_Location;
723
         Prevt := 'm';
724
 
725
         for J in 1 .. NR loop
726
            if Xrefs.Table (Rnums (J)).Key.Loc /= Crloc
727
              or else (Prevt = 'm'
728
                        and then Xrefs.Table (Rnums (J)).Key.Typ = 'r')
729
            then
730
               Crloc         := Xrefs.Table (Rnums (J)).Key.Loc;
731
               Prevt         := Xrefs.Table (Rnums (J)).Key.Typ;
732
               Nrefs         := Nrefs + 1;
733
               Rnums (Nrefs) := Rnums (J);
734
            end if;
735
         end loop;
736
      end Eliminate_After_Sort;
737
 
738
      --  Initialize loop
739
 
740
      Cur_Scope_Idx  := 1;
741
      From_Xref_Idx  := 1;
742
      Cur_Entity     := Empty;
743
 
744
      if Alfa_Scope_Table.Last = 0 then
745
         return;
746
      end if;
747
 
748
      --  Loop to output references
749
 
750
      for Refno in 1 .. Nrefs loop
751
         Add_One_Xref : declare
752
 
753
            -----------------------
754
            -- Local Subprograms --
755
            -----------------------
756
 
757
            function Cur_Scope return Node_Id;
758
            --  Return scope entity which corresponds to index Cur_Scope_Idx in
759
            --  table Alfa_Scope_Table.
760
 
761
            function Get_Entity_Type (E : Entity_Id) return Character;
762
            --  Return a character representing the type of entity
763
 
764
            function Is_Future_Scope_Entity (E : Entity_Id) return Boolean;
765
            --  Check whether entity E is in Alfa_Scope_Table at index
766
            --  Cur_Scope_Idx or higher.
767
 
768
            function Is_Past_Scope_Entity (E : Entity_Id) return Boolean;
769
            --  Check whether entity E is in Alfa_Scope_Table at index strictly
770
            --  lower than Cur_Scope_Idx.
771
 
772
            ---------------
773
            -- Cur_Scope --
774
            ---------------
775
 
776
            function Cur_Scope return Node_Id is
777
            begin
778
               return Alfa_Scope_Table.Table (Cur_Scope_Idx).Scope_Entity;
779
            end Cur_Scope;
780
 
781
            ---------------------
782
            -- Get_Entity_Type --
783
            ---------------------
784
 
785
            function Get_Entity_Type (E : Entity_Id) return Character is
786
               C : Character;
787
            begin
788
               case Ekind (E) is
789
                  when E_Out_Parameter    => C := '<';
790
                  when E_In_Out_Parameter => C := '=';
791
                  when E_In_Parameter     => C := '>';
792
                  when others             => C := '*';
793
               end case;
794
               return C;
795
            end Get_Entity_Type;
796
 
797
            ----------------------------
798
            -- Is_Future_Scope_Entity --
799
            ----------------------------
800
 
801
            function Is_Future_Scope_Entity (E : Entity_Id) return Boolean is
802
            begin
803
               for J in Cur_Scope_Idx .. Alfa_Scope_Table.Last loop
804
                  if E = Alfa_Scope_Table.Table (J).Scope_Entity then
805
                     return True;
806
                  end if;
807
               end loop;
808
 
809
               --  If this assertion fails, this means that the scope which we
810
               --  are looking for has been treated already, which reveals a
811
               --  problem in the order of cross-references.
812
 
813
               pragma Assert (not Is_Past_Scope_Entity (E));
814
 
815
               return False;
816
            end Is_Future_Scope_Entity;
817
 
818
            --------------------------
819
            -- Is_Past_Scope_Entity --
820
            --------------------------
821
 
822
            function Is_Past_Scope_Entity (E : Entity_Id) return Boolean is
823
            begin
824
               for J in Alfa_Scope_Table.First .. Cur_Scope_Idx - 1 loop
825
                  if E = Alfa_Scope_Table.Table (J).Scope_Entity then
826
                     return True;
827
                  end if;
828
               end loop;
829
 
830
               return False;
831
            end Is_Past_Scope_Entity;
832
 
833
            ---------------------
834
            -- Local Variables --
835
            ---------------------
836
 
837
            XE  : Xref_Entry renames Xrefs.Table (Rnums (Refno));
838
 
839
         begin
840
            --  If this assertion fails, the scope which we are looking for is
841
            --  not in Alfa scope table, which reveals either a problem in the
842
            --  construction of the scope table, or an erroneous scope for the
843
            --  current cross-reference.
844
 
845
            pragma Assert (Is_Future_Scope_Entity (XE.Key.Ent_Scope));
846
 
847
            --  Update the range of cross references to which the current scope
848
            --  refers to. This may be the empty range only for the first scope
849
            --  considered.
850
 
851
            if XE.Key.Ent_Scope /= Cur_Scope then
852
               Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref :=
853
                 From_Xref_Idx;
854
               Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref :=
855
                 Alfa_Xref_Table.Last;
856
               From_Xref_Idx := Alfa_Xref_Table.Last + 1;
857
            end if;
858
 
859
            while XE.Key.Ent_Scope /= Cur_Scope loop
860
               Cur_Scope_Idx := Cur_Scope_Idx + 1;
861
               pragma Assert (Cur_Scope_Idx <= Alfa_Scope_Table.Last);
862
            end loop;
863
 
864
            if XE.Key.Ent /= Cur_Entity then
865
               Cur_Entity_Name :=
866
                 new String'(Unique_Name (XE.Key.Ent));
867
            end if;
868
 
869
            if XE.Key.Ent = Heap then
870
               Alfa_Xref_Table.Append (
871
                 (Entity_Name => Cur_Entity_Name,
872
                  Entity_Line => 0,
873
                  Etype       => Get_Entity_Type (XE.Key.Ent),
874
                  Entity_Col  => 0,
875
                  File_Num    => Dependency_Num (XE.Key.Lun),
876
                  Scope_Num   => Get_Scope_Num (XE.Key.Ref_Scope),
877
                  Line        => Int (Get_Logical_Line_Number (XE.Key.Loc)),
878
                  Rtype       => XE.Key.Typ,
879
                  Col         => Int (Get_Column_Number (XE.Key.Loc))));
880
 
881
            else
882
               Alfa_Xref_Table.Append (
883
                 (Entity_Name => Cur_Entity_Name,
884
                  Entity_Line => Int (Get_Logical_Line_Number (XE.Def)),
885
                  Etype       => Get_Entity_Type (XE.Key.Ent),
886
                  Entity_Col  => Int (Get_Column_Number (XE.Def)),
887
                  File_Num    => Dependency_Num (XE.Key.Lun),
888
                  Scope_Num   => Get_Scope_Num (XE.Key.Ref_Scope),
889
                  Line        => Int (Get_Logical_Line_Number (XE.Key.Loc)),
890
                  Rtype       => XE.Key.Typ,
891
                  Col         => Int (Get_Column_Number (XE.Key.Loc))));
892
            end if;
893
         end Add_One_Xref;
894
      end loop;
895
 
896
      --  Update the range of cross references to which the scope refers to
897
 
898
      Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref := From_Xref_Idx;
899
      Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref   := Alfa_Xref_Table.Last;
900
   end Add_Alfa_Xrefs;
901
 
902
   ------------------
903
   -- Collect_Alfa --
904
   ------------------
905
 
906
   procedure Collect_Alfa (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat) is
907
   begin
908
      --  Cross-references should have been computed first
909
 
910
      pragma Assert (Xrefs.Last /= 0);
911
 
912
      Initialize_Alfa_Tables;
913
 
914
      --  Generate file and scope Alfa information
915
 
916
      for D in 1 .. Num_Sdep loop
917
         Add_Alfa_File (U => Sdep_Table (D), D => D);
918
      end loop;
919
 
920
      --  Fill in the spec information when relevant
921
 
922
      declare
923
         package Entity_Hash_Table is new
924
           GNAT.HTable.Simple_HTable
925
             (Header_Num => Entity_Hashed_Range,
926
              Element    => Scope_Index,
927
              No_Element => 0,
928
              Key        => Entity_Id,
929
              Hash       => Entity_Hash,
930
              Equal      => "=");
931
 
932
      begin
933
         --  Fill in the hash-table
934
 
935
         for S in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop
936
            declare
937
               Srec : Alfa_Scope_Record renames Alfa_Scope_Table.Table (S);
938
            begin
939
               Entity_Hash_Table.Set (Srec.Scope_Entity, S);
940
            end;
941
         end loop;
942
 
943
         --  Use the hash-table to locate spec entities
944
 
945
         for S in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop
946
            declare
947
               Srec : Alfa_Scope_Record renames Alfa_Scope_Table.Table (S);
948
 
949
               Spec_Entity : constant Entity_Id :=
950
                               Unique_Entity (Srec.Scope_Entity);
951
               Spec_Scope  : constant Scope_Index :=
952
                               Entity_Hash_Table.Get (Spec_Entity);
953
 
954
            begin
955
               --  Spec of generic may be missing, in which case Spec_Scope is
956
               --  zero.
957
 
958
               if Spec_Entity /= Srec.Scope_Entity
959
                 and then Spec_Scope /= 0
960
               then
961
                  Srec.Spec_File_Num :=
962
                    Alfa_Scope_Table.Table (Spec_Scope).File_Num;
963
                  Srec.Spec_Scope_Num :=
964
                    Alfa_Scope_Table.Table (Spec_Scope).Scope_Num;
965
               end if;
966
            end;
967
         end loop;
968
      end;
969
 
970
      --  Generate cross reference Alfa information
971
 
972
      Add_Alfa_Xrefs;
973
   end Collect_Alfa;
974
 
975
   -------------------------------
976
   -- Detect_And_Add_Alfa_Scope --
977
   -------------------------------
978
 
979
   procedure Detect_And_Add_Alfa_Scope (N : Node_Id) is
980
   begin
981
      if Nkind_In (N, N_Subprogram_Declaration,
982
                      N_Subprogram_Body,
983
                      N_Subprogram_Body_Stub,
984
                      N_Package_Declaration,
985
                      N_Package_Body)
986
      then
987
         Add_Alfa_Scope (N);
988
      end if;
989
   end Detect_And_Add_Alfa_Scope;
990
 
991
   -------------------------------------
992
   -- Enclosing_Subprogram_Or_Package --
993
   -------------------------------------
994
 
995
   function Enclosing_Subprogram_Or_Package (N : Node_Id) return Entity_Id is
996
      Result : Entity_Id;
997
 
998
   begin
999
      --  If N is the defining identifier for a subprogram, then return the
1000
      --  enclosing subprogram or package, not this subprogram.
1001
 
1002
      if Nkind_In (N, N_Defining_Identifier, N_Defining_Operator_Symbol)
1003
        and then Nkind (Parent (N)) in N_Subprogram_Specification
1004
      then
1005
         Result := Parent (Parent (Parent (N)));
1006
      else
1007
         Result := N;
1008
      end if;
1009
 
1010
      loop
1011
         exit when No (Result);
1012
 
1013
         case Nkind (Result) is
1014
            when N_Package_Specification =>
1015
               Result := Defining_Unit_Name (Result);
1016
               exit;
1017
 
1018
            when N_Package_Body =>
1019
               Result := Defining_Unit_Name (Result);
1020
               exit;
1021
 
1022
            when N_Subprogram_Specification =>
1023
               Result := Defining_Unit_Name (Result);
1024
               exit;
1025
 
1026
            when N_Subprogram_Declaration =>
1027
               Result := Defining_Unit_Name (Specification (Result));
1028
               exit;
1029
 
1030
            when N_Subprogram_Body =>
1031
               Result := Defining_Unit_Name (Specification (Result));
1032
               exit;
1033
 
1034
            --  The enclosing subprogram for a pre- or postconditions should be
1035
            --  the subprogram to which the pragma is attached. This is not
1036
            --  always the case in the AST, as the pragma may be declared after
1037
            --  the declaration of the subprogram. Return Empty in this case.
1038
 
1039
            when N_Pragma =>
1040
               if Get_Pragma_Id (Result) = Pragma_Precondition
1041
                    or else
1042
                  Get_Pragma_Id (Result) = Pragma_Postcondition
1043
               then
1044
                  return Empty;
1045
               else
1046
                  Result := Parent (Result);
1047
               end if;
1048
 
1049
            when others =>
1050
               Result := Parent (Result);
1051
         end case;
1052
      end loop;
1053
 
1054
      if Nkind (Result) = N_Defining_Program_Unit_Name then
1055
         Result := Defining_Identifier (Result);
1056
      end if;
1057
 
1058
      --  Do no return a scope without a proper location
1059
 
1060
      if Present (Result)
1061
        and then Sloc (Result) = No_Location
1062
      then
1063
         return Empty;
1064
      end if;
1065
 
1066
      return Result;
1067
   end Enclosing_Subprogram_Or_Package;
1068
 
1069
   -----------------
1070
   -- Entity_Hash --
1071
   -----------------
1072
 
1073
   function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range is
1074
   begin
1075
      return
1076
        Entity_Hashed_Range (E mod (Entity_Id (Entity_Hashed_Range'Last) + 1));
1077
   end Entity_Hash;
1078
 
1079
   --------------------------
1080
   -- Generate_Dereference --
1081
   --------------------------
1082
 
1083
   procedure Generate_Dereference
1084
     (N   : Node_Id;
1085
      Typ : Character := 'r')
1086
   is
1087
      Indx      : Nat;
1088
      Ref       : Source_Ptr;
1089
      Ref_Scope : Entity_Id;
1090
 
1091
   begin
1092
      Ref := Original_Location (Sloc (N));
1093
 
1094
      if Ref > No_Location then
1095
         Drefs.Increment_Last;
1096
         Indx := Drefs.Last;
1097
 
1098
         Ref_Scope := Enclosing_Subprogram_Or_Package (N);
1099
 
1100
         --  Entity is filled later on with the special "Heap" variable
1101
 
1102
         Drefs.Table (Indx).Key.Ent := Empty;
1103
 
1104
         Drefs.Table (Indx).Def := No_Location;
1105
         Drefs.Table (Indx).Key.Loc := Ref;
1106
         Drefs.Table (Indx).Key.Typ := Typ;
1107
 
1108
         --  It is as if the special "Heap" was defined in every scope where it
1109
         --  is referenced.
1110
 
1111
         Drefs.Table (Indx).Key.Eun := Get_Source_Unit (Ref);
1112
         Drefs.Table (Indx).Key.Lun := Get_Source_Unit (Ref);
1113
 
1114
         Drefs.Table (Indx).Key.Ref_Scope := Ref_Scope;
1115
         Drefs.Table (Indx).Key.Ent_Scope := Ref_Scope;
1116
         Drefs.Table (Indx).Ent_Scope_File := Get_Source_Unit (Ref_Scope);
1117
      end if;
1118
   end Generate_Dereference;
1119
 
1120
   ------------------------------------
1121
   -- Traverse_All_Compilation_Units --
1122
   ------------------------------------
1123
 
1124
   procedure Traverse_All_Compilation_Units (Process : Node_Processing) is
1125
   begin
1126
      for U in Units.First .. Last_Unit loop
1127
         Traverse_Compilation_Unit (Cunit (U), Process, Inside_Stubs => False);
1128
      end loop;
1129
   end Traverse_All_Compilation_Units;
1130
 
1131
   -------------------------------
1132
   -- Traverse_Compilation_Unit --
1133
   -------------------------------
1134
 
1135
   procedure Traverse_Compilation_Unit
1136
     (CU           : Node_Id;
1137
      Process      : Node_Processing;
1138
      Inside_Stubs : Boolean)
1139
   is
1140
      Lu : Node_Id;
1141
 
1142
   begin
1143
      --  Get Unit (checking case of subunit)
1144
 
1145
      Lu := Unit (CU);
1146
 
1147
      if Nkind (Lu) = N_Subunit then
1148
         Lu := Proper_Body (Lu);
1149
      end if;
1150
 
1151
      --  Call Process on all declarations
1152
 
1153
      if Nkind (Lu) in N_Declaration
1154
        or else Nkind (Lu) in N_Later_Decl_Item
1155
      then
1156
         Process (Lu);
1157
      end if;
1158
 
1159
      --  Traverse the unit
1160
 
1161
      if Nkind (Lu) = N_Subprogram_Body then
1162
         Traverse_Subprogram_Body (Lu, Process, Inside_Stubs);
1163
 
1164
      elsif Nkind (Lu) = N_Subprogram_Declaration then
1165
         null;
1166
 
1167
      elsif Nkind (Lu) = N_Package_Declaration then
1168
         Traverse_Package_Declaration (Lu, Process, Inside_Stubs);
1169
 
1170
      elsif Nkind (Lu) = N_Package_Body then
1171
         Traverse_Package_Body (Lu, Process, Inside_Stubs);
1172
 
1173
      --  ??? TBD
1174
 
1175
      elsif Nkind (Lu) = N_Generic_Package_Declaration then
1176
         null;
1177
 
1178
      --  ??? TBD
1179
 
1180
      elsif Nkind (Lu) in N_Generic_Instantiation then
1181
         null;
1182
 
1183
      --  All other cases of compilation units (e.g. renamings), are not
1184
      --  declarations.
1185
 
1186
      else
1187
         null;
1188
      end if;
1189
   end Traverse_Compilation_Unit;
1190
 
1191
   -----------------------------------------
1192
   -- Traverse_Declarations_Or_Statements --
1193
   -----------------------------------------
1194
 
1195
   procedure Traverse_Declarations_Or_Statements
1196
     (L            : List_Id;
1197
      Process      : Node_Processing;
1198
      Inside_Stubs : Boolean)
1199
   is
1200
      N : Node_Id;
1201
 
1202
   begin
1203
      --  Loop through statements or declarations
1204
 
1205
      N := First (L);
1206
      while Present (N) loop
1207
         --  Call Process on all declarations
1208
 
1209
         if Nkind (N) in N_Declaration
1210
              or else
1211
            Nkind (N) in N_Later_Decl_Item
1212
         then
1213
            Process (N);
1214
         end if;
1215
 
1216
         case Nkind (N) is
1217
 
1218
            --  Package declaration
1219
 
1220
            when N_Package_Declaration =>
1221
               Traverse_Package_Declaration (N, Process, Inside_Stubs);
1222
 
1223
            --  Generic package declaration ??? TBD
1224
 
1225
            when N_Generic_Package_Declaration =>
1226
               null;
1227
 
1228
            --  Package body
1229
 
1230
            when N_Package_Body =>
1231
               if Ekind (Defining_Entity (N)) /= E_Generic_Package then
1232
                  Traverse_Package_Body (N, Process, Inside_Stubs);
1233
               end if;
1234
 
1235
            when N_Package_Body_Stub =>
1236
               if Present (Library_Unit (N)) then
1237
                  declare
1238
                     Body_N : constant Node_Id := Get_Body_From_Stub (N);
1239
                  begin
1240
                     if Inside_Stubs
1241
                       and then
1242
                         Ekind (Defining_Entity (Body_N)) /= E_Generic_Package
1243
                     then
1244
                        Traverse_Package_Body (Body_N, Process, Inside_Stubs);
1245
                     end if;
1246
                  end;
1247
               end if;
1248
 
1249
            --  Subprogram declaration
1250
 
1251
            when N_Subprogram_Declaration =>
1252
               null;
1253
 
1254
            --  Generic subprogram declaration ??? TBD
1255
 
1256
            when N_Generic_Subprogram_Declaration =>
1257
               null;
1258
 
1259
            --  Subprogram body
1260
 
1261
            when N_Subprogram_Body =>
1262
               if not Is_Generic_Subprogram (Defining_Entity (N)) then
1263
                  Traverse_Subprogram_Body (N, Process, Inside_Stubs);
1264
               end if;
1265
 
1266
            when N_Subprogram_Body_Stub =>
1267
               if Present (Library_Unit (N)) then
1268
                  declare
1269
                     Body_N : constant Node_Id := Get_Body_From_Stub (N);
1270
                  begin
1271
                     if Inside_Stubs
1272
                       and then
1273
                         not Is_Generic_Subprogram (Defining_Entity (Body_N))
1274
                     then
1275
                        Traverse_Subprogram_Body
1276
                          (Body_N, Process, Inside_Stubs);
1277
                     end if;
1278
                  end;
1279
               end if;
1280
 
1281
            --  Block statement
1282
 
1283
            when N_Block_Statement =>
1284
               Traverse_Declarations_Or_Statements
1285
                 (Declarations (N), Process, Inside_Stubs);
1286
               Traverse_Handled_Statement_Sequence
1287
                 (Handled_Statement_Sequence (N), Process, Inside_Stubs);
1288
 
1289
            when N_If_Statement =>
1290
 
1291
               --  Traverse the statements in the THEN part
1292
 
1293
               Traverse_Declarations_Or_Statements
1294
                 (Then_Statements (N), Process, Inside_Stubs);
1295
 
1296
               --  Loop through ELSIF parts if present
1297
 
1298
               if Present (Elsif_Parts (N)) then
1299
                  declare
1300
                     Elif : Node_Id := First (Elsif_Parts (N));
1301
 
1302
                  begin
1303
                     while Present (Elif) loop
1304
                        Traverse_Declarations_Or_Statements
1305
                          (Then_Statements (Elif), Process, Inside_Stubs);
1306
                        Next (Elif);
1307
                     end loop;
1308
                  end;
1309
               end if;
1310
 
1311
               --  Finally traverse the ELSE statements if present
1312
 
1313
               Traverse_Declarations_Or_Statements
1314
                 (Else_Statements (N), Process, Inside_Stubs);
1315
 
1316
            --  Case statement
1317
 
1318
            when N_Case_Statement =>
1319
 
1320
               --  Process case branches
1321
 
1322
               declare
1323
                  Alt : Node_Id;
1324
               begin
1325
                  Alt := First (Alternatives (N));
1326
                  while Present (Alt) loop
1327
                     Traverse_Declarations_Or_Statements
1328
                       (Statements (Alt), Process, Inside_Stubs);
1329
                     Next (Alt);
1330
                  end loop;
1331
               end;
1332
 
1333
            --  Extended return statement
1334
 
1335
            when N_Extended_Return_Statement =>
1336
               Traverse_Handled_Statement_Sequence
1337
                 (Handled_Statement_Sequence (N), Process, Inside_Stubs);
1338
 
1339
            --  Loop
1340
 
1341
            when N_Loop_Statement =>
1342
               Traverse_Declarations_Or_Statements
1343
                 (Statements (N), Process, Inside_Stubs);
1344
 
1345
            when others =>
1346
               null;
1347
         end case;
1348
 
1349
         Next (N);
1350
      end loop;
1351
   end Traverse_Declarations_Or_Statements;
1352
 
1353
   -----------------------------------------
1354
   -- Traverse_Handled_Statement_Sequence --
1355
   -----------------------------------------
1356
 
1357
   procedure Traverse_Handled_Statement_Sequence
1358
     (N            : Node_Id;
1359
      Process      : Node_Processing;
1360
      Inside_Stubs : Boolean)
1361
   is
1362
      Handler : Node_Id;
1363
 
1364
   begin
1365
      if Present (N) then
1366
         Traverse_Declarations_Or_Statements
1367
           (Statements (N), Process, Inside_Stubs);
1368
 
1369
         if Present (Exception_Handlers (N)) then
1370
            Handler := First (Exception_Handlers (N));
1371
            while Present (Handler) loop
1372
               Traverse_Declarations_Or_Statements
1373
                 (Statements (Handler), Process, Inside_Stubs);
1374
               Next (Handler);
1375
            end loop;
1376
         end if;
1377
      end if;
1378
   end Traverse_Handled_Statement_Sequence;
1379
 
1380
   ---------------------------
1381
   -- Traverse_Package_Body --
1382
   ---------------------------
1383
 
1384
   procedure Traverse_Package_Body
1385
     (N            : Node_Id;
1386
      Process      : Node_Processing;
1387
      Inside_Stubs : Boolean) is
1388
   begin
1389
      Traverse_Declarations_Or_Statements
1390
        (Declarations (N), Process, Inside_Stubs);
1391
      Traverse_Handled_Statement_Sequence
1392
        (Handled_Statement_Sequence (N), Process, Inside_Stubs);
1393
   end Traverse_Package_Body;
1394
 
1395
   ----------------------------------
1396
   -- Traverse_Package_Declaration --
1397
   ----------------------------------
1398
 
1399
   procedure Traverse_Package_Declaration
1400
     (N            : Node_Id;
1401
      Process      : Node_Processing;
1402
      Inside_Stubs : Boolean)
1403
   is
1404
      Spec : constant Node_Id := Specification (N);
1405
   begin
1406
      Traverse_Declarations_Or_Statements
1407
        (Visible_Declarations (Spec), Process, Inside_Stubs);
1408
      Traverse_Declarations_Or_Statements
1409
        (Private_Declarations (Spec), Process, Inside_Stubs);
1410
   end Traverse_Package_Declaration;
1411
 
1412
   ------------------------------
1413
   -- Traverse_Subprogram_Body --
1414
   ------------------------------
1415
 
1416
   procedure Traverse_Subprogram_Body
1417
     (N            : Node_Id;
1418
      Process      : Node_Processing;
1419
      Inside_Stubs : Boolean) is
1420
   begin
1421
      Traverse_Declarations_Or_Statements
1422
        (Declarations (N), Process, Inside_Stubs);
1423
      Traverse_Handled_Statement_Sequence
1424
        (Handled_Statement_Sequence (N), Process, Inside_Stubs);
1425
   end Traverse_Subprogram_Body;
1426
 
1427
end Alfa;

powered by: WebSVN 2.1.0

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