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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [binde.adb] - Blame information for rev 859

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
--                                B I N D E                                 --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-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.  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 Binderr;  use Binderr;
27
with Butil;    use Butil;
28
with Debug;    use Debug;
29
with Fname;    use Fname;
30
with Namet;    use Namet;
31
with Opt;      use Opt;
32
with Osint;
33
with Output;   use Output;
34
with Targparm; use Targparm;
35
 
36
with System.Case_Util; use System.Case_Util;
37
 
38
package body Binde is
39
 
40
   --  The following data structures are used to represent the graph that is
41
   --  used to determine the elaboration order (using a topological sort).
42
 
43
   --  The following structures are used to record successors. If A is a
44
   --  successor of B in this table, it means that A must be elaborated
45
   --  before B is elaborated.
46
 
47
   type Successor_Id is new Nat;
48
   --  Identification of single successor entry
49
 
50
   No_Successor : constant Successor_Id := 0;
51
   --  Used to indicate end of list of successors
52
 
53
   type Elab_All_Id is new Nat;
54
   --  Identification of Elab_All entry link
55
 
56
   No_Elab_All_Link : constant Elab_All_Id := 0;
57
   --  Used to indicate end of list
58
 
59
   --  Succ_Reason indicates the reason for a particular elaboration link
60
 
61
   type Succ_Reason is
62
     (Withed,
63
      --  After directly with's Before, so the spec of Before must be
64
      --  elaborated before After is elaborated.
65
 
66
      Elab,
67
      --  After directly mentions Before in a pragma Elaborate, so the
68
      --  body of Before must be elaborate before After is elaborated.
69
 
70
      Elab_All,
71
      --  After either mentions Before directly in a pragma Elaborate_All,
72
      --  or mentions a third unit, X, which itself requires that Before be
73
      --  elaborated before unit X is elaborated. The Elab_All_Link list
74
      --  traces the dependencies in the latter case.
75
 
76
      Elab_All_Desirable,
77
      --  This is just like Elab_All, except that the elaborate all was not
78
      --  explicitly present in the source, but rather was created by the
79
      --  front end, which decided that it was "desirable".
80
 
81
      Elab_Desirable,
82
      --  This is just like Elab, except that the elaborate was not
83
      --  explicitly present in the source, but rather was created by the
84
      --  front end, which decided that it was "desirable".
85
 
86
      Spec_First);
87
      --  After is a body, and Before is the corresponding spec
88
 
89
   --  Successor_Link contains the information for one link
90
 
91
   type Successor_Link is record
92
      Before : Unit_Id;
93
      --  Predecessor unit
94
 
95
      After : Unit_Id;
96
      --  Successor unit
97
 
98
      Next : Successor_Id;
99
      --  Next successor on this list
100
 
101
      Reason : Succ_Reason;
102
      --  Reason for this link
103
 
104
      Elab_Body : Boolean;
105
      --  Set True if this link is needed for the special Elaborate_Body
106
      --  processing described below.
107
 
108
      Reason_Unit : Unit_Id;
109
      --  For Reason = Elab, or Elab_All or Elab_Desirable, records the unit
110
      --  containing the pragma leading to the link.
111
 
112
      Elab_All_Link : Elab_All_Id;
113
      --  If Reason = Elab_All or Elab_Desirable, then this points to the
114
      --  first elment in a list of Elab_All entries that record the with
115
      --  chain leading resulting in this particular dependency.
116
 
117
   end record;
118
 
119
   --  Note on handling of Elaborate_Body. Basically, if we have a pragma
120
   --  Elaborate_Body in a unit, it means that the spec and body have to
121
   --  be handled as a single entity from the point of view of determining
122
   --  an elaboration order. What we do is to essentially remove the body
123
   --  from consideration completely, and transfer all its links (other
124
   --  than the spec link) to the spec. Then when then the spec gets chosen,
125
   --  we choose the body right afterwards. We mark the links that get moved
126
   --  from the body to the spec by setting their Elab_Body flag True, so
127
   --  that we can understand what is going on!
128
 
129
   Succ_First : constant := 1;
130
 
131
   package Succ is new Table.Table (
132
     Table_Component_Type => Successor_Link,
133
     Table_Index_Type     => Successor_Id,
134
     Table_Low_Bound      => Succ_First,
135
     Table_Initial        => 500,
136
     Table_Increment      => 200,
137
     Table_Name           => "Succ");
138
 
139
   --  For the case of Elaborate_All, the following table is used to record
140
   --  chains of with relationships that lead to the Elab_All link. These
141
   --  are used solely for diagnostic purposes
142
 
143
   type Elab_All_Entry is record
144
      Needed_By : Unit_Name_Type;
145
      --  Name of unit from which referencing unit was with'ed or otherwise
146
      --  needed as a result of Elaborate_All or Elaborate_Desirable.
147
 
148
      Next_Elab : Elab_All_Id;
149
      --  Link to next entry on chain (No_Elab_All_Link marks end of list)
150
   end record;
151
 
152
   package Elab_All_Entries is new Table.Table (
153
     Table_Component_Type => Elab_All_Entry,
154
     Table_Index_Type     => Elab_All_Id,
155
     Table_Low_Bound      => 1,
156
     Table_Initial        => 2000,
157
     Table_Increment      => 200,
158
     Table_Name           => "Elab_All_Entries");
159
 
160
   --  A Unit_Node record is built for each active unit
161
 
162
   type Unit_Node_Record is record
163
 
164
      Successors : Successor_Id;
165
      --  Pointer to list of links for successor nodes
166
 
167
      Num_Pred : Int;
168
      --  Number of predecessors for this unit. Normally non-negative, but
169
      --  can go negative in the case of units chosen by the diagnose error
170
      --  procedure (when cycles are being removed from the graph).
171
 
172
      Nextnp : Unit_Id;
173
      --  Forward pointer for list of units with no predecessors
174
 
175
      Elab_Order : Nat;
176
      --  Position in elaboration order (zero = not placed yet)
177
 
178
      Visited : Boolean;
179
      --  Used in computing transitive closure for elaborate all and
180
      --  also in locating cycles and paths in the diagnose routines.
181
 
182
      Elab_Position : Natural;
183
      --  Initialized to zero. Set non-zero when a unit is chosen and
184
      --  placed in the elaboration order. The value represents the
185
      --  ordinal position in the elaboration order.
186
 
187
   end record;
188
 
189
   package UNR is new Table.Table (
190
     Table_Component_Type => Unit_Node_Record,
191
     Table_Index_Type     => Unit_Id,
192
     Table_Low_Bound      => First_Unit_Entry,
193
     Table_Initial        => 500,
194
     Table_Increment      => 200,
195
     Table_Name           => "UNR");
196
 
197
   No_Pred : Unit_Id;
198
   --  Head of list of items with no predecessors
199
 
200
   Num_Left : Int;
201
   --  Number of entries not yet dealt with
202
 
203
   Cur_Unit : Unit_Id;
204
   --  Current unit, set by Gather_Dependencies, and picked up in Build_Link
205
   --  to set the Reason_Unit field of the created dependency link.
206
 
