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

Subversion Repositories openrisc_me

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                                  L I B                                   --
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.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- GNAT was originally developed  by the GNAT team at  New York University. --
28
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29
--                                                                          --
30
------------------------------------------------------------------------------
31
 
32
pragma Style_Checks (All_Checks);
33
--  Subprogram ordering not enforced in this unit
34
--  (because of some logical groupings).
35
 
36
with Atree;   use Atree;
37
with Einfo;   use Einfo;
38
with Fname;   use Fname;
39
with Output;  use Output;
40
with Sinfo;   use Sinfo;
41
with Sinput;  use Sinput;
42
with Stand;   use Stand;
43
with Stringt; use Stringt;
44
with Tree_IO; use Tree_IO;
45
with Uname;   use Uname;
46
 
47
package body Lib is
48
 
49
   Switch_Storing_Enabled : Boolean := True;
50
   --  Controlled by Enable_Switch_Storing/Disable_Switch_Storing
51
 
52
   -----------------------
53
   -- Local Subprograms --
54
   -----------------------
55
 
56
   type SEU_Result is (
57
      Yes_Before, -- S1 is in same extended unit as S2 and appears before it
58
      Yes_Same,   -- S1 is in same extended unit as S2, Slocs are the same
59
      Yes_After,  -- S1 is in same extended unit as S2, and appears after it
60
      No);        -- S2 is not in same extended unit as S2
61
 
62
   function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result;
63
   --  Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns
64
   --  value as described above.
65
 
66
   function Get_Code_Or_Source_Unit
67
     (S                : Source_Ptr;
68
      Unwind_Instances : Boolean) return Unit_Number_Type;
69
   --  Common code for Get_Code_Unit (get unit of instantiation for location)
70
   --  and Get_Source_Unit (get unit of template for location).
71
 
72
   --------------------------------------------
73
   -- Access Functions for Unit Table Fields --
74
   --------------------------------------------
75
 
76
   function Cunit (U : Unit_Number_Type) return Node_Id is
77
   begin
78
      return Units.Table (U).Cunit;
79
   end Cunit;
80
 
81
   function Cunit_Entity (U : Unit_Number_Type) return Entity_Id is
82
   begin
83
      return Units.Table (U).Cunit_Entity;
84
   end Cunit_Entity;
85
 
86
   function Dependency_Num (U : Unit_Number_Type) return Nat is
87
   begin
88
      return Units.Table (U).Dependency_Num;
89
   end Dependency_Num;
90
 
91
   function Dynamic_Elab (U : Unit_Number_Type) return Boolean is
92
   begin
93
      return Units.Table (U).Dynamic_Elab;
94
   end Dynamic_Elab;
95
 
96
   function Error_Location (U : Unit_Number_Type) return Source_Ptr is
97
   begin
98
      return Units.Table (U).Error_Location;
99
   end Error_Location;
100
 
101
   function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type is
102
   begin
103
      return Units.Table (U).Expected_Unit;
104
   end Expected_Unit;
105
 
106
   function Fatal_Error (U : Unit_Number_Type) return Boolean is
107
   begin
108
      return Units.Table (U).Fatal_Error;
109
   end Fatal_Error;
110
 
111
   function Generate_Code (U : Unit_Number_Type) return Boolean is
112
   begin
113
      return Units.Table (U).Generate_Code;
114
   end Generate_Code;
115
 
116
   function Has_RACW (U : Unit_Number_Type) return Boolean is
117
   begin
118
      return Units.Table (U).Has_RACW;
119
   end Has_RACW;
120
 
121
   function Is_Compiler_Unit (U : Unit_Number_Type) return Boolean is
122
   begin
123
      return Units.Table (U).Is_Compiler_Unit;
124
   end Is_Compiler_Unit;
125
 
126
   function Ident_String (U : Unit_Number_Type) return Node_Id is
127
   begin
128
      return Units.Table (U).Ident_String;
129
   end Ident_String;
130
 
131
   function Loading (U : Unit_Number_Type) return Boolean is
132
   begin
133
      return Units.Table (U).Loading;
134
   end Loading;
135
 
136
   function Main_Priority (U : Unit_Number_Type) return Int is
137
   begin
138
      return Units.Table (U).Main_Priority;
139
   end Main_Priority;
140
 
141
   function Munit_Index (U : Unit_Number_Type) return Nat is
142
   begin
