1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 pragma Style_Checks
(All_Checks
);
33 -- Subprogram ordering not enforced in this unit
34 -- (because of some logical groupings).
36 with Atree
; use Atree
;
37 with Csets
; use Csets
;
38 with Einfo
; use Einfo
;
39 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
;
52 Switch_Storing_Enabled
: Boolean := True;
53 -- Controlled by Enable_Switch_Storing/Disable_Switch_Storing
55 -----------------------
56 -- Local Subprograms --
57 -----------------------
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
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.
69 function Get_Code_Or_Source_Unit
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.
80 --------------------------------------------
81 -- Access Functions for Unit Table Fields --
82 --------------------------------------------
84 function Cunit
(U
: Unit_Number_Type
) return Node_Id
is
86 return Units
.Table
(U
).Cunit
;
89 function Cunit_Entity
(U
: Unit_Number_Type
) return Entity_Id
is
91 return Units
.Table
(U
).Cunit_Entity
;
94 function Dependency_Num
(U
: Unit_Number_Type
) return Nat
is
96 return Units
.Table
(U
).Dependency_Num
;
99 function Dynamic_Elab
(U
: Unit_Number_Type
) return Boolean is
101 return Units
.Table
(U
).Dynamic_Elab
;
104 function Error_Location
(U
: Unit_Number_Type
) return Source_Ptr
is
106 return Units
.Table
(U
).Error_Location
;
109 function Expected_Unit
(U
: Unit_Number_Type
) return Unit_Name_Type
is
111 return Units
.Table
(U
).Expected_Unit
;
114 function Fatal_Error
(U
: Unit_Number_Type
) return Fatal_Type
is
116 return Units
.Table
(U
).Fatal_Error
;
119 function Generate_Code
(U
: Unit_Number_Type
) return Boolean is
121 return Units
.Table
(U
).Generate_Code
;
124 function Has_RACW
(U
: Unit_Number_Type
) return Boolean is
126 return Units
.Table
(U
).Has_RACW
;
129 function Is_Predefined_Renaming
(U
: Unit_Number_Type
) return Boolean is
131 return Units
.Table
(U
).Is_Predefined_Renaming
;
132 end Is_Predefined_Renaming
;
134 function Is_Internal_Unit
(U
: Unit_Number_Type
) return Boolean is
136 return Units
.Table
(U
).Is_Internal_Unit
;
137 end Is_Internal_Unit
;
139 function Is_Predefined_Unit
(U
: Unit_Number_Type
) return Boolean is
141 return Units
.Table
(U
).Is_Predefined_Unit
;
142 end Is_Predefined_Unit
;
144 function Ident_String
(U
: Unit_Number_Type
) return Node_Id
is
146 return Units
.Table
(U
).Ident_String
;
149 function Loading
(U
: Unit_Number_Type
) return Boolean is
151 return Units
.Table
(U
).Loading
;
154 function Main_CPU
(U
: Unit_Number_Type
) return Int
is
156 return Units
.Table
(U
).Main_CPU
;
159 function Main_Priority
(U
: Unit_Number_Type
) return Int
is
161 return Units
.Table
(U
).Main_Priority
;
164 function Munit_Index
(U
: Unit_Number_Type
) return Nat
is
166 return Units
.Table
(U
).Munit_Index
;
169 function No_Elab_Code_All
(U
: Unit_Number_Type
) return Boolean is
171 return Units
.Table
(U
).No_Elab_Code_All
;
172 end No_Elab_Code_All
;
174 function OA_Setting
(U
: Unit_Number_Type
) return Character is
176 return Units
.Table
(U
).OA_Setting
;
179 function Source_Index
(U
: Unit_Number_Type
) return Source_File_Index
is
181 return Units
.Table
(U
).Source_Index
;
184 function Unit_File_Name
(U
: Unit_Number_Type
) return File_Name_Type
is
186 return Units
.Table
(U
).Unit_File_Name
;
189 function Unit_Name
(U
: Unit_Number_Type
) return Unit_Name_Type
is
191 return Units
.Table
(U
).Unit_Name
;
194 ------------------------------------------
195 -- Subprograms to Set Unit Table Fields --
196 ------------------------------------------
198 procedure Set_Cunit
(U
: Unit_Number_Type
; N
: Node_Id
) is
200 Units
.Table
(U
).Cunit
:= N
;
203 procedure Set_Cunit_Entity
(U
: Unit_Number_Type
; E
: Entity_Id
) is
205 Units
.Table
(U
).Cunit_Entity
:= E
;
206 Set_Is_Compilation_Unit
(E
);
207 end Set_Cunit_Entity
;
209 procedure Set_Dynamic_Elab
(U
: Unit_Number_Type
; B
: Boolean := True) is
211 Units
.Table
(U
).Dynamic_Elab
:= B
;
212 end Set_Dynamic_Elab
;
214 procedure Set_Error_Location
(U
: Unit_Number_Type
; W
: Source_Ptr
) is
216 Units
.Table
(U
).Error_Location
:= W
;
217 end Set_Error_Location
;
219 procedure Set_Fatal_Error
(U
: Unit_Number_Type
; V
: Fatal_Type
) is
221 Units
.Table
(U
).Fatal_Error
:= V
;
224 procedure Set_Generate_Code
(U
: Unit_Number_Type
; B
: Boolean := True) is
226 Units
.Table
(U
).Generate_Code
:= B
;
227 end Set_Generate_Code
;
229 procedure Set_Has_RACW
(U
: Unit_Number_Type
; B
: Boolean := True) is
231 Units
.Table
(U
).Has_RACW
:= B
;
234 procedure Set_Ident_String
(U
: Unit_Number_Type
; N
: Node_Id
) is
236 Units
.Table
(U
).Ident_String
:= N
;
237 end Set_Ident_String
;
239 procedure Set_Loading
(U
: Unit_Number_Type
; B
: Boolean := True) is
241 Units
.Table
(U
).Loading
:= B
;
244 procedure Set_Main_CPU
(U
: Unit_Number_Type
; P
: Int
) is
246 Units
.Table
(U
).Main_CPU
:= P
;
249 procedure Set_Main_Priority
(U
: Unit_Number_Type
; P
: Int
) is
251 Units
.Table
(U
).Main_Priority
:= P
;
252 end Set_Main_Priority
;
254 procedure Set_No_Elab_Code_All
255 (U
: Unit_Number_Type
;
259 Units
.Table
(U
).No_Elab_Code_All
:= B
;
260 end Set_No_Elab_Code_All
;
262 procedure Set_OA_Setting
(U
: Unit_Number_Type
; C
: Character) is
264 Units
.Table
(U
).OA_Setting
:= C
;
267 procedure Set_Unit_Name
(U
: Unit_Number_Type
; N
: Unit_Name_Type
) is
269 Units
.Table
(U
).Unit_Name
:= N
;
272 ------------------------------
273 -- Check_Same_Extended_Unit --
274 ------------------------------
276 function Check_Same_Extended_Unit
(S1
, S2
: Source_Ptr
) return SEU_Result
is
277 Max_Iterations
: constant Nat
:= Maximum_Instantiations
* 2;
278 -- Limit to prevent a potential infinite loop
285 Sind1
: Source_File_Index
;
286 Sind2
: Source_File_Index
;
291 Unum1
: Unit_Number_Type
;
292 Unum2
: Unit_Number_Type
;
295 if S1
= No_Location
or else S2
= No_Location
then
298 elsif S1
= Standard_Location
then
299 if S2
= Standard_Location
then
305 elsif S2
= Standard_Location
then
312 Unum1
:= Get_Source_Unit
(Sloc1
);
313 Unum2
:= Get_Source_Unit
(Sloc2
);
316 -- Step 1: Check whether the two locations are in the same source
319 Sind1
:= Get_Source_File_Index
(Sloc1
);
320 Sind2
:= Get_Source_File_Index
(Sloc2
);
322 if Sind1
= Sind2
then
323 if Sloc1
< Sloc2
then
325 elsif Sloc1
> Sloc2
then
332 -- Step 2: Check subunits. If a subunit is instantiated, follow the
333 -- instantiation chain rather than the stub chain.
335 Unit1
:= Unit
(Cunit
(Unum1
));
336 Unit2
:= Unit
(Cunit
(Unum2
));
337 Inst1
:= Instantiation
(Sind1
);
338 Inst2
:= Instantiation
(Sind2
);
340 if Nkind
(Unit1
) = N_Subunit
341 and then Present
(Corresponding_Stub
(Unit1
))
342 and then Inst1
= No_Location
344 if Nkind
(Unit2
) = N_Subunit
345 and then Present
(Corresponding_Stub
(Unit2
))
346 and then Inst2
= No_Location
348 -- Both locations refer to subunits which may have a common
349 -- ancestor. If they do, the deeper subunit must have a longer
350 -- unit name. Replace the deeper one with its corresponding
351 -- stub in order to find the nearest ancestor.
353 if Length_Of_Name
(Unit_Name
(Unum1
)) <
354 Length_Of_Name
(Unit_Name
(Unum2
))
356 Sloc2
:= Sloc
(Corresponding_Stub
(Unit2
));
357 Unum2
:= Get_Source_Unit
(Sloc2
);
361 Sloc1
:= Sloc
(Corresponding_Stub
(Unit1
));
362 Unum1
:= Get_Source_Unit
(Sloc1
);
366 -- Sloc1 in subunit, Sloc2 not
369 Sloc1
:= Sloc
(Corresponding_Stub
(Unit1
));
370 Unum1
:= Get_Source_Unit
(Sloc1
);
374 -- Sloc2 in subunit, Sloc1 not
376 elsif Nkind
(Unit2
) = N_Subunit
377 and then Present
(Corresponding_Stub
(Unit2
))
378 and then Inst2
= No_Location
380 Sloc2
:= Sloc
(Corresponding_Stub
(Unit2
));
381 Unum2
:= Get_Source_Unit
(Sloc2
);
385 -- Step 3: Check instances. The two locations may yield a common
388 if Inst1
/= No_Location
then
389 if Inst2
/= No_Location
then
391 -- Both locations denote instantiations
393 Depth1
:= Instantiation_Depth
(Sloc1
);
394 Depth2
:= Instantiation_Depth
(Sloc2
);
396 if Depth1
< Depth2
then
398 Unum2
:= Get_Source_Unit
(Sloc2
);
401 elsif Depth1
> Depth2
then
403 Unum1
:= Get_Source_Unit
(Sloc1
);
409 Unum1
:= Get_Source_Unit
(Sloc1
);
410 Unum2
:= Get_Source_Unit
(Sloc2
);
414 -- Sloc1 is an instantiation
418 Unum1
:= Get_Source_Unit
(Sloc1
);
422 -- Sloc2 is an instantiation
424 elsif Inst2
/= No_Location
then
426 Unum2
:= Get_Source_Unit
(Sloc2
);
430 -- Step 4: One location in the spec, the other in the corresponding
431 -- body of the same unit. The location in the spec is considered
434 if Nkind
(Unit1
) = N_Subprogram_Body
436 Nkind
(Unit1
) = N_Package_Body
438 if Library_Unit
(Cunit
(Unum1
)) = Cunit
(Unum2
) then
442 elsif Nkind
(Unit2
) = N_Subprogram_Body
444 Nkind
(Unit2
) = N_Package_Body
446 if Library_Unit
(Cunit
(Unum2
)) = Cunit
(Unum1
) then
451 -- At this point it is certain that the two locations denote two
452 -- entirely separate units.
457 Counter
:= Counter
+ 1;
459 -- Prevent looping forever
461 if Counter
> Max_Iterations
then
462 -- ??? Not quite right, but return a value to be able to generate
463 -- SCIL files and hope for the best.
465 if CodePeer_Mode
then
472 end Check_Same_Extended_Unit
;
474 -------------------------------
475 -- Compilation_Switches_Last --
476 -------------------------------
478 function Compilation_Switches_Last
return Nat
is
480 return Compilation_Switches
.Last
;
481 end Compilation_Switches_Last
;
483 ---------------------------
484 -- Enable_Switch_Storing --
485 ---------------------------
487 procedure Enable_Switch_Storing
is
489 Switch_Storing_Enabled
:= True;
490 end Enable_Switch_Storing
;
492 ----------------------------
493 -- Disable_Switch_Storing --
494 ----------------------------
496 procedure Disable_Switch_Storing
is
498 Switch_Storing_Enabled
:= False;
499 end Disable_Switch_Storing
;
501 ------------------------------
502 -- Earlier_In_Extended_Unit --
503 ------------------------------
505 function Earlier_In_Extended_Unit
(S1
, S2
: Source_Ptr
) return Boolean is
507 return Check_Same_Extended_Unit
(S1
, S2
) = Yes_Before
;
508 end Earlier_In_Extended_Unit
;
510 -----------------------
511 -- Exact_Source_Name --
512 -----------------------
514 function Exact_Source_Name
(Loc
: Source_Ptr
) return String is
515 U
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
516 Buf
: constant Source_Buffer_Ptr
:= Source_Text
(Source_Index
(U
));
517 Orig
: constant Source_Ptr
:= Original_Location
(Loc
);
522 pragma Warnings
(Off
, WC
);
523 pragma Warnings
(Off
, Err
);
526 -- Entity is character literal
528 if Buf
(Orig
) = ''' then
529 return String (Buf
(Orig
.. Orig
+ 2));
531 -- Entity is operator symbol
533 elsif Buf
(Orig
) = '"' or else Buf
(Orig
) = '%' then
538 exit when Buf
(P
) = Buf
(Orig
);
541 return String (Buf
(Orig
.. P
));
543 -- Entity is identifier
549 if Is_Start_Of_Wide_Char
(Buf
, P
) then
550 Scan_Wide
(Buf
, P
, WC
, Err
);
551 elsif not Identifier_Char
(Buf
(P
)) then
558 -- Write out the identifier by copying the exact source characters
559 -- used in its declaration. Note that this means wide characters will
560 -- be in their original encoded form.
562 return String (Buf
(Orig
.. P
- 1));
564 end Exact_Source_Name
;
566 ----------------------------
567 -- Entity_Is_In_Main_Unit --
568 ----------------------------
570 function Entity_Is_In_Main_Unit
(E
: Entity_Id
) return Boolean is
576 while S
/= Standard_Standard
loop
577 if S
= Main_Unit_Entity
then
579 elsif Ekind
(S
) = E_Package
and then Is_Child_Unit
(S
) then
587 end Entity_Is_In_Main_Unit
;
589 --------------------------
590 -- Generic_May_Lack_ALI --
591 --------------------------
593 function Generic_May_Lack_ALI
(Unum
: Unit_Number_Type
) return Boolean is
595 -- We allow internal generic units to be used without having a
596 -- corresponding ALI files to help bootstrapping with older compilers
597 -- that did not support generating ALIs for such generics. It is safe
598 -- to do so because the only thing the generated code would contain
599 -- is the elaboration boolean, and we are careful to elaborate all
600 -- predefined units first anyway.
602 return Is_Internal_Unit
(Unum
);
603 end Generic_May_Lack_ALI
;
605 -----------------------------
606 -- Get_Code_Or_Source_Unit --
607 -----------------------------
609 function Get_Code_Or_Source_Unit
611 Unwind_Instances
: Boolean;
612 Unwind_Subunits
: Boolean) return Unit_Number_Type
615 -- Search table unless we have No_Location, which can happen if the
616 -- relevant location has not been set yet. Happens for example when
617 -- we obtain Sloc (Cunit (Main_Unit)) before it is set.
619 if S
/= No_Location
then
621 Source_File
: Source_File_Index
;
622 Source_Unit
: Unit_Number_Type
;
626 Source_File
:= Get_Source_File_Index
(S
);
628 if Unwind_Instances
then
629 while Template
(Source_File
) /= No_Source_File
loop
630 Source_File
:= Template
(Source_File
);
634 Source_Unit
:= Unit
(Source_File
);
636 if Unwind_Subunits
then
637 Unit_Node
:= Unit
(Cunit
(Source_Unit
));
639 while Nkind
(Unit_Node
) = N_Subunit
640 and then Present
(Corresponding_Stub
(Unit_Node
))
643 Get_Code_Or_Source_Unit
644 (Sloc
(Corresponding_Stub
(Unit_Node
)),
645 Unwind_Instances
=> Unwind_Instances
,
646 Unwind_Subunits
=> Unwind_Subunits
);
647 Unit_Node
:= Unit
(Cunit
(Source_Unit
));
651 if Source_Unit
/= No_Unit
then
657 -- If S was No_Location, or was not in the table, we must be in the main
658 -- source unit (and the value has not been placed in the table yet),
659 -- or in one of the configuration pragma files.
662 end Get_Code_Or_Source_Unit
;
668 function Get_Code_Unit
(S
: Source_Ptr
) return Unit_Number_Type
is
671 Get_Code_Or_Source_Unit
672 (Top_Level_Location
(S
),
673 Unwind_Instances
=> False,
674 Unwind_Subunits
=> False);
677 function Get_Code_Unit
(N
: Node_Or_Entity_Id
) return Unit_Number_Type
is
679 return Get_Code_Unit
(Sloc
(N
));
682 ----------------------------
683 -- Get_Compilation_Switch --
684 ----------------------------
686 function Get_Compilation_Switch
(N
: Pos
) return String_Ptr
is
688 if N
<= Compilation_Switches
.Last
then
689 return Compilation_Switches
.Table
(N
);
693 end Get_Compilation_Switch
;
695 ----------------------------------
696 -- Get_Cunit_Entity_Unit_Number --
697 ----------------------------------
699 function Get_Cunit_Entity_Unit_Number
700 (E
: Entity_Id
) return Unit_Number_Type
703 for U
in Units
.First
.. Units
.Last
loop
704 if Cunit_Entity
(U
) = E
then
709 -- If not in the table, must be the main source unit, and we just
710 -- have not got it put into the table yet.
713 end Get_Cunit_Entity_Unit_Number
;
715 ---------------------------
716 -- Get_Cunit_Unit_Number --
717 ---------------------------
719 function Get_Cunit_Unit_Number
(N
: Node_Id
) return Unit_Number_Type
is
721 for U
in Units
.First
.. Units
.Last
loop
722 if Cunit
(U
) = N
then
727 -- If not in the table, must be a spec created for a main unit that is a
728 -- child subprogram body which we have not inserted into the table yet.
730 if N
= Library_Unit
(Cunit
(Main_Unit
)) then
733 -- If it is anything else, something is seriously wrong, and we really
734 -- don't want to proceed, even if assertions are off, so we explicitly
735 -- raise an exception in this case to terminate compilation.
740 end Get_Cunit_Unit_Number
;
742 ---------------------
743 -- Get_Source_Unit --
744 ---------------------
746 function Get_Source_Unit
(S
: Source_Ptr
) return Unit_Number_Type
is
749 Get_Code_Or_Source_Unit
750 (S
, Unwind_Instances
=> True, Unwind_Subunits
=> False);
753 function Get_Source_Unit
(N
: Node_Or_Entity_Id
) return Unit_Number_Type
is
755 return Get_Source_Unit
(Sloc
(N
));
758 -----------------------------
759 -- Get_Top_Level_Code_Unit --
760 -----------------------------
762 function Get_Top_Level_Code_Unit
(S
: Source_Ptr
) return Unit_Number_Type
is
765 Get_Code_Or_Source_Unit
766 (Top_Level_Location
(S
),
767 Unwind_Instances
=> False,
768 Unwind_Subunits
=> True);
769 end Get_Top_Level_Code_Unit
;
771 function Get_Top_Level_Code_Unit
772 (N
: Node_Or_Entity_Id
) return Unit_Number_Type
is
774 return Get_Top_Level_Code_Unit
(Sloc
(N
));
775 end Get_Top_Level_Code_Unit
;
777 --------------------------------
778 -- In_Extended_Main_Code_Unit --
779 --------------------------------
781 function In_Extended_Main_Code_Unit
782 (N
: Node_Or_Entity_Id
) return Boolean
785 if Sloc
(N
) = Standard_Location
then
788 elsif Sloc
(N
) = No_Location
then
791 -- Special case Itypes to test the Sloc of the associated node. The
792 -- reason we do this is for possible calls from gigi after -gnatD
793 -- processing is complete in sprint. This processing updates the
794 -- sloc fields of all nodes in the tree, but itypes are not in the
795 -- tree so their slocs do not get updated.
797 elsif Nkind
(N
) = N_Defining_Identifier
798 and then Is_Itype
(N
)
800 return In_Extended_Main_Code_Unit
(Associated_Node_For_Itype
(N
));
802 -- Otherwise see if we are in the main unit
804 elsif Get_Code_Unit
(Sloc
(N
)) = Get_Code_Unit
(Cunit
(Main_Unit
)) then
807 -- Node may be in spec (or subunit etc) of main unit
811 In_Same_Extended_Unit
(N
, Cunit
(Main_Unit
));
813 end In_Extended_Main_Code_Unit
;
815 function In_Extended_Main_Code_Unit
(Loc
: Source_Ptr
) return Boolean is
817 if Loc
= Standard_Location
then
820 elsif Loc
= No_Location
then
823 -- Otherwise see if we are in the main unit
825 elsif Get_Code_Unit
(Loc
) = Get_Code_Unit
(Cunit
(Main_Unit
)) then
828 -- Location may be in spec (or subunit etc) of main unit
832 In_Same_Extended_Unit
(Loc
, Sloc
(Cunit
(Main_Unit
)));
834 end In_Extended_Main_Code_Unit
;
836 ----------------------------------
837 -- In_Extended_Main_Source_Unit --
838 ----------------------------------
840 function In_Extended_Main_Source_Unit
841 (N
: Node_Or_Entity_Id
) return Boolean
843 Nloc
: constant Source_Ptr
:= Sloc
(N
);
844 Mloc
: constant Source_Ptr
:= Sloc
(Cunit
(Main_Unit
));
847 -- If parsing, then use the global flag to indicate result
849 if Compiler_State
= Parsing
then
850 return Parsing_Main_Extended_Source
;
852 -- Special value cases
854 elsif Nloc
= Standard_Location
then
857 elsif Nloc
= No_Location
then
860 -- Special case Itypes to test the Sloc of the associated node. The
861 -- reason we do this is for possible calls from gigi after -gnatD
862 -- processing is complete in sprint. This processing updates the
863 -- sloc fields of all nodes in the tree, but itypes are not in the
864 -- tree so their slocs do not get updated.
866 elsif Nkind
(N
) = N_Defining_Identifier
867 and then Is_Itype
(N
)
869 return In_Extended_Main_Source_Unit
(Associated_Node_For_Itype
(N
));
871 -- Otherwise compare original locations to see if in same unit
875 In_Same_Extended_Unit
876 (Original_Location
(Nloc
), Original_Location
(Mloc
));
878 end In_Extended_Main_Source_Unit
;
880 function In_Extended_Main_Source_Unit
881 (Loc
: Source_Ptr
) return Boolean
883 Mloc
: constant Source_Ptr
:= Sloc
(Cunit
(Main_Unit
));
886 -- If parsing, then use the global flag to indicate result
888 if Compiler_State
= Parsing
then
889 return Parsing_Main_Extended_Source
;
891 -- Special value cases
893 elsif Loc
= Standard_Location
then
896 elsif Loc
= No_Location
then
899 -- Otherwise compare original locations to see if in same unit
903 In_Same_Extended_Unit
904 (Original_Location
(Loc
), Original_Location
(Mloc
));
906 end In_Extended_Main_Source_Unit
;
908 ----------------------
909 -- In_Internal_Unit --
910 ----------------------
912 function In_Internal_Unit
(N
: Node_Or_Entity_Id
) return Boolean is
914 return In_Internal_Unit
(Sloc
(N
));
915 end In_Internal_Unit
;
917 function In_Internal_Unit
(S
: Source_Ptr
) return Boolean is
918 Unit
: constant Unit_Number_Type
:= Get_Source_Unit
(S
);
920 return Is_Internal_Unit
(Unit
);
921 end In_Internal_Unit
;
923 ----------------------------
924 -- In_Predefined_Renaming --
925 ----------------------------
927 function In_Predefined_Renaming
(N
: Node_Or_Entity_Id
) return Boolean is
929 return In_Predefined_Renaming
(Sloc
(N
));
930 end In_Predefined_Renaming
;
932 function In_Predefined_Renaming
(S
: Source_Ptr
) return Boolean is
933 Unit
: constant Unit_Number_Type
:= Get_Source_Unit
(S
);
935 return Is_Predefined_Renaming
(Unit
);
936 end In_Predefined_Renaming
;
938 ------------------------
939 -- In_Predefined_Unit --
940 ------------------------
942 function In_Predefined_Unit
(N
: Node_Or_Entity_Id
) return Boolean is
944 return In_Predefined_Unit
(Sloc
(N
));
945 end In_Predefined_Unit
;
947 function In_Predefined_Unit
(S
: Source_Ptr
) return Boolean is
948 Unit
: constant Unit_Number_Type
:= Get_Source_Unit
(S
);
950 return Is_Predefined_Unit
(Unit
);
951 end In_Predefined_Unit
;
953 -----------------------
954 -- In_Same_Code_Unit --
955 -----------------------
957 function In_Same_Code_Unit
(N1
, N2
: Node_Or_Entity_Id
) return Boolean is
958 S1
: constant Source_Ptr
:= Sloc
(N1
);
959 S2
: constant Source_Ptr
:= Sloc
(N2
);
962 if S1
= No_Location
or else S2
= No_Location
then
965 elsif S1
= Standard_Location
then
966 return S2
= Standard_Location
;
968 elsif S2
= Standard_Location
then
972 return Get_Code_Unit
(N1
) = Get_Code_Unit
(N2
);
973 end In_Same_Code_Unit
;
975 ---------------------------
976 -- In_Same_Extended_Unit --
977 ---------------------------
979 function In_Same_Extended_Unit
980 (N1
, N2
: Node_Or_Entity_Id
) return Boolean
983 return Check_Same_Extended_Unit
(Sloc
(N1
), Sloc
(N2
)) /= No
;
984 end In_Same_Extended_Unit
;
986 function In_Same_Extended_Unit
(S1
, S2
: Source_Ptr
) return Boolean is
988 return Check_Same_Extended_Unit
(S1
, S2
) /= No
;
989 end In_Same_Extended_Unit
;
991 -------------------------
992 -- In_Same_Source_Unit --
993 -------------------------
995 function In_Same_Source_Unit
(N1
, N2
: Node_Or_Entity_Id
) return Boolean is
996 S1
: constant Source_Ptr
:= Sloc
(N1
);
997 S2
: constant Source_Ptr
:= Sloc
(N2
);
1000 if S1
= No_Location
or else S2
= No_Location
then
1003 elsif S1
= Standard_Location
then
1004 return S2
= Standard_Location
;
1006 elsif S2
= Standard_Location
then
1010 return Get_Source_Unit
(N1
) = Get_Source_Unit
(N2
);
1011 end In_Same_Source_Unit
;
1013 -----------------------------
1014 -- Increment_Serial_Number --
1015 -----------------------------
1017 function Increment_Serial_Number
return Nat
is
1018 TSN
: Int
renames Units
.Table
(Current_Sem_Unit
).Serial_Number
;
1022 end Increment_Serial_Number
;
1028 procedure Initialize
is
1030 Linker_Option_Lines
.Init
;
1034 Compilation_Switches
.Init
;
1041 function Is_Loaded
(Uname
: Unit_Name_Type
) return Boolean is
1043 for Unum
in Units
.First
.. Units
.Last
loop
1044 if Uname
= Unit_Name
(Unum
) then
1056 function Last_Unit
return Unit_Number_Type
is
1065 procedure List
(File_Names_Only
: Boolean := False) is separate;
1073 Linker_Option_Lines
.Release
;
1074 Linker_Option_Lines
.Locked
:= True;
1076 Load_Stack
.Locked
:= True;
1078 Units
.Locked
:= True;
1085 function Num_Units
return Nat
is
1087 return Int
(Units
.Last
) - Int
(Main_Unit
) + 1;
1094 procedure Remove_Unit
(U
: Unit_Number_Type
) is
1096 if U
= Units
.Last
then
1097 Units
.Decrement_Last
;
1101 ----------------------------------
1102 -- Replace_Linker_Option_String --
1103 ----------------------------------
1105 procedure Replace_Linker_Option_String
1106 (S
: String_Id
; Match_String
: String)
1109 if Match_String
'Length > 0 then
1110 for J
in 1 .. Linker_Option_Lines
.Last
loop
1111 String_To_Name_Buffer
(Linker_Option_Lines
.Table
(J
).Option
);
1113 if Match_String
= Name_Buffer
(1 .. Match_String
'Length) then
1114 Linker_Option_Lines
.Table
(J
).Option
:= S
;
1120 Store_Linker_Option_String
(S
);
1121 end Replace_Linker_Option_String
;
1127 procedure Sort
(Tbl
: in out Unit_Ref_Table
) is separate;
1129 ------------------------------
1130 -- Store_Compilation_Switch --
1131 ------------------------------
1133 procedure Store_Compilation_Switch
(Switch
: String) is
1135 if Switch_Storing_Enabled
then
1136 Compilation_Switches
.Increment_Last
;
1137 Compilation_Switches
.Table
(Compilation_Switches
.Last
) :=
1138 new String'(Switch);
1140 -- Fix up --RTS flag which has been transformed by the gcc driver
1143 if Switch'Last >= Switch'First + 4
1144 and then Switch (Switch'First .. Switch'First + 4) = "-fRTS"
1146 Compilation_Switches.Table
1147 (Compilation_Switches.Last) (Switch'First + 1) := '-';
1150 end Store_Compilation_Switch;
1152 --------------------------------
1153 -- Store_Linker_Option_String --
1154 --------------------------------
1156 procedure Store_Linker_Option_String (S : String_Id) is
1158 Linker_Option_Lines.Append ((Option => S, Unit => Current_Sem_Unit));
1159 end Store_Linker_Option_String;
1165 procedure Store_Note (N : Node_Id) is
1166 Sfile : constant Source_File_Index := Get_Source_File_Index (Sloc (N));
1169 -- Notes for a generic are emitted when processing the template, never
1172 if In_Extended_Main_Code_Unit (N)
1173 and then Instance (Sfile) = No_Instance_Id
1179 -------------------------------
1180 -- Synchronize_Serial_Number --
1181 -------------------------------
1183 procedure Synchronize_Serial_Number is
1184 TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
1187 end Synchronize_Serial_Number;
1193 procedure Tree_Read is
1200 -- Read Compilation_Switches table. First release the memory occupied
1201 -- by the previously loaded switches.
1203 for J in Compilation_Switches.First .. Compilation_Switches.Last loop
1204 Free (Compilation_Switches.Table (J));
1208 Compilation_Switches.Set_Last (N);
1210 for J in 1 .. N loop
1212 Compilation_Switches.Table (J) := S;
1220 procedure Tree_Write is
1224 -- Write Compilation_Switches table
1226 Tree_Write_Int (Compilation_Switches.Last);
1228 for J in 1 .. Compilation_Switches.Last loop
1229 Tree_Write_Str (Compilation_Switches.Table (J));
1239 Linker_Option_Lines.Locked := False;
1240 Load_Stack.Locked := False;
1241 Units.Locked := False;
1248 function Version_Get (U : Unit_Number_Type) return Word_Hex_String is
1250 return Get_Hex_String (Units.Table (U).Version);
1253 ------------------------
1254 -- Version_Referenced --
1255 ------------------------
1257 procedure Version_Referenced (S : String_Id) is
1259 Version_Ref.Append (S);
1260 end Version_Referenced;
1262 ---------------------
1263 -- Write_Unit_Info --
1264 ---------------------
1266 procedure Write_Unit_Info
1267 (Unit_Num : Unit_Number_Type;
1269 Prefix : String := "";
1270 Withs : Boolean := False)
1274 Write_Unit_Name (Unit_Name (Unit_Num));
1275 Write_Str (", unit ");
1276 Write_Int (Int (Unit_Num));
1278 Write_Int (Int (Item));
1280 Write_Str (Node_Kind'Image (Nkind (Item)));
1282 if Item /= Original_Node (Item) then
1283 Write_Str (", orig = ");
1284 Write_Int (Int (Original_Node (Item)));
1286 Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
1291 -- Skip the rest if we're not supposed to print the withs
1298 Context_Item : Node_Id;
1301 Context_Item := First (Context_Items (Cunit (Unit_Num)));
1302 while Present (Context_Item)
1303 and then (Nkind (Context_Item) /= N_With_Clause
1304 or else Limited_Present (Context_Item))
1306 Context_Item := Next (Context_Item);
1309 if Present (Context_Item) then
1311 Write_Line ("withs:");
1314 while Present (Context_Item) loop
1315 if Nkind (Context_Item) = N_With_Clause
1316 and then not Limited_Present (Context_Item)
1318 pragma Assert (Present (Library_Unit (Context_Item)));
1321 (Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
1323 if Implicit_With (Context_Item) then
1324 Write_Str (" -- implicit");
1330 Context_Item := Next (Context_Item);
1334 Write_Line ("end withs");
1338 end Write_Unit_Info;