207
   Num_Chosen : Natural := 0;
208
   --  Number of units chosen in the elaboration order so far
209
 
210
   -----------------------
211
   -- Local Subprograms --
212
   -----------------------
213
 
214
   function Better_Choice (U1, U2 : Unit_Id) return Boolean;
215
   --  U1 and U2 are both permitted candidates for selection as the next unit
216
   --  to be elaborated. This function determines whether U1 is a better choice
217
   --  than U2, i.e. should be elaborated in preference to U2, based on a set
218
   --  of heuristics that establish a friendly and predictable order (see body
219
   --  for details). The result is True if U1 is a better choice than U2, and
220
   --  False if it is a worse choice, or there is no preference between them.
221
 
222
   procedure Build_Link
223
     (Before : Unit_Id;
224
      After  : Unit_Id;
225
      R      : Succ_Reason;
226
      Ea_Id  : Elab_All_Id := No_Elab_All_Link);
227
   --  Establish a successor link, Before must be elaborated before After,
228
   --  and the reason for the link is R. Ea_Id is the contents to be placed
229
   --  in the Elab_All_Link of the entry.
230
 
231
   procedure Choose (Chosen : Unit_Id);
232
   --  Chosen is the next entry chosen in the elaboration order. This
233
   --  procedure updates all data structures appropriately.
234
 
235
   function Corresponding_Body (U : Unit_Id) return Unit_Id;
236
   pragma Inline (Corresponding_Body);
237
   --  Given a unit which is a spec for which there is a separate body,
238
   --  return the unit id of the body. It is an error to call this routine
239
   --  with a unit that is not a spec, or which does not have a separate body.
240
 
241
   function Corresponding_Spec (U : Unit_Id) return Unit_Id;
242
   pragma Inline (Corresponding_Spec);
243
   --  Given a unit which is a body for which there is a separate spec,
244
   --  return the unit id of the spec. It is an error to call this routine
245
   --  with a unit that is not a body, or which does not have a separate spec.
246
 
247
   procedure Diagnose_Elaboration_Problem;
248
   --  Called when no elaboration order can be found. Outputs an appropriate
249
   --  diagnosis of the problem, and then abandons the bind.
250
 
251
   procedure Elab_All_Links
252
     (Before : Unit_Id;
253
      After  : Unit_Id;
254
      Reason : Succ_Reason;
255
      Link   : Elab_All_Id);
256
   --  Used to compute the transitive closure of elaboration links for an
257
   --  Elaborate_All pragma (Reason = Elab_All) or for an indication of
258
   --  Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has
259
   --  a pragma Elaborate_All or the front end has determined that a reference
260
   --  probably requires Elaborate_All is required, and unit Before must be
261
   --  previously elaborated. First a link is built making sure that unit
262
   --  Before is elaborated before After, then a recursive call ensures that
263
   --  we also build links for any units needed by Before (i.e. these units
264
   --  must/should also be elaborated before After). Link is used to build
265
   --  a chain of Elab_All_Entries to explain the reason for a link. The
266
   --  value passed is the chain so far.
267
 
268
   procedure Elab_Error_Msg (S : Successor_Id);
269
   --  Given a successor link, outputs an error message of the form
270
   --  "$ must be elaborated before $ ..." where ... is the reason.
271
 
272
   procedure Gather_Dependencies;
273
   --  Compute dependencies, building the Succ and UNR tables
274
 
275
   function Is_Body_Unit (U : Unit_Id) return Boolean;
276
   pragma Inline (Is_Body_Unit);
277
   --  Determines if given unit is a body
278
 
279
   function Is_Waiting_Body (U : Unit_Id) return Boolean;
280
   pragma Inline (Is_Waiting_Body);
281
   --  Determines if U is a waiting body, defined as a body which has
282
   --  not been elaborated, but whose spec has been elaborated.
283
 
284
   function Make_Elab_Entry
285
     (Unam : Unit_Name_Type;
286
      Link : Elab_All_Id) return Elab_All_Id;
287
   --  Make an Elab_All_Entries table entry with the given Unam and Link
288
 
289
   function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
290
   --  This function uses the Info field set in the names table to obtain
291
   --  the unit Id of a unit, given its name id value.
292
 
293
   function Worse_Choice (U1, U2 : Unit_Id) return Boolean;
294
   --  This is like Better_Choice, and has the same interface, but returns
295
   --  true if U1 is a worse choice than U2 in the sense of the -h (horrible
296
   --  elaboration order) switch. We still have to obey Ada rules, so it is
297
   --  not quite the direct inverse of Better_Choice.
298
 
299
   procedure Write_Dependencies;
300
   --  Write out dependencies (called only if appropriate option is set)
301
 
302
   procedure Write_Elab_All_Chain (S : Successor_Id);
303
   --  If the reason for the link S is Elaborate_All or Elaborate_Desirable,
304
   --  then this routine will output the "needed by" explanation chain.
305
 
306
   -------------------
307
   -- Better_Choice --
308
   -------------------
309
 
310
   function Better_Choice (U1, U2 : Unit_Id) return Boolean is
311
      UT1 : Unit_Record renames Units.Table (U1);
312
      UT2 : Unit_Record renames Units.Table (U2);
313
 
314
   begin
315
      if Debug_Flag_B then
316
         Write_Str ("Better_Choice (");
317
         Write_Unit_Name (UT1.Uname);
318
         Write_Str (", ");
319
         Write_Unit_Name (UT2.Uname);
320
         Write_Line (")");
321
      end if;
322
 
323
      --  Note: the checks here are applied in sequence, and the ordering is
324
      --  significant (i.e. the more important criteria are applied first).
325
 
326
      --  Prefer a waiting body to any other case
327
 
328
      if Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
329
         if Debug_Flag_B then
330
            Write_Line ("  True: u1 is waiting body, u2 is not");
331
         end if;
332
 
333
         return True;
334
 
335
      elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
336
         if Debug_Flag_B then
337
            Write_Line ("  False: u2 is waiting body, u1 is not");
338
         end if;
339
 
340
         return False;
341
 
342
      --  Prefer a predefined unit to a non-predefined unit
343
 
344
      elsif UT1.Predefined and then not UT2.Predefined then
345
         if Debug_Flag_B then
346
            Write_Line ("  True: u1 is predefined, u2 is not");
347
         end if;
348
 
349
         return True;
350
 
351
      elsif UT2.Predefined and then not UT1.Predefined then
352
         if Debug_Flag_B then
353
            Write_Line ("  False: u2 is predefined, u1 is not");
354
         end if;
355
 
356
         return False;
357
 
358
      --  Prefer an internal unit to a non-internal unit
359
 
360
      elsif UT1.Internal and then not UT2.Internal then
361
         if Debug_Flag_B then
362
            Write_Line ("  True: u1 is internal, u2 is not");
363
         end if;
364
         return True;
365
 
366
      elsif UT2.Internal and then not UT1.Internal then
367
         if Debug_Flag_B then
368
            Write_Line ("  False: u2 is internal, u1 is not");
369
         end if;
370
 
371
         return False;
372
 
373
      --  Prefer a body to a spec
374
 
375
      elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