143
      return Units.Table (U).Munit_Index;
144
   end Munit_Index;
145
 
146
   function OA_Setting (U : Unit_Number_Type) return Character is
147
   begin
148
      return Units.Table (U).OA_Setting;
149
   end OA_Setting;
150
 
151
   function Source_Index (U : Unit_Number_Type) return Source_File_Index is
152
   begin
153
      return Units.Table (U).Source_Index;
154
   end Source_Index;
155
 
156
   function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type is
157
   begin
158
      return Units.Table (U).Unit_File_Name;
159
   end Unit_File_Name;
160
 
161
   function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type is
162
   begin
163
      return Units.Table (U).Unit_Name;
164
   end Unit_Name;
165
 
166
   ------------------------------------------
167
   -- Subprograms to Set Unit Table Fields --
168
   ------------------------------------------
169
 
170
   procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id) is
171
   begin
172
      Units.Table (U).Cunit := N;
173
   end Set_Cunit;
174
 
175
   procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id) is
176
   begin
177
      Units.Table (U).Cunit_Entity := E;
178
      Set_Is_Compilation_Unit (E);
179
   end Set_Cunit_Entity;
180
 
181
   procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True) is
182
   begin
183
      Units.Table (U).Dynamic_Elab := B;
184
   end Set_Dynamic_Elab;
185
 
186
   procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr) is
187
   begin
188
      Units.Table (U).Error_Location := W;
189
   end Set_Error_Location;
190
 
191
   procedure Set_Fatal_Error (U : Unit_Number_Type; B : Boolean := True) is
192
   begin
193
      Units.Table (U).Fatal_Error := B;
194
   end Set_Fatal_Error;
195
 
196
   procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True) is
197
   begin
198
      Units.Table (U).Generate_Code := B;
199
   end Set_Generate_Code;
200
 
201
   procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True) is
202
   begin
203
      Units.Table (U).Has_RACW := B;
204
   end Set_Has_RACW;
205
 
206
   procedure Set_Is_Compiler_Unit
207
     (U : Unit_Number_Type;
208
      B : Boolean := True)
209
   is
210
   begin
211
      Units.Table (U).Is_Compiler_Unit := B;
212
   end Set_Is_Compiler_Unit;
213
 
214
   procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id) is
215
   begin
216
      Units.Table (U).Ident_String := N;
217
   end Set_Ident_String;
218
 
219
   procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True) is
220
   begin
221
      Units.Table (U).Loading := B;
222
   end Set_Loading;
223
 
224
   procedure Set_Main_Priority (U : Unit_Number_Type; P : Int) is
225
   begin
226
      Units.Table (U).Main_Priority := P;
227
   end Set_Main_Priority;
228
 
229
   procedure Set_OA_Setting (U : Unit_Number_Type; C : Character) is
230
   begin
231
      Units.Table (U).OA_Setting := C;
232
   end Set_OA_Setting;
233
 
234
   procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is
235
   begin
236
      Units.Table (U).Unit_Name := N;
237
   end Set_Unit_Name;
238
 
239
   ------------------------------
240
   -- Check_Same_Extended_Unit --
241
   ------------------------------
242
 
243
   function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is
244
      Sloc1  : Source_Ptr;
245
      Sloc2  : Source_Ptr;
246
      Sind1  : Source_File_Index;
247
      Sind2  : Source_File_Index;
248
      Inst1  : Source_Ptr;
249
      Inst2  : Source_Ptr;
250
      Unum1  : Unit_Number_Type;
251
      Unum2  : Unit_Number_Type;
252
      Unit1  : Node_Id;
253
      Unit2  : Node_Id;
254
      Depth1 : Nat;
255
      Depth2 : Nat;
256
 
257
   begin
258
      if S1 = No_Location or else S2 = No_Location then
259
         return No;
260
 
261
      elsif S1 = Standard_Location then
262
         if S2 = Standard_Location then
263
            return Yes_Same;
264
         else
265
            return No;
266
         end if;
267
 
268
      elsif S2 = Standard_Location then
269
         return No;
270
      end if;
271
 
272
      Sloc1 := S1;
273
      Sloc2 := S2;
274
      Unum1 := Get_Code_Unit (Sloc1);
275
      Unum2 := Get_Code_Unit (Sloc2);
276
 
277
      loop
278
         Sind1 := Get_Source_File_Index (Sloc1);
