File : lib.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- L I B --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, 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 -- --
19 -- --
20 -- --
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 Csets; use Csets;
38 with Einfo; use Einfo;
39 with Fname; use Fname;
40 with Nlists; use Nlists;
41 with Output; use Output;
42 with Sinfo; use Sinfo;
43 with Sinput; use Sinput;
44 with Stand; use Stand;
45 with Stringt; use Stringt;
46 with Tree_IO; use Tree_IO;
47 with Uname; use Uname;
48 with Widechar; use Widechar;
49
50 package body Lib is
51
52 Switch_Storing_Enabled : Boolean := True;
53 -- Controlled by Enable_Switch_Storing/Disable_Switch_Storing
54
55 -----------------------
56 -- Local Subprograms --
57 -----------------------
58
59 type SEU_Result is (
60 Yes_Before, -- S1 is in same extended unit as S2 and appears before it
61 Yes_Same, -- S1 is in same extended unit as S2, Slocs are the same
62 Yes_After, -- S1 is in same extended unit as S2, and appears after it
63 No); -- S2 is not in same extended unit as S2
64
65 function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result;
66 -- Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns
67 -- value as described above.
68
69 function Get_Code_Or_Source_Unit
70 (S : Source_Ptr;
71 Unwind_Instances : Boolean;
72 Unwind_Subunits : Boolean) return Unit_Number_Type;
73 -- Common processing for routines Get_Code_Unit, Get_Source_Unit, and
74 -- Get_Top_Level_Code_Unit. Unwind_Instances is True when the unit for the
75 -- top-level instantiation should be returned instead of the unit for the
76 -- template, in the case of an instantiation. Unwind_Subunits is True when
77 -- the corresponding top-level unit should be returned instead of a
78 -- subunit, in the case of a subunit.
79
80 --------------------------------------------
81 -- Access Functions for Unit Table Fields --
82 --------------------------------------------
83
84 function Cunit (U : Unit_Number_Type) return Node_Id is
85 begin
86 return Units.Table (U).Cunit;
87 end Cunit;
88
89 function Cunit_Entity (U : Unit_Number_Type) return Entity_Id is
90 begin
91 return Units.Table (U).Cunit_Entity;
92 end Cunit_Entity;
93
94 function Dependency_Num (U : Unit_Number_Type) return Nat is
95 begin
96 return Units.Table (U).Dependency_Num;
97 end Dependency_Num;
98
99 function Dynamic_Elab (U : Unit_Number_Type) return Boolean is
100 begin
101 return Units.Table (U).Dynamic_Elab;
102 end Dynamic_Elab;
103
104 function Error_Location (U : Unit_Number_Type) return Source_Ptr is
105 begin
106 return Units.Table (U).Error_Location;
107 end Error_Location;
108
109 function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type is
110 begin
111 return Units.Table (U).Expected_Unit;
112 end Expected_Unit;
113
114 function Fatal_Error (U : Unit_Number_Type) return Fatal_Type is
115 begin
116 return Units.Table (U).Fatal_Error;
117 end Fatal_Error;
118
119 function Generate_Code (U : Unit_Number_Type) return Boolean is
120 begin
121 return Units.Table (U).Generate_Code;
122 end Generate_Code;
123
124 function Has_RACW (U : Unit_Number_Type) return Boolean is
125 begin
126 return Units.Table (U).Has_RACW;
127 end Has_RACW;
128
129 function Ident_String (U : Unit_Number_Type) return Node_Id is
130 begin
131 return Units.Table (U).Ident_String;
132 end Ident_String;
133
134 function Loading (U : Unit_Number_Type) return Boolean is
135 begin
136 return Units.Table (U).Loading;
137 end Loading;
138
139 function Main_CPU (U : Unit_Number_Type) return Int is
140 begin
141 return Units.Table (U).Main_CPU;
142 end Main_CPU;
143
144 function Main_Priority (U : Unit_Number_Type) return Int is
145 begin
146 return Units.Table (U).Main_Priority;
147 end Main_Priority;
148
149 function Munit_Index (U : Unit_Number_Type) return Nat is
150 begin
151 return Units.Table (U).Munit_Index;
152 end Munit_Index;
153
154 function No_Elab_Code_All (U : Unit_Number_Type) return Boolean is
155 begin
156 return Units.Table (U).No_Elab_Code_All;
157 end No_Elab_Code_All;
158
159 function OA_Setting (U : Unit_Number_Type) return Character is
160 begin
161 return Units.Table (U).OA_Setting;
162 end OA_Setting;
163
164 function Source_Index (U : Unit_Number_Type) return Source_File_Index is
165 begin
166 return Units.Table (U).Source_Index;
167 end Source_Index;
168
169 function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type is
170 begin
171 return Units.Table (U).Unit_File_Name;
172 end Unit_File_Name;
173
174 function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type is
175 begin
176 return Units.Table (U).Unit_Name;
177 end Unit_Name;
178
179 ------------------------------------------
180 -- Subprograms to Set Unit Table Fields --
181 ------------------------------------------
182
183 procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id) is
184 begin
185 Units.Table (U).Cunit := N;
186 end Set_Cunit;
187
188 procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id) is
189 begin
190 Units.Table (U).Cunit_Entity := E;
191 Set_Is_Compilation_Unit (E);
192 end Set_Cunit_Entity;
193
194 procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True) is
195 begin
196 Units.Table (U).Dynamic_Elab := B;
197 end Set_Dynamic_Elab;
198
199 procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr) is
200 begin
201 Units.Table (U).Error_Location := W;
202 end Set_Error_Location;
203
204 procedure Set_Fatal_Error (U : Unit_Number_Type; V : Fatal_Type) is
205 begin
206 Units.Table (U).Fatal_Error := V;
207 end Set_Fatal_Error;
208
209 procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True) is
210 begin
211 Units.Table (U).Generate_Code := B;
212 end Set_Generate_Code;
213
214 procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True) is
215 begin
216 Units.Table (U).Has_RACW := B;
217 end Set_Has_RACW;
218
219 procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id) is
220 begin
221 Units.Table (U).Ident_String := N;
222 end Set_Ident_String;
223
224 procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True) is
225 begin
226 Units.Table (U).Loading := B;
227 end Set_Loading;
228
229 procedure Set_Main_CPU (U : Unit_Number_Type; P : Int) is
230 begin
231 Units.Table (U).Main_CPU := P;
232 end Set_Main_CPU;
233
234 procedure Set_Main_Priority (U : Unit_Number_Type; P : Int) is
235 begin
236 Units.Table (U).Main_Priority := P;
237 end Set_Main_Priority;
238
239 procedure Set_No_Elab_Code_All
240 (U : Unit_Number_Type;
241 B : Boolean := True)
242 is
243 begin
244 Units.Table (U).No_Elab_Code_All := B;
245 end Set_No_Elab_Code_All;
246
247 procedure Set_OA_Setting (U : Unit_Number_Type; C : Character) is
248 begin
249 Units.Table (U).OA_Setting := C;
250 end Set_OA_Setting;
251
252 procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is
253 begin
254 Units.Table (U).Unit_Name := N;
255 end Set_Unit_Name;
256
257 ------------------------------
258 -- Check_Same_Extended_Unit --
259 ------------------------------
260
261 function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is
262 Sloc1 : Source_Ptr;
263 Sloc2 : Source_Ptr;
264 Sind1 : Source_File_Index;
265 Sind2 : Source_File_Index;
266 Inst1 : Source_Ptr;
267 Inst2 : Source_Ptr;
268 Unum1 : Unit_Number_Type;
269 Unum2 : Unit_Number_Type;
270 Unit1 : Node_Id;
271 Unit2 : Node_Id;
272 Depth1 : Nat;
273 Depth2 : Nat;
274
275 begin
276 if S1 = No_Location or else S2 = No_Location then
277 return No;
278
279 elsif S1 = Standard_Location then
280 if S2 = Standard_Location then
281 return Yes_Same;
282 else
283 return No;
284 end if;
285
286 elsif S2 = Standard_Location then
287 return No;
288 end if;
289
290 Sloc1 := S1;
291 Sloc2 := S2;
292
293 Unum1 := Get_Source_Unit (Sloc1);
294 Unum2 := Get_Source_Unit (Sloc2);
295
296 loop
297 -- Step 1: Check whether the two locations are in the same source
298 -- file.
299
300 Sind1 := Get_Source_File_Index (Sloc1);
301 Sind2 := Get_Source_File_Index (Sloc2);
302
303 if Sind1 = Sind2 then
304 if Sloc1 < Sloc2 then
305 return Yes_Before;
306 elsif Sloc1 > Sloc2 then
307 return Yes_After;
308 else
309 return Yes_Same;
310 end if;
311 end if;
312
313 -- Step 2: Check subunits. If a subunit is instantiated, follow the
314 -- instantiation chain rather than the stub chain.
315
316 Unit1 := Unit (Cunit (Unum1));
317 Unit2 := Unit (Cunit (Unum2));
318 Inst1 := Instantiation (Sind1);
319 Inst2 := Instantiation (Sind2);
320
321 if Nkind (Unit1) = N_Subunit
322 and then Present (Corresponding_Stub (Unit1))
323 and then Inst1 = No_Location
324 then
325 if Nkind (Unit2) = N_Subunit
326 and then Present (Corresponding_Stub (Unit2))
327 and then Inst2 = No_Location
328 then
329 -- Both locations refer to subunits which may have a common
330 -- ancestor. If they do, the deeper subunit must have a longer
331 -- unit name. Replace the deeper one with its corresponding
332 -- stub in order to find the nearest ancestor.
333
334 if Length_Of_Name (Unit_Name (Unum1)) <
335 Length_Of_Name (Unit_Name (Unum2))
336 then
337 Sloc2 := Sloc (Corresponding_Stub (Unit2));
338 Unum2 := Get_Source_Unit (Sloc2);
339 goto Continue;
340
341 else
342 Sloc1 := Sloc (Corresponding_Stub (Unit1));
343 Unum1 := Get_Source_Unit (Sloc1);
344 goto Continue;
345 end if;
346
347 -- Sloc1 in subunit, Sloc2 not
348
349 else
350 Sloc1 := Sloc (Corresponding_Stub (Unit1));
351 Unum1 := Get_Source_Unit (Sloc1);
352 goto Continue;
353 end if;
354
355 -- Sloc2 in subunit, Sloc1 not
356
357 elsif Nkind (Unit2) = N_Subunit
358 and then Present (Corresponding_Stub (Unit2))
359 and then Inst2 = No_Location
360 then
361 Sloc2 := Sloc (Corresponding_Stub (Unit2));
362 Unum2 := Get_Source_Unit (Sloc2);
363 goto Continue;
364 end if;
365
366 -- Step 3: Check instances. The two locations may yield a common
367 -- ancestor.
368
369 if Inst1 /= No_Location then
370 if Inst2 /= No_Location then
371
372 -- Both locations denote instantiations
373
374 Depth1 := Instantiation_Depth (Sloc1);
375 Depth2 := Instantiation_Depth (Sloc2);
376
377 if Depth1 < Depth2 then
378 Sloc2 := Inst2;
379 Unum2 := Get_Source_Unit (Sloc2);
380 goto Continue;
381
382 elsif Depth1 > Depth2 then
383 Sloc1 := Inst1;
384 Unum1 := Get_Source_Unit (Sloc1);
385 goto Continue;
386
387 else
388 Sloc1 := Inst1;
389 Sloc2 := Inst2;
390 Unum1 := Get_Source_Unit (Sloc1);
391 Unum2 := Get_Source_Unit (Sloc2);
392 goto Continue;
393 end if;
394
395 -- Sloc1 is an instantiation
396
397 else
398 Sloc1 := Inst1;
399 Unum1 := Get_Source_Unit (Sloc1);
400 goto Continue;
401 end if;
402
403 -- Sloc2 is an instantiation
404
405 elsif Inst2 /= No_Location then
406 Sloc2 := Inst2;
407 Unum2 := Get_Source_Unit (Sloc2);
408 goto Continue;
409 end if;
410
411 -- Step 4: One location in the spec, the other in the corresponding
412 -- body of the same unit. The location in the spec is considered
413 -- earlier.
414
415 if Nkind (Unit1) = N_Subprogram_Body
416 or else
417 Nkind (Unit1) = N_Package_Body
418 then
419 if Library_Unit (Cunit (Unum1)) = Cunit (Unum2) then
420 return Yes_After;
421 end if;
422
423 elsif Nkind (Unit2) = N_Subprogram_Body
424 or else
425 Nkind (Unit2) = N_Package_Body
426 then
427 if Library_Unit (Cunit (Unum2)) = Cunit (Unum1) then
428 return Yes_Before;
429 end if;
430 end if;
431
432 -- At this point it is certain that the two locations denote two
433 -- entirely separate units.
434
435 return No;
436
437 <<Continue>>
438 null;
439 end loop;
440 end Check_Same_Extended_Unit;
441
442 -------------------------------
443 -- Compilation_Switches_Last --
444 -------------------------------
445
446 function Compilation_Switches_Last return Nat is
447 begin
448 return Compilation_Switches.Last;
449 end Compilation_Switches_Last;
450
451 ---------------------------
452 -- Enable_Switch_Storing --
453 ---------------------------
454
455 procedure Enable_Switch_Storing is
456 begin
457 Switch_Storing_Enabled := True;
458 end Enable_Switch_Storing;
459
460 ----------------------------
461 -- Disable_Switch_Storing --
462 ----------------------------
463
464 procedure Disable_Switch_Storing is
465 begin
466 Switch_Storing_Enabled := False;
467 end Disable_Switch_Storing;
468
469 ------------------------------
470 -- Earlier_In_Extended_Unit --
471 ------------------------------
472
473 function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is
474 begin
475 return Check_Same_Extended_Unit (S1, S2) = Yes_Before;
476 end Earlier_In_Extended_Unit;
477
478 -----------------------
479 -- Exact_Source_Name --
480 -----------------------
481
482 function Exact_Source_Name (Loc : Source_Ptr) return String is
483 U : constant Unit_Number_Type := Get_Source_Unit (Loc);
484 Buf : constant Source_Buffer_Ptr := Source_Text (Source_Index (U));
485 Orig : constant Source_Ptr := Original_Location (Loc);
486 P : Source_Ptr;
487
488 WC : Char_Code;
489 Err : Boolean;
490 pragma Warnings (Off, WC);
491 pragma Warnings (Off, Err);
492
493 begin
494 -- Entity is character literal
495
496 if Buf (Orig) = ''' then
497 return String (Buf (Orig .. Orig + 2));
498
499 -- Entity is operator symbol
500
501 elsif Buf (Orig) = '"' or else Buf (Orig) = '%' then
502 P := Orig;
503
504 loop
505 P := P + 1;
506 exit when Buf (P) = Buf (Orig);
507 end loop;
508
509 return String (Buf (Orig .. P));
510
511 -- Entity is identifier
512
513 else
514 P := Orig;
515
516 loop
517 if Is_Start_Of_Wide_Char (Buf, P) then
518 Scan_Wide (Buf, P, WC, Err);
519 elsif not Identifier_Char (Buf (P)) then
520 exit;
521 else
522 P := P + 1;
523 end if;
524 end loop;
525
526 -- Write out the identifier by copying the exact source characters
527 -- used in its declaration. Note that this means wide characters will
528 -- be in their original encoded form.
529
530 return String (Buf (Orig .. P - 1));
531 end if;
532 end Exact_Source_Name;
533
534 ----------------------------
535 -- Entity_Is_In_Main_Unit --
536 ----------------------------
537
538 function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean is
539 S : Entity_Id;
540
541 begin
542 S := Scope (E);
543
544 while S /= Standard_Standard loop
545 if S = Main_Unit_Entity then
546 return True;
547 elsif Ekind (S) = E_Package and then Is_Child_Unit (S) then
548 return False;
549 else
550 S := Scope (S);
551 end if;
552 end loop;
553
554 return False;
555 end Entity_Is_In_Main_Unit;
556
557 --------------------------
558 -- Generic_May_Lack_ALI --
559 --------------------------
560
561 function Generic_May_Lack_ALI (Sfile : File_Name_Type) return Boolean is
562 begin
563 -- We allow internal generic units to be used without having a
564 -- corresponding ALI files to help bootstrapping with older compilers
565 -- that did not support generating ALIs for such generics. It is safe
566 -- to do so because the only thing the generated code would contain
567 -- is the elaboration boolean, and we are careful to elaborate all
568 -- predefined units first anyway.
569
570 return Is_Internal_File_Name
571 (Fname => Sfile,
572 Renamings_Included => True);
573 end Generic_May_Lack_ALI;
574
575 -----------------------------
576 -- Get_Code_Or_Source_Unit --
577 -----------------------------
578
579 function Get_Code_Or_Source_Unit
580 (S : Source_Ptr;
581 Unwind_Instances : Boolean;
582 Unwind_Subunits : Boolean) return Unit_Number_Type
583 is
584 begin
585 -- Search table unless we have No_Location, which can happen if the
586 -- relevant location has not been set yet. Happens for example when
587 -- we obtain Sloc (Cunit (Main_Unit)) before it is set.
588
589 if S /= No_Location then
590 declare
591 Source_File : Source_File_Index;
592 Source_Unit : Unit_Number_Type;
593 Unit_Node : Node_Id;
594
595 begin
596 Source_File := Get_Source_File_Index (S);
597
598 if Unwind_Instances then
599 while Template (Source_File) /= No_Source_File loop
600 Source_File := Template (Source_File);
601 end loop;
602 end if;
603
604 Source_Unit := Unit (Source_File);
605
606 if Unwind_Subunits then
607 Unit_Node := Unit (Cunit (Source_Unit));
608
609 while Nkind (Unit_Node) = N_Subunit
610 and then Present (Corresponding_Stub (Unit_Node))
611 loop
612 Source_Unit :=
613 Get_Code_Or_Source_Unit
614 (Sloc (Corresponding_Stub (Unit_Node)),
615 Unwind_Instances => Unwind_Instances,
616 Unwind_Subunits => Unwind_Subunits);
617 Unit_Node := Unit (Cunit (Source_Unit));
618 end loop;
619 end if;
620
621 if Source_Unit /= No_Unit then
622 return Source_Unit;
623 end if;
624 end;
625 end if;
626
627 -- If S was No_Location, or was not in the table, we must be in the main
628 -- source unit (and the value has not been placed in the table yet),
629 -- or in one of the configuration pragma files.
630
631 return Main_Unit;
632 end Get_Code_Or_Source_Unit;
633
634 -------------------
635 -- Get_Code_Unit --
636 -------------------
637
638 function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is
639 begin
640 return
641 Get_Code_Or_Source_Unit
642 (Top_Level_Location (S),
643 Unwind_Instances => False,
644 Unwind_Subunits => False);
645 end Get_Code_Unit;
646
647 function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
648 begin
649 return Get_Code_Unit (Sloc (N));
650 end Get_Code_Unit;
651
652 ----------------------------
653 -- Get_Compilation_Switch --
654 ----------------------------
655
656 function Get_Compilation_Switch (N : Pos) return String_Ptr is
657 begin
658 if N <= Compilation_Switches.Last then
659 return Compilation_Switches.Table (N);
660 else
661 return null;
662 end if;
663 end Get_Compilation_Switch;
664
665 ----------------------------------
666 -- Get_Cunit_Entity_Unit_Number --
667 ----------------------------------
668
669 function Get_Cunit_Entity_Unit_Number
670 (E : Entity_Id) return Unit_Number_Type
671 is
672 begin
673 for U in Units.First .. Units.Last loop
674 if Cunit_Entity (U) = E then
675 return U;
676 end if;
677 end loop;
678
679 -- If not in the table, must be the main source unit, and we just
680 -- have not got it put into the table yet.
681
682 return Main_Unit;
683 end Get_Cunit_Entity_Unit_Number;
684
685 ---------------------------
686 -- Get_Cunit_Unit_Number --
687 ---------------------------
688
689 function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type is
690 begin
691 for U in Units.First .. Units.Last loop
692 if Cunit (U) = N then
693 return U;
694 end if;
695 end loop;
696
697 -- If not in the table, must be a spec created for a main unit that is a
698 -- child subprogram body which we have not inserted into the table yet.
699
700 if N = Library_Unit (Cunit (Main_Unit)) then
701 return Main_Unit;
702
703 -- If it is anything else, something is seriously wrong, and we really
704 -- don't want to proceed, even if assertions are off, so we explicitly
705 -- raise an exception in this case to terminate compilation.
706
707 else
708 raise Program_Error;
709 end if;
710 end Get_Cunit_Unit_Number;
711
712 ---------------------
713 -- Get_Source_Unit --
714 ---------------------
715
716 function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is
717 begin
718 return
719 Get_Code_Or_Source_Unit
720 (S, Unwind_Instances => True, Unwind_Subunits => False);
721 end Get_Source_Unit;
722
723 function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
724 begin
725 return Get_Source_Unit (Sloc (N));
726 end Get_Source_Unit;
727
728 -----------------------------
729 -- Get_Top_Level_Code_Unit --
730 -----------------------------
731
732 function Get_Top_Level_Code_Unit (S : Source_Ptr) return Unit_Number_Type is
733 begin
734 return
735 Get_Code_Or_Source_Unit
736 (Top_Level_Location (S),
737 Unwind_Instances => False,
738 Unwind_Subunits => True);
739 end Get_Top_Level_Code_Unit;
740
741 function Get_Top_Level_Code_Unit
742 (N : Node_Or_Entity_Id) return Unit_Number_Type is
743 begin
744 return Get_Top_Level_Code_Unit (Sloc (N));
745 end Get_Top_Level_Code_Unit;
746
747 --------------------------------
748 -- In_Extended_Main_Code_Unit --
749 --------------------------------
750
751 function In_Extended_Main_Code_Unit
752 (N : Node_Or_Entity_Id) return Boolean
753 is
754 begin
755 if Sloc (N) = Standard_Location then
756 return False;
757
758 elsif Sloc (N) = No_Location then
759 return False;
760
761 -- Special case Itypes to test the Sloc of the associated node. The
762 -- reason we do this is for possible calls from gigi after -gnatD
763 -- processing is complete in sprint. This processing updates the
764 -- sloc fields of all nodes in the tree, but itypes are not in the
765 -- tree so their slocs do not get updated.
766
767 elsif Nkind (N) = N_Defining_Identifier
768 and then Is_Itype (N)
769 then
770 return In_Extended_Main_Code_Unit (Associated_Node_For_Itype (N));
771
772 -- Otherwise see if we are in the main unit
773
774 elsif Get_Code_Unit (Sloc (N)) = Get_Code_Unit (Cunit (Main_Unit)) then
775 return True;
776
777 -- Node may be in spec (or subunit etc) of main unit
778
779 else
780 return
781 In_Same_Extended_Unit (N, Cunit (Main_Unit));
782 end if;
783 end In_Extended_Main_Code_Unit;
784
785 function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean is
786 begin
787 if Loc = Standard_Location then
788 return False;
789
790 elsif Loc = No_Location then
791 return False;
792
793 -- Otherwise see if we are in the main unit
794
795 elsif Get_Code_Unit (Loc) = Get_Code_Unit (Cunit (Main_Unit)) then
796 return True;
797
798 -- Location may be in spec (or subunit etc) of main unit
799
800 else
801 return
802 In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit)));
803 end if;
804 end In_Extended_Main_Code_Unit;
805
806 ----------------------------------
807 -- In_Extended_Main_Source_Unit --
808 ----------------------------------
809
810 function In_Extended_Main_Source_Unit
811 (N : Node_Or_Entity_Id) return Boolean
812 is
813 Nloc : constant Source_Ptr := Sloc (N);
814 Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
815
816 begin
817 -- If parsing, then use the global flag to indicate result
818
819 if Compiler_State = Parsing then
820 return Parsing_Main_Extended_Source;
821
822 -- Special value cases
823
824 elsif Nloc = Standard_Location then
825 return False;
826
827 elsif Nloc = No_Location then
828 return False;
829
830 -- Special case Itypes to test the Sloc of the associated node. The
831 -- reason we do this is for possible calls from gigi after -gnatD
832 -- processing is complete in sprint. This processing updates the
833 -- sloc fields of all nodes in the tree, but itypes are not in the
834 -- tree so their slocs do not get updated.
835
836 elsif Nkind (N) = N_Defining_Identifier
837 and then Is_Itype (N)
838 then
839 return In_Extended_Main_Source_Unit (Associated_Node_For_Itype (N));
840
841 -- Otherwise compare original locations to see if in same unit
842
843 else
844 return
845 In_Same_Extended_Unit
846 (Original_Location (Nloc), Original_Location (Mloc));
847 end if;
848 end In_Extended_Main_Source_Unit;
849
850 function In_Extended_Main_Source_Unit
851 (Loc : Source_Ptr) return Boolean
852 is
853 Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
854
855 begin
856 -- If parsing, then use the global flag to indicate result
857
858 if Compiler_State = Parsing then
859 return Parsing_Main_Extended_Source;
860
861 -- Special value cases
862
863 elsif Loc = Standard_Location then
864 return False;
865
866 elsif Loc = No_Location then
867 return False;
868
869 -- Otherwise compare original locations to see if in same unit
870
871 else
872 return
873 In_Same_Extended_Unit
874 (Original_Location (Loc), Original_Location (Mloc));
875 end if;
876 end In_Extended_Main_Source_Unit;
877
878 ------------------------
879 -- In_Predefined_Unit --
880 ------------------------
881
882 function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean is
883 begin
884 return In_Predefined_Unit (Sloc (N));
885 end In_Predefined_Unit;
886
887 function In_Predefined_Unit (S : Source_Ptr) return Boolean is
888 Unit : constant Unit_Number_Type := Get_Source_Unit (S);
889 File : constant File_Name_Type := Unit_File_Name (Unit);
890 begin
891 return Is_Predefined_File_Name (File);
892 end In_Predefined_Unit;
893
894 -----------------------
895 -- In_Same_Code_Unit --
896 -----------------------
897
898 function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is
899 S1 : constant Source_Ptr := Sloc (N1);
900 S2 : constant Source_Ptr := Sloc (N2);
901
902 begin
903 if S1 = No_Location or else S2 = No_Location then
904 return False;
905
906 elsif S1 = Standard_Location then
907 return S2 = Standard_Location;
908
909 elsif S2 = Standard_Location then
910 return False;
911 end if;
912
913 return Get_Code_Unit (N1) = Get_Code_Unit (N2);
914 end In_Same_Code_Unit;
915
916 ---------------------------
917 -- In_Same_Extended_Unit --
918 ---------------------------
919
920 function In_Same_Extended_Unit
921 (N1, N2 : Node_Or_Entity_Id) return Boolean
922 is
923 begin
924 return Check_Same_Extended_Unit (Sloc (N1), Sloc (N2)) /= No;
925 end In_Same_Extended_Unit;
926
927 function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is
928 begin
929 return Check_Same_Extended_Unit (S1, S2) /= No;
930 end In_Same_Extended_Unit;
931
932 -------------------------
933 -- In_Same_Source_Unit --
934 -------------------------
935
936 function In_Same_Source_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is
937 S1 : constant Source_Ptr := Sloc (N1);
938 S2 : constant Source_Ptr := Sloc (N2);
939
940 begin
941 if S1 = No_Location or else S2 = No_Location then
942 return False;
943
944 elsif S1 = Standard_Location then
945 return S2 = Standard_Location;
946
947 elsif S2 = Standard_Location then
948 return False;
949 end if;
950
951 return Get_Source_Unit (N1) = Get_Source_Unit (N2);
952 end In_Same_Source_Unit;
953
954 -----------------------------
955 -- Increment_Serial_Number --
956 -----------------------------
957
958 function Increment_Serial_Number return Nat is
959 TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
960 begin
961 TSN := TSN + 1;
962 return TSN;
963 end Increment_Serial_Number;
964
965 ----------------
966 -- Initialize --
967 ----------------
968
969 procedure Initialize is
970 begin
971 Linker_Option_Lines.Init;
972 Notes.Init;
973 Load_Stack.Init;
974 Units.Init;
975 Compilation_Switches.Init;
976 end Initialize;
977
978 ---------------
979 -- Is_Loaded --
980 ---------------
981
982 function Is_Loaded (Uname : Unit_Name_Type) return Boolean is
983 begin
984 for Unum in Units.First .. Units.Last loop
985 if Uname = Unit_Name (Unum) then
986 return True;
987 end if;
988 end loop;
989
990 return False;
991 end Is_Loaded;
992
993 ---------------
994 -- Last_Unit --
995 ---------------
996
997 function Last_Unit return Unit_Number_Type is
998 begin
999 return Units.Last;
1000 end Last_Unit;
1001
1002 ----------
1003 -- List --
1004 ----------
1005
1006 procedure List (File_Names_Only : Boolean := False) is separate;
1007
1008 ----------
1009 -- Lock --
1010 ----------
1011
1012 procedure Lock is
1013 begin
1014 Linker_Option_Lines.Locked := True;
1015 Load_Stack.Locked := True;
1016 Units.Locked := True;
1017 Linker_Option_Lines.Release;
1018 Load_Stack.Release;
1019 Units.Release;
1020 end Lock;
1021
1022 ---------------
1023 -- Num_Units --
1024 ---------------
1025
1026 function Num_Units return Nat is
1027 begin
1028 return Int (Units.Last) - Int (Main_Unit) + 1;
1029 end Num_Units;
1030
1031 -----------------
1032 -- Remove_Unit --
1033 -----------------
1034
1035 procedure Remove_Unit (U : Unit_Number_Type) is
1036 begin
1037 if U = Units.Last then
1038 Units.Decrement_Last;
1039 end if;
1040 end Remove_Unit;
1041
1042 ----------------------------------
1043 -- Replace_Linker_Option_String --
1044 ----------------------------------
1045
1046 procedure Replace_Linker_Option_String
1047 (S : String_Id; Match_String : String)
1048 is
1049 begin
1050 if Match_String'Length > 0 then
1051 for J in 1 .. Linker_Option_Lines.Last loop
1052 String_To_Name_Buffer (Linker_Option_Lines.Table (J).Option);
1053
1054 if Match_String = Name_Buffer (1 .. Match_String'Length) then
1055 Linker_Option_Lines.Table (J).Option := S;
1056 return;
1057 end if;
1058 end loop;
1059 end if;
1060
1061 Store_Linker_Option_String (S);
1062 end Replace_Linker_Option_String;
1063
1064 ----------
1065 -- Sort --
1066 ----------
1067
1068 procedure Sort (Tbl : in out Unit_Ref_Table) is separate;
1069
1070 ------------------------------
1071 -- Store_Compilation_Switch --
1072 ------------------------------
1073
1074 procedure Store_Compilation_Switch (Switch : String) is
1075 begin
1076 if Switch_Storing_Enabled then
1077 Compilation_Switches.Increment_Last;
1078 Compilation_Switches.Table (Compilation_Switches.Last) :=
1079 new String'(Switch);
1080
1081 -- Fix up --RTS flag which has been transformed by the gcc driver
1082 -- into -fRTS
1083
1084 if Switch'Last >= Switch'First + 4
1085 and then Switch (Switch'First .. Switch'First + 4) = "-fRTS"
1086 then
1087 Compilation_Switches.Table
1088 (Compilation_Switches.Last) (Switch'First + 1) := '-';
1089 end if;
1090 end if;
1091 end Store_Compilation_Switch;
1092
1093 --------------------------------
1094 -- Store_Linker_Option_String --
1095 --------------------------------
1096
1097 procedure Store_Linker_Option_String (S : String_Id) is
1098 begin
1099 Linker_Option_Lines.Append ((Option => S, Unit => Current_Sem_Unit));
1100 end Store_Linker_Option_String;
1101
1102 ----------------
1103 -- Store_Note --
1104 ----------------
1105
1106 procedure Store_Note (N : Node_Id) is
1107 Sfile : constant Source_File_Index := Get_Source_File_Index (Sloc (N));
1108
1109 begin
1110 -- Notes for a generic are emitted when processing the template, never
1111 -- in instances.
1112
1113 if In_Extended_Main_Code_Unit (N)
1114 and then Instance (Sfile) = No_Instance_Id
1115 then
1116 Notes.Append (N);
1117 end if;
1118 end Store_Note;
1119
1120 -------------------------------
1121 -- Synchronize_Serial_Number --
1122 -------------------------------
1123
1124 procedure Synchronize_Serial_Number is
1125 TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
1126 begin
1127 TSN := TSN + 1;
1128 end Synchronize_Serial_Number;
1129
1130 ---------------
1131 -- Tree_Read --
1132 ---------------
1133
1134 procedure Tree_Read is
1135 N : Nat;
1136 S : String_Ptr;
1137
1138 begin
1139 Units.Tree_Read;
1140
1141 -- Read Compilation_Switches table. First release the memory occupied
1142 -- by the previously loaded switches.
1143
1144 for J in Compilation_Switches.First .. Compilation_Switches.Last loop
1145 Free (Compilation_Switches.Table (J));
1146 end loop;
1147
1148 Tree_Read_Int (N);
1149 Compilation_Switches.Set_Last (N);
1150
1151 for J in 1 .. N loop
1152 Tree_Read_Str (S);
1153 Compilation_Switches.Table (J) := S;
1154 end loop;
1155 end Tree_Read;
1156
1157 ----------------
1158 -- Tree_Write --
1159 ----------------
1160
1161 procedure Tree_Write is
1162 begin
1163 Units.Tree_Write;
1164
1165 -- Write Compilation_Switches table
1166
1167 Tree_Write_Int (Compilation_Switches.Last);
1168
1169 for J in 1 .. Compilation_Switches.Last loop
1170 Tree_Write_Str (Compilation_Switches.Table (J));
1171 end loop;
1172 end Tree_Write;
1173
1174 ------------
1175 -- Unlock --
1176 ------------
1177
1178 procedure Unlock is
1179 begin
1180 Linker_Option_Lines.Locked := False;
1181 Load_Stack.Locked := False;
1182 Units.Locked := False;
1183 end Unlock;
1184
1185 -----------------
1186 -- Version_Get --
1187 -----------------
1188
1189 function Version_Get (U : Unit_Number_Type) return Word_Hex_String is
1190 begin
1191 return Get_Hex_String (Units.Table (U).Version);
1192 end Version_Get;
1193
1194 ------------------------
1195 -- Version_Referenced --
1196 ------------------------
1197
1198 procedure Version_Referenced (S : String_Id) is
1199 begin
1200 Version_Ref.Append (S);
1201 end Version_Referenced;
1202
1203 ---------------------
1204 -- Write_Unit_Info --
1205 ---------------------
1206
1207 procedure Write_Unit_Info
1208 (Unit_Num : Unit_Number_Type;
1209 Item : Node_Id;
1210 Prefix : String := "";
1211 Withs : Boolean := False)
1212 is
1213 begin
1214 Write_Str (Prefix);
1215 Write_Unit_Name (Unit_Name (Unit_Num));
1216 Write_Str (", unit ");
1217 Write_Int (Int (Unit_Num));
1218 Write_Str (", ");
1219 Write_Int (Int (Item));
1220 Write_Str ("=");
1221 Write_Str (Node_Kind'Image (Nkind (Item)));
1222
1223 if Item /= Original_Node (Item) then
1224 Write_Str (", orig = ");
1225 Write_Int (Int (Original_Node (Item)));
1226 Write_Str ("=");
1227 Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
1228 end if;
1229
1230 Write_Eol;
1231
1232 -- Skip the rest if we're not supposed to print the withs
1233
1234 if not Withs then
1235 return;
1236 end if;
1237
1238 declare
1239 Context_Item : Node_Id;
1240
1241 begin
1242 Context_Item := First (Context_Items (Cunit (Unit_Num)));
1243 while Present (Context_Item)
1244 and then (Nkind (Context_Item) /= N_With_Clause
1245 or else Limited_Present (Context_Item))
1246 loop
1247 Context_Item := Next (Context_Item);
1248 end loop;
1249
1250 if Present (Context_Item) then
1251 Indent;
1252 Write_Line ("withs:");
1253 Indent;
1254
1255 while Present (Context_Item) loop
1256 if Nkind (Context_Item) = N_With_Clause
1257 and then not Limited_Present (Context_Item)
1258 then
1259 pragma Assert (Present (Library_Unit (Context_Item)));
1260 Write_Unit_Name
1261 (Unit_Name
1262 (Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
1263
1264 if Implicit_With (Context_Item) then
1265 Write_Str (" -- implicit");
1266 end if;
1267
1268 Write_Eol;
1269 end if;
1270
1271 Context_Item := Next (Context_Item);
1272 end loop;
1273
1274 Outdent;
1275 Write_Line ("end withs");
1276 Outdent;
1277 end if;
1278 end;
1279 end Write_Unit_Info;
1280
1281 end Lib;