376
         if Debug_Flag_B then
377
            Write_Line ("  True: u1 is body, u2 is not");
378
         end if;
379
 
380
         return True;
381
 
382
      elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
383
         if Debug_Flag_B then
384
            Write_Line ("  False: u2 is body, u1 is not");
385
         end if;
386
 
387
         return False;
388
 
389
      --  If both are waiting bodies, then prefer the one whose spec is
390
      --  more recently elaborated. Consider the following:
391
 
392
      --     spec of A
393
      --     spec of B
394
      --     body of A or B?
395
 
396
      --  The normal waiting body preference would have placed the body of
397
      --  A before the spec of B if it could. Since it could not, there it
398
      --  must be the case that A depends on B. It is therefore a good idea
399
      --  to put the body of B first.
400
 
401
      elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
402
         declare
403
            Result : constant Boolean :=
404
                       UNR.Table (Corresponding_Spec (U1)).Elab_Position >
405
                       UNR.Table (Corresponding_Spec (U2)).Elab_Position;
406
         begin
407
            if Debug_Flag_B then
408
               if Result then
409
                  Write_Line ("  True: based on waiting body elab positions");
410
               else
411
                  Write_Line ("  False: based on waiting body elab positions");
412
               end if;
413
            end if;
414
 
415
            return Result;
416
         end;
417
      end if;
418
 
419
      --  Remaining choice rules are disabled by Debug flag -do
420
 
421
      if not Debug_Flag_O then
422
 
423
         --  The following deal with the case of specs which have been marked
424
         --  as Elaborate_Body_Desirable. We generally want to delay these
425
         --  specs as long as possible, so that the bodies have a better chance
426
         --  of being elaborated closer to the specs.
427
 
428
         --  If we have two units, one of which is a spec for which this flag
429
         --  is set, and the other is not, we prefer to delay the spec for
430
         --  which the flag is set.
431
 
432
         if not UT1.Elaborate_Body_Desirable
433
           and then UT2.Elaborate_Body_Desirable
434
         then
435
            if Debug_Flag_B then
436
               Write_Line ("  True: u1 is elab body desirable, u2 is not");
437
            end if;
438
 
439
            return True;
440
 
441
         elsif not UT2.Elaborate_Body_Desirable
442
           and then UT1.Elaborate_Body_Desirable
443
         then
444
            if Debug_Flag_B then
445
               Write_Line ("  False: u1 is elab body desirable, u2 is not");
446
            end if;
447
 
448
            return False;
449
 
450
            --  If we have two specs that are both marked as Elaborate_Body
451
            --  desirable, we prefer the one whose body is nearer to being able
452
            --  to be elaborated, based on the Num_Pred count. This helps to
453
            --  ensure bodies are as close to specs as possible.
454
 
455
         elsif UT1.Elaborate_Body_Desirable
456
           and then UT2.Elaborate_Body_Desirable
457
         then
458
            declare
459
               Result : constant Boolean :=
460
                          UNR.Table (Corresponding_Body (U1)).Num_Pred <
461
                          UNR.Table (Corresponding_Body (U2)).Num_Pred;
462
            begin
463
               if Debug_Flag_B then
464
                  if Result then
465
                     Write_Line ("  True based on Num_Pred compare");
466
                  else
467
                     Write_Line ("  False based on Num_Pred compare");
468
                  end if;
469
               end if;
470
 
471
               return Result;
472
            end;
473
         end if;
474
      end if;
475
 
476
      --  If we fall through, it means that no preference rule applies, so we
477
      --  use alphabetical order to at least give a deterministic result.
478
 
479
      if Debug_Flag_B then
480
         Write_Line ("  choose on alpha order");
481
      end if;
482
 
483
      return Uname_Less (UT1.Uname, UT2.Uname);
484
   end Better_Choice;
485
 
486
   ----------------
487
   -- Build_Link --
488
   ----------------
489
 
490
   procedure Build_Link
491
     (Before : Unit_Id;
492
      After  : Unit_Id;
493
      R      : Succ_Reason;
494
      Ea_Id  : Elab_All_Id := No_Elab_All_Link)
495
   is
496
      Cspec : Unit_Id;
497
 
498
   begin
499
      Succ.Increment_Last;
500
      Succ.Table (Succ.Last).Before          := Before;
501
      Succ.Table (Succ.Last).Next            := UNR.Table (Before).Successors;
502
      UNR.Table (Before).Successors          := Succ.Last;
503
      Succ.Table (Succ.Last).Reason          := R;
504
      Succ.Table (Succ.Last).Reason_Unit     := Cur_Unit;
505
      Succ.Table (Succ.Last).Elab_All_Link   := Ea_Id;
506
 
507
      --  Deal with special Elab_Body case. If the After of this link is
508
      --  a body whose spec has Elaborate_All set, and this is not the link
509
      --  directly from the body to the spec, then we make the After of the
510
      --  link reference its spec instead, marking the link appropriately.
511
 
512
      if Units.Table (After).Utype = Is_Body then
513
         Cspec := Corresponding_Spec (After);
514
 
515
         if Units.Table (Cspec).Elaborate_Body
516
           and then Cspec /= Before
517
         then
518
            Succ.Table (Succ.Last).After     := Cspec;
519
            Succ.Table (Succ.Last).Elab_Body := True;
520
            UNR.Table (Cspec).Num_Pred       := UNR.Table (Cspec).Num_Pred + 1;
521
            return;
522
         end if;
523
      end if;
524
 
525
      --  Fall through on normal case
526
 
527
      Succ.Table (Succ.Last).After           := After;
528
      Succ.Table (Succ.Last).Elab_Body       := False;
529
      UNR.Table (After).Num_Pred             := UNR.Table (After).Num_Pred + 1;
530
   end Build_Link;
531
 
532
   ------------
533
   -- Choose --
534
   ------------
535
 
536
   procedure Choose (Chosen : Unit_Id) is
537
      S : Successor_Id;
538
      U : Unit_Id;
539
 
540
   begin
541
      if Debug_Flag_C then
542
         Write_Str ("Choosing Unit ");
543
         Write_Unit_Name (Units.Table (Chosen).Uname);
544
         Write_Eol;
545
      end if;
546
 
547
      --  Add to elaboration order. Note that units having no elaboration
548
      --  code are not treated specially yet. The special casing of this
549
      --  is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile
550
      --  we need them here, because the object file list is also driven
551
      --  by the contents of the Elab_Order table.
552
 
553
      Elab_Order.Increment_Last;
554
      Elab_Order.Table (Elab_Order.Last) := Chosen;
555
 
556
      --  Remove from No_Pred list. This is a little inefficient and may
557
      --  be we should doubly link the list, but it will do for now!
558
 
559
      if No_Pred = Chosen then
560
         No_Pred := UNR.Table (Chosen).Nextnp;
561
 
562
      else
563
         --  Note that we just ignore the situation where it does not
564
         --  appear in the No_Pred list, this happens in calls from the
565
         --  Diagnose_Elaboration_Problem routine, where cycles are being
566
         --  removed arbitrarily from the graph.
567
 
568
         U := No_Pred;