279
         Sind2 := Get_Source_File_Index (Sloc2);
280
 
281
         if Sind1 = Sind2 then
282
            if Sloc1 < Sloc2 then
283
               return Yes_Before;
284
            elsif Sloc1 > Sloc2 then
285
               return Yes_After;
286
            else
287
               return Yes_Same;
288
            end if;
289
         end if;
290
 
291
         --  OK, the two nodes are in separate source elements, but this is not
292
         --  decisive, because of the issue of subunits and instantiations.
293
 
294
         --  First we deal with subunits, since if the subunit is in an
295
         --  instantiation, we know that the parent is in the corresponding
296
         --  instantiation, since that is the only way we can have a subunit
297
         --  that is part of an instantiation.
298
 
299
         Unit1 := Unit (Cunit (Unum1));
300
         Unit2 := Unit (Cunit (Unum2));
301
 
302
         if Nkind (Unit1) = N_Subunit
303
           and then Present (Corresponding_Stub (Unit1))
304
         then
305
            --  Both in subunits. They could have a common ancestor. If they
306
            --  do, then the deeper one must have a longer unit name. Replace
307
            --  the deeper one with its corresponding stub, in order to find
308
            --  nearest common ancestor, if any.
309
 
310
            if Nkind (Unit2) = N_Subunit
311
              and then Present (Corresponding_Stub (Unit2))
312
            then
313
               if Length_Of_Name (Unit_Name (Unum1)) <
314
                  Length_Of_Name (Unit_Name (Unum2))
315
               then
316
                  Sloc2 := Sloc (Corresponding_Stub (Unit2));
317
                  Unum2 := Get_Source_Unit (Sloc2);
318
                  goto Continue;
319
 
320
               else
321
                  Sloc1 := Sloc (Corresponding_Stub (Unit1));
322
                  Unum1 := Get_Source_Unit (Sloc1);
323
                  goto Continue;
324
               end if;
325
 
326
            --  Nod1 in subunit, Nod2 not
327
 
328
            else
329
               Sloc1 := Sloc (Corresponding_Stub (Unit1));
330
               Unum1 := Get_Source_Unit (Sloc1);
331
               goto Continue;
332
            end if;
333
 
334
         --  Nod2 in subunit, Nod1 not
335
 
336
         elsif Nkind (Unit2) = N_Subunit
337
           and then Present (Corresponding_Stub (Unit2))
338
         then
339
            Sloc2 := Sloc (Corresponding_Stub (Unit2));
340
            Unum2 := Get_Source_Unit (Sloc2);
341
            goto Continue;
342
         end if;
343
 
344
         --  At this stage we know that neither is a subunit, so we deal
345
         --  with instantiations, since we could have a common ancestor
346
 
347
         Inst1 := Instantiation (Sind1);
348
         Inst2 := Instantiation (Sind2);
349
 
350
         if Inst1 /= No_Location then
351
 
352
            --  Both are instantiations
353
 
354
            if Inst2 /= No_Location then
355
 
356
               Depth1 := Instantiation_Depth (Sloc1);
357
               Depth2 := Instantiation_Depth (Sloc2);
358
 
359
               if Depth1 < Depth2 then
360
                  Sloc2 := Inst2;
361
                  Unum2 := Get_Source_Unit (Sloc2);
362
                  goto Continue;
363
 
364
               elsif Depth1 > Depth2 then
365
                  Sloc1 := Inst1;
366
                  Unum1 := Get_Source_Unit (Sloc1);
367
                  goto Continue;
368
 
369
               else
370
                  Sloc1 := Inst1;
371
                  Sloc2 := Inst2;
372
                  Unum1 := Get_Source_Unit (Sloc1);
373
                  Unum2 := Get_Source_Unit (Sloc2);
374
                  goto Continue;
375
               end if;
376
 
377
            --  Only first node is in instantiation
378
 
379
            else
380
               Sloc1 := Inst1;
381
               Unum1 := Get_Source_Unit (Sloc1);
382
               goto Continue;
383
            end if;
384
 
385
         --  Only second node is instantiation
386
 
387
         elsif Inst2 /= No_Location then
388
            Sloc2 := Inst2;
389
            Unum2 := Get_Source_Unit (Sloc2);
390
            goto Continue;
391
         end if;
392
 
393
         --  No instantiations involved, so we are not in the same unit