569
         while U /= No_Unit_Id loop
570
            if UNR.Table (U).Nextnp = Chosen then
571
               UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp;
572
               exit;
573
            end if;
574
 
575
            U := UNR.Table (U).Nextnp;
576
         end loop;
577
      end if;
578
 
579
      --  For all successors, decrement the number of predecessors, and
580
      --  if it becomes zero, then add to no predecessor list.
581
 
582
      S := UNR.Table (Chosen).Successors;
583
      while S /= No_Successor loop
584
         U := Succ.Table (S).After;
585
         UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1;
586
 
587
         if Debug_Flag_N then
588
            Write_Str ("  decrementing Num_Pred for unit ");
589
            Write_Unit_Name (Units.Table (U).Uname);
590
            Write_Str (" new value = ");
591
            Write_Int (Int (UNR.Table (U).Num_Pred));
592
            Write_Eol;
593
         end if;
594
 
595
         if UNR.Table (U).Num_Pred = 0 then
596
            UNR.Table (U).Nextnp := No_Pred;
597
            No_Pred := U;
598
         end if;
599
 
600
         S := Succ.Table (S).Next;
601
      end loop;
602
 
603
      --  All done, adjust number of units left count and set elaboration pos
604
 
605
      Num_Left := Num_Left - 1;
606
      Num_Chosen := Num_Chosen + 1;
607
      UNR.Table (Chosen).Elab_Position := Num_Chosen;
608
      Units.Table (Chosen).Elab_Position := Num_Chosen;
609
 
610
      --  If we just chose a spec with Elaborate_Body set, then we
611
      --  must immediately elaborate the body, before any other units.
612
 
613
      if Units.Table (Chosen).Elaborate_Body then
614
 
615
         --  If the unit is a spec only, then there is no body. This is a bit
616
         --  odd given that Elaborate_Body is here, but it is valid in an
617
         --  RCI unit, where we only have the interface in the stub bind.
618
 
619
         if Units.Table (Chosen).Utype = Is_Spec_Only
620
           and then Units.Table (Chosen).RCI
621
         then
622
            null;
623
         else
624
            Choose (Corresponding_Body (Chosen));
625
         end if;
626
      end if;
627
   end Choose;
628
 
629
   ------------------------
630
   -- Corresponding_Body --
631
   ------------------------
632
 
633
   --  Currently if the body and spec are separate, then they appear as
634
   --  two separate units in the same ALI file, with the body appearing
635
   --  first and the spec appearing second.
636
 
637
   function Corresponding_Body (U : Unit_Id) return Unit_Id is
638
   begin
639
      pragma Assert (Units.Table (U).Utype = Is_Spec);
640
      return U - 1;
641
   end Corresponding_Body;
642
 
643
   ------------------------
644
   -- Corresponding_Spec --
645
   ------------------------
646
 
647
   --  Currently if the body and spec are separate, then they appear as
648
   --  two separate units in the same ALI file, with the body appearing
649
   --  first and the spec appearing second.
650
 
651
   function Corresponding_Spec (U : Unit_Id) return Unit_Id is
652
   begin
653
      pragma Assert (Units.Table (U).Utype = Is_Body);
654
      return U + 1;
655
   end Corresponding_Spec;
656
 
657
   ----------------------------------
658
   -- Diagnose_Elaboration_Problem --
659
   ----------------------------------
660
 
661
   procedure Diagnose_Elaboration_Problem is
662
 
663
      function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean;
664
      --  Recursive routine used to find a path from node Ufrom to node Uto.
665
      --  If a path exists, returns True and outputs an appropriate set of
666
      --  error messages giving the path. Also calls Choose for each of the
667
      --  nodes so that they get removed from the remaining set. There are
668
      --  two cases of calls, either Ufrom = Uto for an attempt to find a
669
      --  cycle, or Ufrom is a spec and Uto the corresponding body for the
670
      --  case of an unsatisfiable Elaborate_Body pragma. ML is the minimum
671
      --  acceptable length for a path.
672
 
673
      ---------------
674
      -- Find_Path --
675
      ---------------
676
 
677
      function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is
678
 
679
         function Find_Link (U : Unit_Id; PL : Nat) return Boolean;
680
         --  This is the inner recursive routine, it determines if a path
681
         --  exists from U to Uto, and if so returns True and outputs the
682
         --  appropriate set of error messages. PL is the path length
683
 
684
         ---------------
685
         -- Find_Link --
686
         ---------------
687
 
688
         function Find_Link (U : Unit_Id; PL : Nat) return Boolean is
689
            S : Successor_Id;
690
 
691
         begin
692
            --  Recursion ends if we are at terminating node and the path
693
            --  is sufficiently long, generate error message and return True.
694
 
695
            if U = Uto and then PL >= ML then
696
               Choose (U);
697
               return True;
698
 
699
            --  All done if already visited, otherwise mark as visited
700
 
701
            elsif UNR.Table (U).Visited then
702
               return False;
703
 
704
            --  Otherwise mark as visited and look at all successors
705
 
706
            else
707
               UNR.Table (U).Visited := True;
708
 
709
               S := UNR.Table (U).Successors;
710
               while S /= No_Successor loop
711
                  if Find_Link (Succ.Table (S).After, PL + 1) then
712
                     Elab_Error_Msg (S);
713
                     Choose (U);
714
                     return True;
715
                  end if;
716
 
717
                  S := Succ.Table (S).Next;
718
               end loop;
719
 
720
               --  Falling through means this does not lead to a path
721
 
722
               return False;
723
            end if;
724
         end Find_Link;
725
 
726
      --  Start of processing for Find_Path
727
 
728
      begin
729
         --  Initialize all non-chosen nodes to not visisted yet
730
 
731
         for U in Units.First .. Units.Last loop
732
            UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0;
733
         end loop;
734
 
735
         --  Now try to find the path
736
 
737
         return Find_Link (Ufrom, 0);
738
      end Find_Path;
739
 
740
   --  Start of processing for Diagnose_Elaboration_Error
741
 
742
   begin
743
      Set_Standard_Error;
744
 
745
      --  Output state of things if debug flag N set
746
 
747
      if Debug_Flag_N then
748
         declare
749
            NP : Int;
750
 
751
         begin
752
            Write_Eol;
753
            Write_Eol;
754
            Write_Str ("Diagnose_Elaboration_Problem called");
755
            Write_Eol;
756
            Write_Str ("List of remaining unchosen units and predecessors");
757
            Write_Eol;
758
 
759
            for U in Units.First .. Units.Last loop
760
               if UNR.Table (U).Elab_Position = 0 then
761
                  NP := UNR.Table (U).Num_Pred;
762
                  Write_Eol;
763
                  Write_Str ("  Unchosen unit: #");
764
                  Write_Int (Int (U));
765
                  Write_Str ("  ");
766
                  Write_Unit_Name (Units.Table (U).Uname);
767
                  Write_Str (" (Num_Pred = ");
768
                  Write_Int (NP);
769
                  Write_Char (')');
770
                  Write_Eol;
771
 
772
                  if NP = 0 then
773
                     if Units.Table (U).Elaborate_Body then