394
         --  However, there is one case still to check, namely the case
395
         --  where one location is in the spec, and the other in the
396
         --  corresponding body (the spec location is earlier).
397
 
398
         if Nkind (Unit1) = N_Subprogram_Body
399
              or else
400
            Nkind (Unit1) = N_Package_Body
401
         then
402
            if Library_Unit (Cunit (Unum1)) = Cunit (Unum2) then
403
               return Yes_After;
404
            end if;
405
 
406
         elsif Nkind (Unit2) = N_Subprogram_Body
407
                 or else
408
               Nkind (Unit2) = N_Package_Body
409
         then
410
            if Library_Unit (Cunit (Unum2)) = Cunit (Unum1) then
411
               return Yes_Before;
412
            end if;
413
         end if;
414
 
415
         --  If that special case does not occur, then we are certain that
416
         --  the two locations are really in separate units.
417
 
418
         return No;
419
 
420
         <<Continue>>
421
            null;
422
      end loop;
423
   end Check_Same_Extended_Unit;
424
 
425
   -------------------------------
426
   -- Compilation_Switches_Last --
427
   -------------------------------
428
 
429
   function Compilation_Switches_Last return Nat is
430
   begin
431
      return Compilation_Switches.Last;
432
   end Compilation_Switches_Last;
433
 
434
   ---------------------------
435
   -- Enable_Switch_Storing --
436
   ---------------------------
437
 
438
   procedure Enable_Switch_Storing is
439
   begin
440
      Switch_Storing_Enabled := True;
441
   end Enable_Switch_Storing;
442
 
443
   ----------------------------
444
   -- Disable_Switch_Storing --
445
   ----------------------------
446
 
447
   procedure Disable_Switch_Storing is
448
   begin
449
      Switch_Storing_Enabled := False;
450
   end Disable_Switch_Storing;
451
 
452
   ------------------------------
453
   -- Earlier_In_Extended_Unit --
454
   ------------------------------
455
 
456
   function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is
457
   begin
458
      return Check_Same_Extended_Unit (S1, S2) = Yes_Before;
459
   end Earlier_In_Extended_Unit;
460
 
461
   ----------------------------
462
   -- Entity_Is_In_Main_Unit --
463
   ----------------------------
464
 
465
   function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean is
466
      S : Entity_Id;
467
 
468
   begin
469
      S := Scope (E);
470
 
471
      while S /= Standard_Standard loop
472
         if S = Main_Unit_Entity then
473
            return True;
474
         elsif Ekind (S) = E_Package and then Is_Child_Unit (S) then
475
            return False;
476
         else
477
            S := Scope (S);
478
         end if;
479
      end loop;
480
 
481
      return False;
482
   end Entity_Is_In_Main_Unit;
483
 
484
   --------------------------
485
   -- Generic_May_Lack_ALI --
486
   --------------------------
487
 
488
   function Generic_May_Lack_ALI (Sfile : File_Name_Type) return Boolean is
489
   begin
490
      --  We allow internal generic units to be used without having a
491
      --  corresponding ALI files to help bootstrapping with older compilers
492
      --  that did not support generating ALIs for such generics. It is safe
493
      --  to do so because the only thing the generated code would contain
494
      --  is the elaboration boolean, and we are careful to elaborate all
495
      --  predefined units first anyway.
496
 
497
      return Is_Internal_File_Name
498
               (Fname              => Sfile,
499
                Renamings_Included => True);
500
   end Generic_May_Lack_ALI;
501
 
502
   -----------------------------
503
   -- Get_Code_Or_Source_Unit --
504
   -----------------------------
505
 
506
   function Get_Code_Or_Source_Unit
507
     (S                : Source_Ptr;
508
      Unwind_Instances : Boolean) return Unit_Number_Type
509
   is
510
   begin
511
      --  Search table unless we have No_Location, which can happen if the
512
      --  relevant location has not been set yet. Happens for example when
513
      --  we obtain Sloc (Cunit (Main_Unit)) before it is set.
514
 
515
      if S /= No_Location then
516
         declare
517
            Source_File : Source_File_Index;
518
            Source_Unit : Unit_Number_Type;
519
 
520
         begin
521
            Source_File := Get_Source_File_Index (S);
522
 
523
            if Unwind_Instances then
524
               while Template (Source_File) /= No_Source_File loop
525
                  Source_File := Template (Source_File);
526
               end loop;
527
            end if;
528
 
529
            Source_Unit := Unit (Source_File);
530
 
531
            if Source_Unit /= No_Unit then
532
               return Source_Unit;
533
            end if;
534
         end;
535
      end if;
536
 
537
      --  If S was No_Location, or was not in the table, we must be in the main
538
      --  source unit (and the value has not been placed in the table yet),
539
      --  or in one of the configuration pragma files.
540
 
541
      return Main_Unit;
542
   end Get_Code_Or_Source_Unit;
543
 
544
   -------------------
545
   -- Get_Code_Unit --
546
   -------------------
547
 
548
   function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is
549
   begin
550
      return Get_Code_Or_Source_Unit (Top_Level_Location (S),
551
        Unwind_Instances => False);
552
   end Get_Code_Unit;
553
 
554
   function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
555
   begin
556
      return Get_Code_Unit (Sloc (N));
557
   end Get_Code_Unit;
558
 
559
   ----------------------------
560
   -- Get_Compilation_Switch --
561
   ----------------------------
562
 
563
   function Get_Compilation_Switch (N : Pos) return String_Ptr is
564
   begin
565
      if N <= Compilation_Switches.Last then
566
         return Compilation_Switches.Table (N);
567
 
568
      else
569
         return null;
570
      end if;
571
   end Get_Compilation_Switch;
572
 
573
   ----------------------------------
574
   -- Get_Cunit_Entity_Unit_Number --
575
   ----------------------------------
576
 
577
   function Get_Cunit_Entity_Unit_Number
578
     (E : Entity_Id) return Unit_Number_Type
579
   is
580
   begin
581
      for U in Units.First .. Units.Last loop
582
         if Cunit_Entity (U) = E then
583
            return U;
584
         end if;
585
      end loop;
586
 
587
      --  If not in the table, must be the main source unit, and we just
588
      --  have not got it put into the table yet.
589
 
590
      return Main_Unit;
591
   end Get_Cunit_Entity_Unit_Number;
592
 
593
   ---------------------------
594
   -- Get_Cunit_Unit_Number --
595
   ---------------------------
596
 
597
   function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type is
598
   begin
599
      for U in Units.First .. Units.Last loop
600
         if Cunit (U) = N then
601
            return U;
602
         end if;
603
      end loop;
604
 
605
      --  If not in the table, must be a spec created for a main unit that is a
606
      --  child subprogram body which we have not inserted into the table yet.
607
 
608
      if N = Library_Unit (Cunit (Main_Unit)) then
609
         return Main_Unit;
610
 
611
      --  If it is anything else, something is seriously wrong, and we really
612
      --  don't want to proceed, even if assertions are off, so we explicitly
613
      --  raise an exception in this case to terminate compilation.
614
 
615
      else
616
         raise Program_Error;
617
      end if;
618
   end Get_Cunit_Unit_Number;
619
 
620
   ---------------------
621
   -- Get_Source_Unit --
622
   ---------------------
623
 
624
   function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is
625
   begin
626
      return Get_Code_Or_Source_Unit (S, Unwind_Instances => True);
627
   end Get_Source_Unit;
628
 
629
   function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
630
   begin
631
      return Get_Source_Unit (Sloc (N));
632
   end Get_Source_Unit;
633
 
634
   --------------------------------
635
   -- In_Extended_Main_Code_Unit --
636
   --------------------------------
637
 
638
   function In_Extended_Main_Code_Unit
639
     (N : Node_Or_Entity_Id) return Boolean
640
   is
641
   begin
642
      if Sloc (N) = Standard_Location then
643
         return True;
644
 
645
      elsif Sloc (N) = No_Location then
646
         return False;
647
 
648
      --  Special case Itypes to test the Sloc of the associated node. The
649
      --  reason we do this is for possible calls from gigi after -gnatD
650
      --  processing is complete in sprint. This processing updates the
651
      --  sloc fields of all nodes in the tree, but itypes are not in the
652
      --  tree so their slocs do not get updated.
653
 
654
      elsif Nkind (N) = N_Defining_Identifier
655
        and then Is_Itype (N)
656
      then
657
         return In_Extended_Main_Code_Unit (Associated_Node_For_Itype (N));
658
 
659
      --  Otherwise see if we are in the main unit
660
 