774
                        Write_Str
775
                          ("    (not chosen because of Elaborate_Body)");
776
                        Write_Eol;
777
                     else
778
                        Write_Str ("  ****************** why not chosen?");
779
                        Write_Eol;
780
                     end if;
781
                  end if;
782
 
783
                  --  Search links list to find unchosen predecessors
784
 
785
                  for S in Succ.First .. Succ.Last loop
786
                     declare
787
                        SL : Successor_Link renames Succ.Table (S);
788
 
789
                     begin
790
                        if SL.After = U
791
                          and then UNR.Table (SL.Before).Elab_Position = 0
792
                        then
793
                           Write_Str ("    unchosen predecessor: #");
794
                           Write_Int (Int (SL.Before));
795
                           Write_Str ("  ");
796
                           Write_Unit_Name (Units.Table (SL.Before).Uname);
797
                           Write_Eol;
798
                           NP := NP - 1;
799
                        end if;
800
                     end;
801
                  end loop;
802
 
803
                  if NP /= 0 then
804
                     Write_Str ("  **************** Num_Pred value wrong!");
805
                     Write_Eol;
806
                  end if;
807
               end if;
808
            end loop;
809
         end;
810
      end if;
811
 
812
      --  Output the header for the error, and manually increment the
813
      --  error count. We are using Error_Msg_Output rather than Error_Msg
814
      --  here for two reasons:
815
 
816
      --    This is really only one error, not one for each line
817
      --    We want this output on standard output since it is voluminous
818
 
819
      --  But we do need to deal with the error count manually in this case
820
 
821
      Errors_Detected := Errors_Detected + 1;
822
      Error_Msg_Output ("elaboration circularity detected", Info => False);
823
 
824
      --  Try to find cycles starting with any of the remaining nodes that have
825
      --  not yet been chosen. There must be at least one (there is some reason
826
      --  we are being called!)
827
 
828
      for U in Units.First .. Units.Last loop
829
         if UNR.Table (U).Elab_Position = 0 then
830
            if Find_Path (U, U, 1) then
831
               raise Unrecoverable_Error;
832
            end if;
833
         end if;
834
      end loop;
835
 
836
      --  We should never get here, since we were called for some reason,
837
      --  and we should have found and eliminated at least one bad path.
838
 
839
      raise Program_Error;
840
   end Diagnose_Elaboration_Problem;
841
 
842
   --------------------
843
   -- Elab_All_Links --
844
   --------------------
845
 
846
   procedure Elab_All_Links
847
     (Before : Unit_Id;
848
      After  : Unit_Id;
849
      Reason : Succ_Reason;
850
      Link   : Elab_All_Id)
851
   is
852
   begin
853
      if UNR.Table (Before).Visited then
854
         return;
855
      end if;
856
 
857
      --  Build the direct link for Before
858
 
859
      UNR.Table (Before).Visited := True;
860
      Build_Link (Before, After, Reason, Link);
861
 
862
      --  Process all units with'ed by Before recursively
863
 
864
      for W in
865
        Units.Table (Before).First_With .. Units.Table (Before).Last_With
866
      loop
867
         --  Skip if this with is an interface to a stand-alone library.
868
         --  Skip also if no ALI file for this WITH, happens for language
869
         --  defined generics while bootstrapping the compiler (see body of
870
         --  Lib.Writ.Write_With_Lines). Finally, skip if it is a limited
871
         --  with clause, which does not impose an elaboration link.
872
 
873
         if not Withs.Table (W).SAL_Interface
874
           and then Withs.Table (W).Afile /= No_File
875
           and then not Withs.Table (W).Limited_With
876
         then
877
            declare
878
               Info : constant Int :=
879
                        Get_Name_Table_Info
880
                          (Withs.Table (W).Uname);
881
 
882
            begin
883
               --  If the unit is unknown, for some unknown reason, fail
884
               --  graciously explaining that the unit is unknown. Without
885
               --  this check, gnatbind will crash in Unit_Id_Of.
886
 
887
               if Info = 0 or else Unit_Id (Info) = No_Unit_Id then
888
                  declare
889
                     Withed       : String :=
890
                                      Get_Name_String (Withs.Table (W).Uname);
891
                     Last_Withed  : Natural := Withed'Last;
892
                     Withing      : String :=
893
                                      Get_Name_String
894
                                        (Units.Table (Before).Uname);
895
                     Last_Withing : Natural := Withing'Last;
896
                     Spec_Body    : String  := " (Spec)";
897
 
898
                  begin
899
                     To_Mixed (Withed);
900
                     To_Mixed (Withing);
901
 
902
                     if Last_Withed > 2 and then
903
                       Withed (Last_Withed - 1) = '%'
904
                     then
905
                        Last_Withed := Last_Withed - 2;
906
                     end if;
907
 
908
                     if Last_Withing > 2 and then
909
                       Withing (Last_Withing - 1) = '%'
910
                     then
911
                        Last_Withing := Last_Withing - 2;
912
                     end if;
913
 
914
                     if Units.Table (Before).Utype = Is_Body or else
915
                       Units.Table (Before).Utype = Is_Body_Only
916
                     then
917
                        Spec_Body := " (Body)";
918
                     end if;
919
 
920
                     Osint.Fail