661
      elsif Get_Code_Unit (Sloc (N)) = Get_Code_Unit (Cunit (Main_Unit)) then
662
         return True;
663
 
664
      --  Node may be in spec (or subunit etc) of main unit
665
 
666
      else
667
         return
668
           In_Same_Extended_Unit (N, Cunit (Main_Unit));
669
      end if;
670
   end In_Extended_Main_Code_Unit;
671
 
672
   function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean is
673
   begin
674
      if Loc = Standard_Location then
675
         return True;
676
 
677
      elsif Loc = No_Location then
678
         return False;
679
 
680
      --  Otherwise see if we are in the main unit
681
 
682
      elsif Get_Code_Unit (Loc) = Get_Code_Unit (Cunit (Main_Unit)) then
683
         return True;
684
 
685
      --  Location may be in spec (or subunit etc) of main unit
686
 
687
      else
688
         return
689
           In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit)));
690
      end if;
691
   end In_Extended_Main_Code_Unit;
692
 
693
   ----------------------------------
694
   -- In_Extended_Main_Source_Unit --
695
   ----------------------------------
696
 
697
   function In_Extended_Main_Source_Unit
698
     (N : Node_Or_Entity_Id) return Boolean
699
   is
700
      Nloc : constant Source_Ptr := Sloc (N);
701
      Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
702
 
703
   begin
704
      --  If Mloc is not set, it means we are still parsing the main unit,
705
      --  so everything so far is in the extended main source unit.
706
 
707
      if Mloc = No_Location then
708
         return True;
709
 
710
      --  Special value cases
711
 
712
      elsif Nloc = Standard_Location then
713
         return True;
714
 
715
      elsif Nloc = No_Location then
716
         return False;
717
 
718
      --  Special case Itypes to test the Sloc of the associated node. The
719
      --  reason we do this is for possible calls from gigi after -gnatD
720
      --  processing is complete in sprint. This processing updates the
721
      --  sloc fields of all nodes in the tree, but itypes are not in the
722
      --  tree so their slocs do not get updated.
723
 
724
      elsif Nkind (N) = N_Defining_Identifier
725
        and then Is_Itype (N)
726
      then
727
         return In_Extended_Main_Source_Unit (Associated_Node_For_Itype (N));
728
 
729
      --  Otherwise compare original locations to see if in same unit
730
 
731
      else
732
         return
733
           In_Same_Extended_Unit
734
             (Original_Location (Nloc), Original_Location (Mloc));
735
      end if;
736
   end In_Extended_Main_Source_Unit;
737
 
738
   function In_Extended_Main_Source_Unit
739
     (Loc : Source_Ptr) return Boolean
740
   is
741
      Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
742
 
743
   begin
744
      --  If Mloc is not set, it means we are still parsing the main unit,
745
      --  so everything so far is in the extended main source unit.
746
 
747
      if Mloc = No_Location then
748
         return True;
749
 
750
      --  Special value cases
751
 
752
      elsif Loc = Standard_Location then
753
         return True;
754
 
755
      elsif Loc = No_Location then
756
         return False;
757
 
758
      --  Otherwise compare original locations to see if in same unit
759
 
760
      else
761
         return
762
           In_Same_Extended_Unit
763
             (Original_Location (Loc), Original_Location (Mloc));
764
      end if;
765
   end In_Extended_Main_Source_Unit;
766
 
767
   ------------------------
768
   -- In_Predefined_Unit --
769
   ------------------------
770
 
771
   function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean is
772
   begin
773
      return In_Predefined_Unit (Sloc (N));
774
   end In_Predefined_Unit;
775
 
776
   function In_Predefined_Unit (S : Source_Ptr) return Boolean is
777
      Unit : constant Unit_Number_Type := Get_Source_Unit (S);
778
      File : constant File_Name_Type   := Unit_File_Name (Unit);
779
   begin
780
      return Is_Predefined_File_Name (File);
781
   end In_Predefined_Unit;
782
 
783
   -----------------------
784
   -- In_Same_Code_Unit --
785
   -----------------------
786
 
787
   function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is
788
      S1 : constant Source_Ptr := Sloc (N1);
789
      S2 : constant Source_Ptr := Sloc (N2);
790
 
791
   begin
792
      if S1 = No_Location or else S2 = No_Location then
793
         return False;
794
 
795
      elsif S1 = Standard_Location then
796
         return S2 = Standard_Location;
797
 
798
      elsif S2 = Standard_Location then
799
         return False;
800
      end if;
801
 
802
      return Get_Code_Unit (N1) = Get_Code_Unit (N2);
803
   end In_Same_Code_Unit;
804
 
805
   ---------------------------
806
   -- In_Same_Extended_Unit --
807
   ---------------------------
808
 
809
   function In_Same_Extended_Unit
810
     (N1, N2 : Node_Or_Entity_Id) return Boolean
811
   is
812
   begin
813
      return Check_Same_Extended_Unit (Sloc (N1), Sloc (N2)) /= No;
814
   end In_Same_Extended_Unit;
815
 
816
   function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is
817
   begin
818
      return Check_Same_Extended_Unit (S1, S2) /= No;
819
   end In_Same_Extended_Unit;
820
 
821
   -------------------------
822
   -- In_Same_Source_Unit --
823
   -------------------------
824
 
825
   function In_Same_Source_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is
826
      S1 : constant Source_Ptr := Sloc (N1);
827
      S2 : constant Source_Ptr := Sloc (N2);
828
 
829
   begin
830
      if S1 = No_Location or else S2 = No_Location then
831
         return False;
832
 
833
      elsif S1 = Standard_Location then
834
         return S2 = Standard_Location;
835
 
836
      elsif S2 = Standard_Location then
837
         return False;
838
      end if;
839
 
840
      return Get_Source_Unit (N1) = Get_Source_Unit (N2);
841
   end In_Same_Source_Unit;
842
 
843
   -----------------------------
844
   -- Increment_Serial_Number --
845
   -----------------------------
846
 
847
   function Increment_Serial_Number return Nat is
848
      TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
849
   begin
850
      TSN := TSN + 1;
851
      return TSN;
852
   end Increment_Serial_Number;
853
 
854
   ----------------
855
   -- Initialize --
856
   ----------------
857
 
858
   procedure Initialize is
859
   begin
860
      Linker_Option_Lines.Init;
861
      Load_Stack.Init;
862
      Units.Init;
863
      Compilation_Switches.Init;
864
   end Initialize;
865
 
866
   ---------------
867
   -- Is_Loaded --
868
   ---------------
869
 
870
   function Is_Loaded (Uname : Unit_Name_Type) return Boolean is
871
   begin
872
      for Unum in Units.First .. Units.Last loop
873
         if Uname = Unit_Name (Unum) then
874
            return True;
875
         end if;
876
      end loop;
877
 
878
      return False;
879
   end Is_Loaded;
880
 
881
   ---------------
882
   -- Last_Unit --
883
   ---------------
884
 
885
   function Last_Unit return Unit_Number_Type is
886
   begin
887
      return Units.Last;
888
   end Last_Unit;
889
 
890
   ----------
891
   -- List --
892
   ----------
893
 
894
   procedure List (File_Names_Only : Boolean := False) is separate;
895
 
896
   ----------
897
   -- Lock --
898
   ----------
899
 
900
   procedure Lock is
901
   begin
902
      Linker_Option_Lines.Locked := True;
903
      Load_Stack.Locked := True;
904
      Units.Locked := True;
905
      Linker_Option_Lines.Release;
906
      Load_Stack.Release;
907
      Units.Release;
908
   end Lock;
909
 
910
   ---------------
911
   -- Num_Units --
912
   ---------------
913
 
914
   function Num_Units return Nat is
915
   begin
916
      return Int (Units.Last) - Int (Main_Unit) + 1;
917
   end Num_Units;
918
 
919
   -----------------
920
   -- Remove_Unit --
921
   -----------------
922
 
923
   procedure Remove_Unit (U : Unit_Number_Type) is
924
   begin
925
      if U = Units.Last then
926
         Units.Decrement_Last;
927
      end if;
928
   end Remove_Unit;
929
 
930
   ----------------------------------
931
   -- Replace_Linker_Option_String --
932
   ----------------------------------
933
 
934
   procedure Replace_Linker_Option_String
935
     (S : String_Id; Match_String : String)
936
   is
937
   begin
938
      if Match_String'Length > 0 then
939
         for J in 1 .. Linker_Option_Lines.Last loop
940
            String_To_Name_Buffer (Linker_Option_Lines.Table (J).Option);
941
 