921
                       ("could not find unit "
922
                        & Withed (Withed'First .. Last_Withed) & " needed by "
923
                        & Withing (Withing'First .. Last_Withing) & Spec_Body);
924
                  end;
925
               end if;
926
 
927
               Elab_All_Links
928
                 (Unit_Id_Of (Withs.Table (W).Uname),
929
                  After,
930
                  Reason,
931
                  Make_Elab_Entry (Withs.Table (W).Uname, Link));
932
            end;
933
         end if;
934
      end loop;
935
 
936
      --  Process corresponding body, if there is one
937
 
938
      if Units.Table (Before).Utype = Is_Spec then
939
         Elab_All_Links
940
           (Corresponding_Body (Before),
941
            After, Reason,
942
            Make_Elab_Entry
943
              (Units.Table (Corresponding_Body (Before)).Uname, Link));
944
      end if;
945
   end Elab_All_Links;
946
 
947
   --------------------
948
   -- Elab_Error_Msg --
949
   --------------------
950
 
951
   procedure Elab_Error_Msg (S : Successor_Id) is
952
      SL : Successor_Link renames Succ.Table (S);
953
 
954
   begin
955
      --  Nothing to do if internal unit involved and no -da flag
956
 
957
      if not Debug_Flag_A
958
        and then
959
          (Is_Internal_File_Name (Units.Table (SL.Before).Sfile)
960
            or else
961
           Is_Internal_File_Name (Units.Table (SL.After).Sfile))
962
      then
963
         return;
964
      end if;
965
 
966
      --  Here we want to generate output
967
 
968
      Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
969
 
970
      if SL.Elab_Body then
971
         Error_Msg_Unit_2 := Units.Table (Corresponding_Body (SL.After)).Uname;
972
      else
973
         Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
974
      end if;
975
 
976
      Error_Msg_Output ("  $ must be elaborated before $", Info => True);
977
 
978
      Error_Msg_Unit_1 := Units.Table (SL.Reason_Unit).Uname;
979
 
980
      case SL.Reason is
981
         when Withed =>
982
            Error_Msg_Output
983
              ("     reason: with clause",
984
               Info => True);
985
 
986
         when Elab =>
987
            Error_Msg_Output
988
              ("     reason: pragma Elaborate in unit $",
989
               Info => True);
990
 
991
         when Elab_All =>
992
            Error_Msg_Output
993
              ("     reason: pragma Elaborate_All in unit $",
994
               Info => True);
995
 
996
         when Elab_All_Desirable =>
997
            Error_Msg_Output
998
              ("     reason: implicit Elaborate_All in unit $",
999
               Info => True);
1000
 
1001
            Error_Msg_Output
1002
              ("     recompile $ with -gnatwl for full details",
1003
               Info => True);
1004
 
1005
         when Elab_Desirable =>
1006
            Error_Msg_Output
1007
              ("     reason: implicit Elaborate in unit $",
1008
               Info => True);
1009
 
1010
            Error_Msg_Output
1011
              ("     recompile $ with -gnatwl for full details",
1012
               Info => True);
1013
 
1014
         when Spec_First =>
1015
            Error_Msg_Output
1016
              ("     reason: spec always elaborated before body",
1017
               Info => True);
1018
      end case;
1019
 
1020
      Write_Elab_All_Chain (S);
1021
 
1022
      if SL.Elab_Body then
1023
         Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
1024
         Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
1025
         Error_Msg_Output
1026
           ("  $ must therefore be elaborated before $",
1027
            True);
1028
 
1029
         Error_Msg_Unit_1 := Units.Table (SL.After).Uname;
1030
         Error_Msg_Output
1031
           ("     (because $ has a pragma Elaborate_Body)",
1032
            True);
1033
      end if;
1034
 
1035
      if not Zero_Formatting then
1036
         Write_Eol;
1037
      end if;
1038
   end Elab_Error_Msg;
1039
 
1040
   ---------------------
1041
   -- Find_Elab_Order --
1042
   ---------------------
1043
 
1044
   procedure Find_Elab_Order is
1045
      U           : Unit_Id;
1046
      Best_So_Far : Unit_Id;
1047
 
1048
   begin
1049
      Succ.Init;
1050
      Num_Left := Int (Units.Last - Units.First + 1);
1051
 
1052
      --  Initialize unit table for elaboration control
1053
 
1054
      for U in Units.First .. Units.Last loop
1055
         UNR.Increment_Last;
1056
         UNR.Table (UNR.Last).Successors    := No_Successor;
1057
         UNR.Table (UNR.Last).Num_Pred      := 0;
1058
         UNR.Table (UNR.Last).Nextnp        := No_Unit_Id;
1059
         UNR.Table (UNR.Last).Elab_Order    := 0;
1060
         UNR.Table (UNR.Last).Elab_Position := 0;
1061
      end loop;
1062
 
1063
      --  Output warning if -p used with no -gnatE units
1064
 
1065
      if Pessimistic_Elab_Order
1066
        and not Dynamic_Elaboration_Checks_Specified
1067
      then
1068
         if OpenVMS_On_Target then
1069
            Error_Msg ("?use of /PESSIMISTIC_ELABORATION questionable");
1070
         else
1071
            Error_Msg ("?use of -p switch questionable");
1072
         end if;
1073
 
1074
         Error_Msg ("?since all units compiled with static elaboration model");
1075
      end if;
1076
 
1077
      --  Gather dependencies and output them if option set
1078
 
1079
      Gather_Dependencies;
1080
 
1081
      --  Output elaboration dependencies if option is set
1082
 
1083
      if Elab_Dependency_Output or Debug_Flag_E then
1084
         Write_Dependencies;
1085
      end if;
1086
 
1087
      --  Initialize the no predecessor list
1088
 
1089
      No_Pred := No_Unit_Id;
1090
 
1091
      for U in UNR.First .. UNR.Last loop
1092
         if UNR.Table (U).Num_Pred = 0 then
1093
            UNR.Table (U).Nextnp := No_Pred;
1094
            No_Pred := U;
1095
         end if;
1096
      end loop;
1097
 
1098
      --  OK, now we determine the elaboration order proper. All we do is to
1099
      --  select the best choice from the no predecessor list until all the
1100
      --  nodes have been chosen.
1101
 
1102
      Outer : loop
1103
 
1104
         --  If there are no nodes with predecessors, then either we are
1105
         --  done, as indicated by Num_Left being set to zero, or we have
1106
         --  a circularity. In the latter case, diagnose the circularity,
1107
         --  removing it from the graph and continue
1108
 
1109
         Get_No_Pred : while No_Pred = No_Unit_Id loop
1110
            exit Outer when Num_Left < 1;
1111
            Diagnose_Elaboration_Problem;
1112
         end loop Get_No_Pred;
1113
 
1114
         U := No_Pred;
1115
         Best_So_Far := No_Unit_Id;
1116
 
1117
         --  Loop to choose best entry in No_Pred list
1118
 
1119
         No_Pred_Search : loop
1120
            if Debug_Flag_N then
1121
               Write_Str ("  considering choice of ");
1122
               Write_Unit_Name (Units.Table (U).Uname);
1123
               Write_Eol;
1124
 
1125
               if Units.Table (U).Elaborate_Body then
1126
                  Write_Str
1127
                    ("    Elaborate_Body = True, Num_Pred for body = ");
1128
                  Write_Int
1129
                    (Int (UNR.Table (Corresponding_Body (U)).Num_Pred));
1130
               else
1131
                  Write_Str
1132
                    ("    Elaborate_Body = False");
1133
               end if;
1134
 
1135
               Write_Eol;
1136
            end if;
1137
 
1138
            --  This is a candididate to be considered for choice
1139
 
1140
            if Best_So_Far = No_Unit_Id
1141
              or else ((not Pessimistic_Elab_Order)
1142
                         and then Better_Choice (U, Best_So_Far))
1143
              or else (Pessimistic_Elab_Order
1144
                         and then Worse_Choice (U, Best_So_Far))
1145
            then
1146
               if Debug_Flag_N then
1147
                  Write_Str ("    tentatively chosen (best so far)");
1148
                  Write_Eol;
1149
               end if;
1150
 
1151
               Best_So_Far := U;
1152
            end if;
1153
 
1154
            U := UNR.Table (U).Nextnp;
1155
            exit No_Pred_Search when U = No_Unit_Id;
1156
         end loop No_Pred_Search;
1157
 
1158
         --  If no candididate chosen, it means that no unit has No_Pred = 0,
1159
         --  but there are units left, hence we have a circular dependency,
1160
         --  which we will get Diagnose_Elaboration_Problem to diagnose it.
1161
 
1162
         if Best_So_Far = No_Unit_Id then
1163
            Diagnose_Elaboration_Problem;
1164
 
1165
         --  Otherwise choose the best candidate found
1166
 
1167
         else
1168
            Choose (Best_So_Far);
1169
         end if;
1170
      end loop Outer;
1171
   end Find_Elab_Order;
1172
 
1173
   -------------------------
1174
   -- Gather_Dependencies --
1175
   -------------------------
1176
 
1177
   procedure Gather_Dependencies is
1178
      Withed_Unit : Unit_Id;
1179
 
1180
   begin
1181
      --  Loop through all units
1182
 
1183
      for U in Units.First .. Units.Last loop
1184
         Cur_Unit := U;
1185
 
1186
         --  If this is not an interface to a stand-alone library and
1187
         --  there is a body and a spec, then spec must be elaborated first
1188
         --  Note that the corresponding spec immediately follows the body
1189
 
1190
         if not Units.Table (U).SAL_Interface
1191
           and then Units.Table (U).Utype = Is_Body
1192
         then
1193
            Build_Link (Corresponding_Spec (U), U, Spec_First);
1194
         end if;
1195
 
1196
         --  If this unit is not an interface to a stand-alone library,
1197
         --  process WITH references for this unit ignoring generic units and
1198
         --  interfaces to stand-alone libraries.
1199
 
1200
         if not Units.Table (U).SAL_Interface then
1201
            for
1202
              W in Units.Table (U).First_With .. Units.Table (U).Last_With
1203
            loop
1204
               if Withs.Table (W).Sfile /= No_File
1205
                 and then (not Withs.Table (W).SAL_Interface)
1206
               then
1207
                  --  Check for special case of withing a unit that does not
1208
                  --  exist any more. If the unit was completely missing we
1209
                  --  would already have detected this, but a nasty case arises
1210
                  --  when we have a subprogram body with no spec, and some
1211
                  --  obsolete unit with's a previous (now disappeared) spec.
1212
 
1213
                  if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then
1214
                     Error_Msg_File_1 := Units.Table (U).Sfile;
1215
                     Error_Msg_Unit_1 := Withs.Table (W).Uname;
1216
                     Error_Msg ("{ depends on $ which no longer exists");
1217
                     goto Next_With;
1218
                  end if;
1219
 
1220
                  Withed_Unit :=
1221
                    Unit_Id (Unit_Id_Of (Withs.Table (W).Uname));
1222
 
1223
                  --  Pragma Elaborate_All case, for this we use the recursive
1224
                  --  Elab_All_Links procedure to establish the links.
1225
 
1226
                  if Withs.Table (W).Elaborate_All then
1227
 
1228
                     --  Reset flags used to stop multiple visits to a given
1229
                     --  node.
1230
 
1231
                     for Uref in UNR.First .. UNR.Last loop
1232
                        UNR.Table (Uref).Visited := False;
1233
                     end loop;
1234
 
1235
                     --  Now establish all the links we need
1236
 
1237
                     Elab_All_Links
1238
                       (Withed_Unit, U, Elab_All,
1239
                        Make_Elab_Entry
1240
                          (Withs.Table (W).Uname, No_Elab_All_Link));
1241
 
1242
                  --  Elaborate_All_Desirable case, for this we establish the
1243
                  --  same links as above, but with a different reason.
1244
 
1245
                  elsif Withs.Table (W).Elab_All_Desirable then
1246
 
1247
                     --  Reset flags used to stop multiple visits to a given
1248
                     --  node.
1249
 
1250
                     for Uref in UNR.First .. UNR.Last loop
1251
                        UNR.Table (Uref).Visited := False;
1252
                     end loop;
1253
 
1254
                     --  Now establish all the links we need
1255
 
1256
                     Elab_All_Links
1257
                       (Withed_Unit, U, Elab_All_Desirable,
1258
                        Make_Elab_Entry
1259
                          (Withs.Table (W).Uname, No_Elab_All_Link));
1260
 
1261
                  --  Pragma Elaborate case. We must build a link for the
1262
                  --  withed unit itself, and also the corresponding body if
1263
                  --  there is one.
1264
 
1265
                  --  However, skip this processing if there is no ALI file for
1266
                  --  the WITH entry, because this means it is a generic (even
1267
                  --  when we fix the generics so that an ALI file is present,
1268
                  --  we probably still will have no ALI file for unchecked and
1269
                  --  other special cases).
1270
 
1271
                  elsif Withs.Table (W).Elaborate
1272
                    and then Withs.Table (W).Afile /= No_File
1273
                  then
1274
                     Build_Link (Withed_Unit, U, Withed);
1275
 
1276
                     if Units.Table (Withed_Unit).Utype = Is_Spec then
1277
                        Build_Link
1278
                          (Corresponding_Body (Withed_Unit), U, Elab);
1279
                     end if;
1280
 
1281
                  --  Elaborate_Desirable case, for this we establish
1282
                  --  the same links as above, but with a different reason.
1283
 
1284
                  elsif Withs.Table (W).Elab_Desirable then
1285
                     Build_Link (Withed_Unit, U, Withed);
1286
 
1287
                     if Units.Table (Withed_Unit).Utype = Is_Spec then
1288
                        Build_Link
1289
                          (Corresponding_Body (Withed_Unit),
1290
                           U, Elab_Desirable);
1291
                     end if;
1292
 
1293
                  --  A limited_with does not establish an elaboration
1294
                  --  dependence (that's the whole point!).
1295
 
1296
                  elsif Withs.Table (W).Limited_With then
1297
                     null;
1298
 
1299
                  --  Case of normal WITH with no elaboration pragmas, just
1300
                  --  build the single link to the directly referenced unit
1301
 
1302
                  else
1303
                     Build_Link (Withed_Unit, U, Withed);
1304
                  end if;
1305
               end if;
1306
 
1307
               <<Next_With>>
1308
               null;
1309
            end loop;
1310
         end if;
1311
      end loop;
1312
   end Gather_Dependencies;
1313
 
1314
   ------------------
1315
   -- Is_Body_Unit --
1316
   ------------------
1317
 
1318
   function Is_Body_Unit (U : Unit_Id) return Boolean is
1319
   begin
1320
      return Units.Table (U).Utype = Is_Body
1321
        or else Units.Table (U).Utype = Is_Body_Only;
1322
   end Is_Body_Unit;
1323
 
1324
   ---------------------
1325
   -- Is_Waiting_Body --
1326
   ---------------------
1327
 
1328
   function Is_Waiting_Body (U : Unit_Id) return Boolean is
1329
   begin
1330
      return Units.Table (U).Utype = Is_Body
1331
        and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
1332
   end Is_Waiting_Body;
1333
 
1334
   ---------------------
1335
   -- Make_Elab_Entry --
1336
   ---------------------
1337
 
1338
   function Make_Elab_Entry
1339
     (Unam : Unit_Name_Type;
1340
      Link : Elab_All_Id) return Elab_All_Id
1341
   is
1342
   begin
1343
      Elab_All_Entries.Increment_Last;
1344
      Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam;
1345
      Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link;
1346
      return Elab_All_Entries.Last;
1347
   end Make_Elab_Entry;
1348
 
1349
   ----------------
1350
   -- Unit_Id_Of --
1351
   ----------------
1352
 
1353
   function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
1354
      Info : constant Int := Get_Name_Table_Info (Uname);
1355
   begin
1356
      pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
1357
      return Unit_Id (Info);
1358
   end Unit_Id_Of;
1359
 
1360
   ------------------
1361
   -- Worse_Choice --
1362
   ------------------
1363
 
1364
   function Worse_Choice (U1, U2 : Unit_Id) return Boolean is
1365
      UT1 : Unit_Record renames Units.Table (U1);
1366
      UT2 : Unit_Record renames Units.Table (U2);
1367
 
1368
   begin
1369
      --  Note: the checks here are applied in sequence, and the ordering is
1370
      --  significant (i.e. the more important criteria are applied first).
1371
 
1372
      --  If either unit is internal, then use Better_Choice, since the
1373
      --  language requires that predefined units not mess up in the choice
1374
      --  of elaboration order, and for internal units, any problems are
1375
      --  ours and not the programmers.
1376
 
1377
      if UT1.Internal or else UT2.Internal then
1378
         return Better_Choice (U1, U2);
1379
 
1380
      --  Prefer anything else to a waiting body (!)
1381
 
1382
      elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
1383
         return False;
1384
 
1385
      elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
1386
         return True;
1387
 
1388
      --  Prefer a spec to a body (!)
1389
 
1390
      elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
1391
         return False;
1392
 
1393
      elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
1394
         return True;
1395
 
1396
      --  If both are waiting bodies, then prefer the one whose spec is
1397
      --  less recently elaborated. Consider the following:
1398
 
1399
      --     spec of A
1400
      --     spec of B
1401
      --     body of A or B?
1402
 
1403
      --  The normal waiting body preference would have placed the body of
1404
      --  A before the spec of B if it could. Since it could not, there it
1405
      --  must be the case that A depends on B. It is therefore a good idea
1406
      --  to put the body of B last so that if there is an elaboration order
1407
      --  problem, we will find it (that's what horrible order is about)
1408
 
1409
      elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
1410
         return
1411
           UNR.Table (Corresponding_Spec (U1)).Elab_Position <
1412
           UNR.Table (Corresponding_Spec (U2)).Elab_Position;
1413
      end if;
1414
 
1415
      --  Remaining choice rules are disabled by Debug flag -do
1416
 
1417
      if not Debug_Flag_O then
1418
 
1419
         --  The following deal with the case of specs which have been marked
1420
         --  as Elaborate_Body_Desirable. In the normal case, we generally want
1421
         --  to delay the elaboration of these specs as long as possible, so
1422
         --  that bodies have better chance of being elaborated closer to the
1423
         --  specs. Worse_Choice as usual wants to do the opposite and
1424
         --  elaborate such specs as early as possible.
1425
 
1426
         --  If we have two units, one of which is a spec for which this flag
1427
         --  is set, and the other is not, we normally prefer to delay the spec
1428
         --  for which the flag is set, and so Worse_Choice does the opposite.
1429
 
1430
         if not UT1.Elaborate_Body_Desirable
1431
           and then UT2.Elaborate_Body_Desirable
1432
         then
1433
            return False;
1434
 
1435
         elsif not UT2.Elaborate_Body_Desirable
1436
           and then UT1.Elaborate_Body_Desirable
1437
         then
1438
            return True;
1439
 
1440
            --  If we have two specs that are both marked as Elaborate_Body
1441
            --  desirable, we normally prefer the one whose body is nearer to
1442
            --  being able to be elaborated, based on the Num_Pred count. This
1443
            --  helps to ensure bodies are as close to specs as possible. As
1444
            --  usual, Worse_Choice does the opposite.
1445
 
1446
         elsif UT1.Elaborate_Body_Desirable
1447
           and then UT2.Elaborate_Body_Desirable
1448
         then
1449
            return UNR.Table (Corresponding_Body (U1)).Num_Pred >=
1450
              UNR.Table (Corresponding_Body (U2)).Num_Pred;
1451
         end if;
1452
      end if;
1453
 
1454
      --  If we fall through, it means that no preference rule applies, so we
1455
      --  use alphabetical order to at least give a deterministic result. Since
1456
      --  Worse_Choice is in the business of stirring up the order, we will
1457
      --  use reverse alphabetical ordering.
1458
 
1459
      return Uname_Less (UT2.Uname, UT1.Uname);
1460
   end Worse_Choice;
1461
 
1462
   ------------------------
1463
   -- Write_Dependencies --
1464
   ------------------------
1465
 
1466
   procedure Write_Dependencies is
1467
   begin
1468
      if not Zero_Formatting then
1469
         Write_Eol;
1470
         Write_Str ("                 ELABORATION ORDER DEPENDENCIES");
1471
         Write_Eol;
1472
         Write_Eol;
1473
      end if;
1474
 
1475
      Info_Prefix_Suppress := True;
1476
 
1477
      for S in Succ_First .. Succ.Last loop
1478
         Elab_Error_Msg (S);
1479
      end loop;
1480
 
1481
      Info_Prefix_Suppress := False;
1482
 
1483
      if not Zero_Formatting then
1484
         Write_Eol;
1485
      end if;
1486
   end Write_Dependencies;
1487
 
1488
   --------------------------
1489
   -- Write_Elab_All_Chain --
1490
   --------------------------
1491
 
1492
   procedure Write_Elab_All_Chain (S : Successor_Id) is
1493
      ST     : constant Successor_Link := Succ.Table (S);
1494
      After  : constant Unit_Name_Type := Units.Table (ST.After).Uname;
1495
 
1496
      L   : Elab_All_Id;
1497
      Nam : Unit_Name_Type;
1498
 
1499
      First_Name : Boolean := True;
1500
 
1501
   begin
1502
      if ST.Reason in Elab_All .. Elab_All_Desirable then
1503
         L := ST.Elab_All_Link;
1504
         while L /= No_Elab_All_Link loop
1505
            Nam := Elab_All_Entries.Table (L).Needed_By;
1506
            Error_Msg_Unit_1 := Nam;
1507
            Error_Msg_Output ("        $", Info => True);
1508
 
1509
            Get_Name_String (Nam);
1510
 
1511
            if Name_Buffer (Name_Len) = 'b' then
1512
               if First_Name then
1513
                  Error_Msg_Output
1514
                    ("           must be elaborated along with its spec:",
1515
                     Info => True);
1516
 
1517
               else
1518
                  Error_Msg_Output
1519
                    ("           which must be elaborated " &
1520
                     "along with its spec:",
1521
                     Info => True);
1522
               end if;
1523
 
1524
            else
1525
               if First_Name then
1526
                  Error_Msg_Output
1527
                    ("           is withed by:",
1528
                     Info => True);
1529
 
1530
               else
1531
                  Error_Msg_Output
1532
                    ("           which is withed by:",
1533
                     Info => True);
1534
               end if;
1535
            end if;
1536
 
1537
            First_Name := False;
1538
 
1539
            L := Elab_All_Entries.Table (L).Next_Elab;
1540
         end loop;
1541
 
1542
         Error_Msg_Unit_1 := After;
1543
         Error_Msg_Output ("        $", Info => True);
1544
      end if;
1545
   end Write_Elab_All_Chain;
1546
 
1547
end Binde;

powered by: WebSVN 2.1.0

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