942
            if Match_String = Name_Buffer (1 .. Match_String'Length) then
943
               Linker_Option_Lines.Table (J).Option := S;
944
               return;
945
            end if;
946
         end loop;
947
      end if;
948
 
949
      Store_Linker_Option_String (S);
950
   end Replace_Linker_Option_String;
951
 
952
   ----------
953
   -- Sort --
954
   ----------
955
 
956
   procedure Sort (Tbl : in out Unit_Ref_Table) is separate;
957
 
958
   ------------------------------
959
   -- Store_Compilation_Switch --
960
   ------------------------------
961
 
962
   procedure Store_Compilation_Switch (Switch : String) is
963
   begin
964
      if Switch_Storing_Enabled then
965
         Compilation_Switches.Increment_Last;
966
         Compilation_Switches.Table (Compilation_Switches.Last) :=
967
           new String'(Switch);
968
 
969
         --  Fix up --RTS flag which has been transformed by the gcc driver
970
         --  into -fRTS
971
 
972
         if Switch'Last >= Switch'First + 4
973
           and then Switch (Switch'First .. Switch'First + 4) = "-fRTS"
974
         then
975
            Compilation_Switches.Table
976
              (Compilation_Switches.Last) (Switch'First + 1) := '-';
977
         end if;
978
      end if;
979
   end Store_Compilation_Switch;
980
 
981
   --------------------------------
982
   -- Store_Linker_Option_String --
983
   --------------------------------
984
 
985
   procedure Store_Linker_Option_String (S : String_Id) is
986
   begin
987
      Linker_Option_Lines.Increment_Last;
988
      Linker_Option_Lines.Table (Linker_Option_Lines.Last) :=
989
        (Option => S, Unit => Current_Sem_Unit);
990
   end Store_Linker_Option_String;
991
 
992
   -------------------------------
993
   -- Synchronize_Serial_Number --
994
   -------------------------------
995
 
996
   procedure Synchronize_Serial_Number is
997
      TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
998
   begin
999
      TSN := TSN + 1;
1000
   end Synchronize_Serial_Number;
1001
 
1002
   ---------------
1003
   -- Tree_Read --
1004
   ---------------
1005
 
1006
   procedure Tree_Read is
1007
      N : Nat;
1008
      S : String_Ptr;
1009
 
1010
   begin
1011
      Units.Tree_Read;
1012
 
1013
      --  Read Compilation_Switches table. First release the memory occupied
1014
      --  by the previously loaded switches.
1015
 
1016
      for J in Compilation_Switches.First .. Compilation_Switches.Last loop
1017
         Free (Compilation_Switches.Table (J));
1018
      end loop;
1019
 
1020
      Tree_Read_Int (N);
1021
      Compilation_Switches.Set_Last (N);
1022
 
1023
      for J in 1 .. N loop
1024
         Tree_Read_Str (S);
1025
         Compilation_Switches.Table (J) := S;
1026
      end loop;
1027
   end Tree_Read;
1028
 
1029
   ----------------
1030
   -- Tree_Write --
1031
   ----------------
1032
 
1033
   procedure Tree_Write is
1034
   begin
1035
      Units.Tree_Write;
1036
 
1037
      --  Write Compilation_Switches table
1038
 
1039
      Tree_Write_Int (Compilation_Switches.Last);
1040
 
1041
      for J in 1 .. Compilation_Switches.Last loop
1042
         Tree_Write_Str (Compilation_Switches.Table (J));
1043
      end loop;
1044
   end Tree_Write;
1045
 
1046
   ------------
1047
   -- Unlock --
1048
   ------------
1049
 
1050
   procedure Unlock is
1051
   begin
1052
      Linker_Option_Lines.Locked := False;
1053
      Load_Stack.Locked := False;
1054
      Units.Locked := False;
1055
   end Unlock;
1056
 
1057
   -----------------
1058
   -- Version_Get --
1059
   -----------------
1060
 
1061
   function Version_Get (U : Unit_Number_Type) return Word_Hex_String is
1062
   begin
1063
      return Get_Hex_String (Units.Table (U).Version);
1064
   end Version_Get;
1065
 
1066
   ------------------------
1067
   -- Version_Referenced --
1068
   ------------------------
1069
 
1070
   procedure Version_Referenced (S : String_Id) is
1071
   begin
1072
      Version_Ref.Append (S);
1073
   end Version_Referenced;
1074
 
1075
end Lib;

powered by: WebSVN 2.1.0

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