1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 pragma Style_Checks
(All_Checks
);
27 -- Subprogram ordering not enforced in this unit
28 -- (because of some logical groupings).
30 with Atree
; use Atree
;
31 with Csets
; use Csets
;
32 with Einfo
; use Einfo
;
33 with Einfo
.Entities
; use Einfo
.Entities
;
34 with Nlists
; use Nlists
;
36 with Output
; use Output
;
37 with Sinfo
; use Sinfo
;
38 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
39 with Sinput
; use Sinput
;
40 with Stand
; use Stand
;
41 with Stringt
; use Stringt
;
42 with Uname
; use Uname
;
43 with Widechar
; use Widechar
;
47 Switch_Storing_Enabled
: Boolean := True;
48 -- Controlled by Enable_Switch_Storing/Disable_Switch_Storing
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
55 Yes_Before
, -- S1 is in same extended unit as S2 and appears before it
56 Yes_Same
, -- S1 is in same extended unit as S2, Slocs are the same
57 Yes_After
, -- S1 is in same extended unit as S2, and appears after it
58 No
); -- S2 is not in same extended unit as S2
60 function Check_Same_Extended_Unit
62 S2
: Source_Ptr
) return SEU_Result
;
63 -- Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns
64 -- value as described above.
66 function Get_Code_Or_Source_Unit
68 Unwind_Instances
: Boolean;
69 Unwind_Subunits
: Boolean) return Unit_Number_Type
;
70 -- Common processing for routines Get_Code_Unit, Get_Source_Unit, and
71 -- Get_Top_Level_Code_Unit. Unwind_Instances is True when the unit for the
72 -- top-level instantiation should be returned instead of the unit for the
73 -- template, in the case of an instantiation. Unwind_Subunits is True when
74 -- the corresponding top-level unit should be returned instead of a
75 -- subunit, in the case of a subunit.
77 --------------------------------------------
78 -- Access Functions for Unit Table Fields --
79 --------------------------------------------
81 function Cunit
(U
: Unit_Number_Type
) return Node_Id
is
83 return Units
.Table
(U
).Cunit
;
86 function Cunit_Entity
(U
: Unit_Number_Type
) return Entity_Id
is
88 return Units
.Table
(U
).Cunit_Entity
;
91 function Dependency_Num
(U
: Unit_Number_Type
) return Nat
is
93 return Units
.Table
(U
).Dependency_Num
;
96 function Dynamic_Elab
(U
: Unit_Number_Type
) return Boolean is
98 return Units
.Table
(U
).Dynamic_Elab
;
101 function Error_Location
(U
: Unit_Number_Type
) return Source_Ptr
is
103 return Units
.Table
(U
).Error_Location
;
106 function Expected_Unit
(U
: Unit_Number_Type
) return Unit_Name_Type
is
108 return Units
.Table
(U
).Expected_Unit
;
111 function Fatal_Error
(U
: Unit_Number_Type
) return Fatal_Type
is
113 return Units
.Table
(U
).Fatal_Error
;
116 function Generate_Code
(U
: Unit_Number_Type
) return Boolean is
118 return Units
.Table
(U
).Generate_Code
;
121 function Has_RACW
(U
: Unit_Number_Type
) return Boolean is
123 return Units
.Table
(U
).Has_RACW
;
126 function Is_Predefined_Renaming
(U
: Unit_Number_Type
) return Boolean is
128 return Units
.Table
(U
).Is_Predefined_Renaming
;
129 end Is_Predefined_Renaming
;
131 function Is_Internal_Unit
(U
: Unit_Number_Type
) return Boolean is
133 return Units
.Table
(U
).Is_Internal_Unit
;
134 end Is_Internal_Unit
;
136 function Is_Predefined_Unit
(U
: Unit_Number_Type
) return Boolean is
138 return Units
.Table
(U
).Is_Predefined_Unit
;
139 end Is_Predefined_Unit
;
141 function Ident_String
(U
: Unit_Number_Type
) return Node_Id
is
143 return Units
.Table
(U
).Ident_String
;
146 function Loading
(U
: Unit_Number_Type
) return Boolean is
148 return Units
.Table
(U
).Loading
;
151 function Main_CPU
(U
: Unit_Number_Type
) return Int
is
153 return Units
.Table
(U
).Main_CPU
;
156 function Main_Priority
(U
: Unit_Number_Type
) return Int
is
158 return Units
.Table
(U
).Main_Priority
;
161 function Munit_Index
(U
: Unit_Number_Type
) return Nat
is
163 return Units
.Table
(U
).Munit_Index
;
166 function No_Elab_Code_All
(U
: Unit_Number_Type
) return Boolean is
168 return Units
.Table
(U
).No_Elab_Code_All
;
169 end No_Elab_Code_All
;
171 function OA_Setting
(U
: Unit_Number_Type
) return Character is
173 return Units
.Table
(U
).OA_Setting
;
176 function Primary_Stack_Count
(U
: Unit_Number_Type
) return Int
is
178 return Units
.Table
(U
).Primary_Stack_Count
;
179 end Primary_Stack_Count
;
181 function Sec_Stack_Count
(U
: Unit_Number_Type
) return Int
is
183 return Units
.Table
(U
).Sec_Stack_Count
;
186 function Source_Index
(U
: Unit_Number_Type
) return Source_File_Index
is
188 return Units
.Table
(U
).Source_Index
;
191 function Unit_File_Name
(U
: Unit_Number_Type
) return File_Name_Type
is
193 return Units
.Table
(U
).Unit_File_Name
;
196 function Unit_Name
(U
: Unit_Number_Type
) return Unit_Name_Type
is
198 return Units
.Table
(U
).Unit_Name
;
201 ------------------------------------------
202 -- Subprograms to Set Unit Table Fields --
203 ------------------------------------------
205 procedure Set_Cunit
(U
: Unit_Number_Type
; N
: Node_Id
) is
207 Units
.Table
(U
).Cunit
:= N
;
210 procedure Set_Cunit_Entity
(U
: Unit_Number_Type
; E
: Entity_Id
) is
212 Units
.Table
(U
).Cunit_Entity
:= E
;
213 Set_Is_Compilation_Unit
(E
);
214 end Set_Cunit_Entity
;
216 procedure Set_Dynamic_Elab
(U
: Unit_Number_Type
; B
: Boolean := True) is
218 Units
.Table
(U
).Dynamic_Elab
:= B
;
219 end Set_Dynamic_Elab
;
221 procedure Set_Error_Location
(U
: Unit_Number_Type
; W
: Source_Ptr
) is
223 Units
.Table
(U
).Error_Location
:= W
;
224 end Set_Error_Location
;
226 procedure Set_Fatal_Error
(U
: Unit_Number_Type
; V
: Fatal_Type
) is
228 Units
.Table
(U
).Fatal_Error
:= V
;
231 procedure Set_Generate_Code
(U
: Unit_Number_Type
; B
: Boolean := True) is
233 Units
.Table
(U
).Generate_Code
:= B
;
234 end Set_Generate_Code
;
236 procedure Set_Has_RACW
(U
: Unit_Number_Type
; B
: Boolean := True) is
238 Units
.Table
(U
).Has_RACW
:= B
;
241 procedure Set_Ident_String
(U
: Unit_Number_Type
; N
: Node_Id
) is
243 Units
.Table
(U
).Ident_String
:= N
;
244 end Set_Ident_String
;
246 procedure Set_Loading
(U
: Unit_Number_Type
; B
: Boolean := True) is
248 Units
.Table
(U
).Loading
:= B
;
251 procedure Set_Main_CPU
(U
: Unit_Number_Type
; P
: Int
) is
253 Units
.Table
(U
).Main_CPU
:= P
;
256 procedure Set_Main_Priority
(U
: Unit_Number_Type
; P
: Int
) is
258 Units
.Table
(U
).Main_Priority
:= P
;
259 end Set_Main_Priority
;
261 procedure Set_No_Elab_Code_All
262 (U
: Unit_Number_Type
;
266 Units
.Table
(U
).No_Elab_Code_All
:= B
;
267 end Set_No_Elab_Code_All
;
269 procedure Set_OA_Setting
(U
: Unit_Number_Type
; C
: Character) is
271 Units
.Table
(U
).OA_Setting
:= C
;
274 procedure Set_Unit_Name
(U
: Unit_Number_Type
; N
: Unit_Name_Type
) is
275 Old_N
: constant Unit_Name_Type
:= Units
.Table
(U
).Unit_Name
;
278 -- First unregister the old name, if any
280 if Present
(Old_N
) and then Unit_Names
.Get
(Old_N
) = U
then
281 Unit_Names
.Set
(Old_N
, No_Unit
);
284 -- Then set the new name
286 Units
.Table
(U
).Unit_Name
:= N
;
288 -- Finally register the new name
290 if Unit_Names
.Get
(N
) = No_Unit
then
291 Unit_Names
.Set
(N
, U
);
295 ------------------------------
296 -- Check_Same_Extended_Unit --
297 ------------------------------
299 function Check_Same_Extended_Unit
301 S2
: Source_Ptr
) return SEU_Result
303 Max_Iterations
: constant Nat
:= Maximum_Instantiations
* 2;
304 -- Limit to prevent a potential infinite loop
311 Sind1
: Source_File_Index
;
312 Sind2
: Source_File_Index
;
317 Unum1
: Unit_Number_Type
;
318 Unum2
: Unit_Number_Type
;
321 if S1
= No_Location
or else S2
= No_Location
then
329 if S1
= Standard_Location
or else S2
= Standard_Location
then
336 Unum1
:= Get_Source_Unit
(Sloc1
);
337 Unum2
:= Get_Source_Unit
(Sloc2
);
340 -- Step 1: Check whether the two locations are in the same source
343 Sind1
:= Get_Source_File_Index
(Sloc1
);
344 Sind2
:= Get_Source_File_Index
(Sloc2
);
346 if Sind1
= Sind2
then
347 if Sloc1
< Sloc2
then
349 elsif Sloc1
> Sloc2
then
356 -- Step 2: Check subunits. If a subunit is instantiated, follow the
357 -- instantiation chain rather than the stub chain.
359 -- Note that we must handle the case where the subunit exists in the
360 -- same body as the main unit (which may happen when Naming gets
361 -- manually specified within a project file or through tools like
362 -- gprname). Otherwise, we will have an infinite loop jumping around
365 Unit1
:= Unit
(Cunit
(Unum1
));
366 Unit2
:= Unit
(Cunit
(Unum2
));
367 Inst1
:= Instantiation
(Sind1
);
368 Inst2
:= Instantiation
(Sind2
);
370 if Nkind
(Unit1
) = N_Subunit
371 and then Present
(Corresponding_Stub
(Unit1
))
372 and then Inst1
= No_Location
374 if Nkind
(Unit2
) = N_Subunit
375 and then Present
(Corresponding_Stub
(Unit2
))
376 and then Inst2
= No_Location
378 -- Both locations refer to subunits which may have a common
379 -- ancestor. If they do, the deeper subunit must have a longer
380 -- unit name. Replace the deeper one with its corresponding
381 -- stub in order to find the nearest ancestor.
383 if Length_Of_Name
(Unit_Name
(Unum1
)) <
384 Length_Of_Name
(Unit_Name
(Unum2
))
386 Sloc2
:= Sloc
(Corresponding_Stub
(Unit2
));
388 if Unum2
/= Get_Source_Unit
(Sloc2
) then
389 Unum2
:= Get_Source_Unit
(Sloc2
);
392 null; -- Unum2 already designates the correct unit
395 Sloc1
:= Sloc
(Corresponding_Stub
(Unit1
));
397 if Unum1
/= Get_Source_Unit
(Sloc1
) then
398 Unum1
:= Get_Source_Unit
(Sloc1
);
401 null; -- Unum1 already designates the correct unit
405 -- Sloc1 in subunit, Sloc2 not
408 Sloc1
:= Sloc
(Corresponding_Stub
(Unit1
));
410 if Unum1
/= Get_Source_Unit
(Sloc1
) then
411 Unum1
:= Get_Source_Unit
(Sloc1
);
414 null; -- Unum1 already designates the correct unit
418 -- Sloc2 in subunit, Sloc1 not
420 elsif Nkind
(Unit2
) = N_Subunit
421 and then Present
(Corresponding_Stub
(Unit2
))
422 and then Inst2
= No_Location
424 Sloc2
:= Sloc
(Corresponding_Stub
(Unit2
));
426 if Unum2
/= Get_Source_Unit
(Sloc2
) then
427 Unum2
:= Get_Source_Unit
(Sloc2
);
430 null; -- Unum2 already designates the correct unit
434 -- Step 3: Check instances. The two locations may yield a common
437 if Inst1
/= No_Location
then
438 if Inst2
/= No_Location
then
440 -- Both locations denote instantiations
442 Depth1
:= Instantiation_Depth
(Sloc1
);
443 Depth2
:= Instantiation_Depth
(Sloc2
);
445 if Depth1
< Depth2
then
447 Unum2
:= Get_Source_Unit
(Sloc2
);
450 elsif Depth1
> Depth2
then
452 Unum1
:= Get_Source_Unit
(Sloc1
);
458 Unum1
:= Get_Source_Unit
(Sloc1
);
459 Unum2
:= Get_Source_Unit
(Sloc2
);
463 -- Sloc1 is an instantiation
467 Unum1
:= Get_Source_Unit
(Sloc1
);
471 -- Sloc2 is an instantiation
473 elsif Inst2
/= No_Location
then
475 Unum2
:= Get_Source_Unit
(Sloc2
);
479 -- Step 4: One location in the spec, the other in the corresponding
480 -- body of the same unit. The location in the spec is considered
483 if Nkind
(Unit1
) in N_Subprogram_Body | N_Package_Body
then
484 if Library_Unit
(Cunit
(Unum1
)) = Cunit
(Unum2
) then
488 elsif Nkind
(Unit2
) in N_Subprogram_Body | N_Package_Body
then
489 if Library_Unit
(Cunit
(Unum2
)) = Cunit
(Unum1
) then
494 -- At this point it is certain that the two locations denote two
495 -- entirely separate units.
500 Counter
:= Counter
+ 1;
502 -- Prevent looping forever
504 if Counter
> Max_Iterations
then
506 -- In CodePeer_Mode, return a value to be able to generate SCIL
507 -- files and hope for the best.
509 if CodePeer_Mode
then
516 end Check_Same_Extended_Unit
;
518 -------------------------------
519 -- Compilation_Switches_Last --
520 -------------------------------
522 function Compilation_Switches_Last
return Nat
is
524 return Compilation_Switches
.Last
;
525 end Compilation_Switches_Last
;
527 ---------------------------
528 -- Enable_Switch_Storing --
529 ---------------------------
531 procedure Enable_Switch_Storing
is
533 Switch_Storing_Enabled
:= True;
534 end Enable_Switch_Storing
;
536 ----------------------------
537 -- Disable_Switch_Storing --
538 ----------------------------
540 procedure Disable_Switch_Storing
is
542 Switch_Storing_Enabled
:= False;
543 end Disable_Switch_Storing
;
545 ------------------------------
546 -- Earlier_In_Extended_Unit --
547 ------------------------------
549 function Earlier_In_Extended_Unit
551 S2
: Source_Ptr
) return Boolean
554 return Check_Same_Extended_Unit
(S1
, S2
) = Yes_Before
;
555 end Earlier_In_Extended_Unit
;
557 function Earlier_In_Extended_Unit
558 (N1
: Node_Or_Entity_Id
;
559 N2
: Node_Or_Entity_Id
) return Boolean
562 return Earlier_In_Extended_Unit
(Sloc
(N1
), Sloc
(N2
));
563 end Earlier_In_Extended_Unit
;
565 -----------------------
566 -- Exact_Source_Name --
567 -----------------------
569 function Exact_Source_Name
(Loc
: Source_Ptr
) return String is
570 U
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
571 Buf
: constant Source_Buffer_Ptr
:= Source_Text
(Source_Index
(U
));
572 Orig
: constant Source_Ptr
:= Original_Location
(Loc
);
577 pragma Warnings
(Off
, WC
);
578 pragma Warnings
(Off
, Err
);
581 -- Entity is character literal
583 if Buf
(Orig
) = ''' then
584 return String (Buf
(Orig
.. Orig
+ 2));
586 -- Entity is operator symbol
588 elsif Buf
(Orig
) = '"' or else Buf
(Orig
) = '%' then
593 exit when Buf
(P
) = Buf
(Orig
);
596 return String (Buf
(Orig
.. P
));
598 -- Entity is identifier
604 if Is_Start_Of_Wide_Char
(Buf
, P
) then
605 Scan_Wide
(Buf
, P
, WC
, Err
);
606 elsif not Identifier_Char
(Buf
(P
)) then
613 -- Write out the identifier by copying the exact source characters
614 -- used in its declaration. Note that this means wide characters will
615 -- be in their original encoded form.
617 return String (Buf
(Orig
.. P
- 1));
619 end Exact_Source_Name
;
621 ----------------------------
622 -- Entity_Is_In_Main_Unit --
623 ----------------------------
625 function Entity_Is_In_Main_Unit
(E
: Entity_Id
) return Boolean is
631 while S
/= Standard_Standard
loop
632 if S
= Main_Unit_Entity
then
634 elsif Ekind
(S
) = E_Package
and then Is_Child_Unit
(S
) then
642 end Entity_Is_In_Main_Unit
;
644 --------------------------
645 -- Generic_May_Lack_ALI --
646 --------------------------
648 function Generic_May_Lack_ALI
(Unum
: Unit_Number_Type
) return Boolean is
650 -- We allow internal generic units to be used without having a
651 -- corresponding ALI files to help bootstrapping with older compilers
652 -- that did not support generating ALIs for such generics. It is safe
653 -- to do so because the only thing the generated code would contain
654 -- is the elaboration boolean, and we are careful to elaborate all
655 -- predefined units first anyway.
657 return Is_Internal_Unit
(Unum
);
658 end Generic_May_Lack_ALI
;
660 -----------------------------
661 -- Get_Code_Or_Source_Unit --
662 -----------------------------
664 function Get_Code_Or_Source_Unit
666 Unwind_Instances
: Boolean;
667 Unwind_Subunits
: Boolean) return Unit_Number_Type
670 -- Search table unless we have No_Location, which can happen if the
671 -- relevant location has not been set yet. Happens for example when
672 -- we obtain Sloc (Cunit (Main_Unit)) before it is set.
674 if S
/= No_Location
then
676 Source_File
: Source_File_Index
;
677 Source_Unit
: Unit_Number_Type
;
681 Source_File
:= Get_Source_File_Index
(S
);
683 if Unwind_Instances
then
684 while Template
(Source_File
) > No_Source_File
loop
685 Source_File
:= Template
(Source_File
);
689 Source_Unit
:= Unit
(Source_File
);
691 if Unwind_Subunits
then
692 Unit_Node
:= Unit
(Cunit
(Source_Unit
));
694 while Nkind
(Unit_Node
) = N_Subunit
695 and then Present
(Corresponding_Stub
(Unit_Node
))
698 Get_Code_Or_Source_Unit
699 (Sloc
(Corresponding_Stub
(Unit_Node
)),
700 Unwind_Instances
=> Unwind_Instances
,
701 Unwind_Subunits
=> Unwind_Subunits
);
702 Unit_Node
:= Unit
(Cunit
(Source_Unit
));
706 if Source_Unit
/= No_Unit
then
712 -- If S was No_Location, or was not in the table, we must be in the main
713 -- source unit (and the value has not been placed in the table yet),
714 -- or in one of the configuration pragma files.
717 end Get_Code_Or_Source_Unit
;
723 function Get_Code_Unit
(S
: Source_Ptr
) return Unit_Number_Type
is
726 Get_Code_Or_Source_Unit
727 (Top_Level_Location
(S
),
728 Unwind_Instances
=> False,
729 Unwind_Subunits
=> False);
732 function Get_Code_Unit
(N
: Node_Or_Entity_Id
) return Unit_Number_Type
is
734 return Get_Code_Unit
(Sloc
(N
));
737 ----------------------------
738 -- Get_Compilation_Switch --
739 ----------------------------
741 function Get_Compilation_Switch
(N
: Pos
) return String_Ptr
is
743 if N
<= Compilation_Switches
.Last
then
744 return Compilation_Switches
.Table
(N
);
748 end Get_Compilation_Switch
;
750 ----------------------------------
751 -- Get_Cunit_Entity_Unit_Number --
752 ----------------------------------
754 function Get_Cunit_Entity_Unit_Number
755 (E
: Entity_Id
) return Unit_Number_Type
758 for U
in Units
.First
.. Units
.Last
loop
759 if Cunit_Entity
(U
) = E
then
764 -- If not in the table, must be the main source unit, and we just
765 -- have not got it put into the table yet.
768 end Get_Cunit_Entity_Unit_Number
;
770 ---------------------------
771 -- Get_Cunit_Unit_Number --
772 ---------------------------
774 function Get_Cunit_Unit_Number
(N
: Node_Id
) return Unit_Number_Type
is
776 for U
in Units
.First
.. Units
.Last
loop
777 if Cunit
(U
) = N
then
782 -- If not in the table, must be a spec created for a main unit that is a
783 -- child subprogram body which we have not inserted into the table yet.
785 if N
= Library_Unit
(Cunit
(Main_Unit
)) then
788 -- If it is anything else, something is seriously wrong, and we really
789 -- don't want to proceed, even if assertions are off, so we explicitly
790 -- raise an exception in this case to terminate compilation.
795 end Get_Cunit_Unit_Number
;
797 ---------------------
798 -- Get_Source_Unit --
799 ---------------------
801 function Get_Source_Unit
(S
: Source_Ptr
) return Unit_Number_Type
is
804 Get_Code_Or_Source_Unit
806 Unwind_Instances
=> True,
807 Unwind_Subunits
=> False);
810 function Get_Source_Unit
(N
: Node_Or_Entity_Id
) return Unit_Number_Type
is
812 return Get_Source_Unit
(Sloc
(N
));
815 -----------------------------
816 -- Get_Top_Level_Code_Unit --
817 -----------------------------
819 function Get_Top_Level_Code_Unit
(S
: Source_Ptr
) return Unit_Number_Type
is
822 Get_Code_Or_Source_Unit
823 (Top_Level_Location
(S
),
824 Unwind_Instances
=> False,
825 Unwind_Subunits
=> True);
826 end Get_Top_Level_Code_Unit
;
828 function Get_Top_Level_Code_Unit
829 (N
: Node_Or_Entity_Id
) return Unit_Number_Type
is
831 return Get_Top_Level_Code_Unit
(Sloc
(N
));
832 end Get_Top_Level_Code_Unit
;
834 --------------------------------
835 -- In_Extended_Main_Code_Unit --
836 --------------------------------
838 function In_Extended_Main_Code_Unit
839 (N
: Node_Or_Entity_Id
) return Boolean
842 -- Special case Itypes to test the Sloc of the associated node. The
843 -- reason we do this is for possible calls from gigi after -gnatD
844 -- processing is complete in sprint. This processing updates the
845 -- sloc fields of all nodes in the tree, but itypes are not in the
846 -- tree so their slocs do not get updated.
848 if Nkind
(N
) = N_Defining_Identifier
and then Is_Itype
(N
) then
849 return In_Extended_Main_Code_Unit
(Associated_Node_For_Itype
(N
));
852 return In_Extended_Main_Code_Unit
(Sloc
(N
));
853 end In_Extended_Main_Code_Unit
;
855 function In_Extended_Main_Code_Unit
(Loc
: Source_Ptr
) return Boolean is
857 -- Special value cases
859 if Loc
in No_Location | Standard_Location
then
863 -- Otherwise see if we are in the main unit
865 if Get_Code_Unit
(Loc
) = Get_Code_Unit
(Cunit
(Main_Unit
)) then
869 -- Location may be in spec (or subunit etc) of main unit
871 return In_Same_Extended_Unit
(Loc
, Sloc
(Cunit
(Main_Unit
)));
872 end In_Extended_Main_Code_Unit
;
874 ----------------------------------
875 -- In_Extended_Main_Source_Unit --
876 ----------------------------------
878 function In_Extended_Main_Source_Unit
879 (N
: Node_Or_Entity_Id
) return Boolean
882 -- Special case Itypes to test the Sloc of the associated node. The
883 -- reason we do this is for possible calls from gigi after -gnatD
884 -- processing is complete in sprint. This processing updates the
885 -- sloc fields of all nodes in the tree, but itypes are not in the
886 -- tree so their slocs do not get updated.
888 if Nkind
(N
) = N_Defining_Identifier
and then Is_Itype
(N
) then
889 pragma Assert
(Compiler_State
/= Parsing
);
890 return In_Extended_Main_Source_Unit
(Associated_Node_For_Itype
(N
));
893 return In_Extended_Main_Source_Unit
(Sloc
(N
));
894 end In_Extended_Main_Source_Unit
;
896 function In_Extended_Main_Source_Unit
897 (Loc
: Source_Ptr
) return Boolean
900 -- If parsing, then use the global flag to indicate result
902 if Compiler_State
= Parsing
then
903 return Parsing_Main_Extended_Source
;
906 -- Special value cases
908 if Loc
in No_Location | Standard_Location
then
912 -- Otherwise compare original locations
914 return In_Same_Extended_Unit
915 (Original_Location
(Loc
),
916 Original_Location
(Sloc
(Cunit
(Main_Unit
))));
917 end In_Extended_Main_Source_Unit
;
919 ----------------------
920 -- In_Internal_Unit --
921 ----------------------
923 function In_Internal_Unit
(N
: Node_Or_Entity_Id
) return Boolean is
925 return In_Internal_Unit
(Sloc
(N
));
926 end In_Internal_Unit
;
928 function In_Internal_Unit
(S
: Source_Ptr
) return Boolean is
929 Unit
: constant Unit_Number_Type
:= Get_Source_Unit
(S
);
931 return Is_Internal_Unit
(Unit
);
932 end In_Internal_Unit
;
934 ----------------------------
935 -- In_Predefined_Renaming --
936 ----------------------------
938 function In_Predefined_Renaming
(N
: Node_Or_Entity_Id
) return Boolean is
940 return In_Predefined_Renaming
(Sloc
(N
));
941 end In_Predefined_Renaming
;
943 function In_Predefined_Renaming
(S
: Source_Ptr
) return Boolean is
944 Unit
: constant Unit_Number_Type
:= Get_Source_Unit
(S
);
946 return Is_Predefined_Renaming
(Unit
);
947 end In_Predefined_Renaming
;
953 function ipu
(N
: Node_Or_Entity_Id
) return Boolean is
955 return In_Predefined_Unit
(N
);
958 ------------------------
959 -- In_Predefined_Unit --
960 ------------------------
962 function In_Predefined_Unit
(N
: Node_Or_Entity_Id
) return Boolean is
964 return In_Predefined_Unit
(Sloc
(N
));
965 end In_Predefined_Unit
;
967 function In_Predefined_Unit
(S
: Source_Ptr
) return Boolean is
968 Unit
: constant Unit_Number_Type
:= Get_Source_Unit
(S
);
970 return Is_Predefined_Unit
(Unit
);
971 end In_Predefined_Unit
;
973 -----------------------
974 -- In_Same_Code_Unit --
975 -----------------------
977 function In_Same_Code_Unit
(N1
, N2
: Node_Or_Entity_Id
) return Boolean is
978 S1
: constant Source_Ptr
:= Sloc
(N1
);
979 S2
: constant Source_Ptr
:= Sloc
(N2
);
982 if S1
= No_Location
or else S2
= No_Location
then
985 elsif S1
= Standard_Location
then
986 return S2
= Standard_Location
;
988 elsif S2
= Standard_Location
then
992 return Get_Code_Unit
(N1
) = Get_Code_Unit
(N2
);
993 end In_Same_Code_Unit
;
995 ---------------------------
996 -- In_Same_Extended_Unit --
997 ---------------------------
999 function In_Same_Extended_Unit
1000 (N1
, N2
: Node_Or_Entity_Id
) return Boolean
1003 return Check_Same_Extended_Unit
(Sloc
(N1
), Sloc
(N2
)) /= No
;
1004 end In_Same_Extended_Unit
;
1006 function In_Same_Extended_Unit
(S1
, S2
: Source_Ptr
) return Boolean is
1008 return Check_Same_Extended_Unit
(S1
, S2
) /= No
;
1009 end In_Same_Extended_Unit
;
1011 -------------------------
1012 -- In_Same_Source_Unit --
1013 -------------------------
1015 function In_Same_Source_Unit
(N1
, N2
: Node_Or_Entity_Id
) return Boolean is
1016 S1
: constant Source_Ptr
:= Sloc
(N1
);
1017 S2
: constant Source_Ptr
:= Sloc
(N2
);
1020 if S1
= No_Location
or else S2
= No_Location
then
1023 elsif S1
= Standard_Location
then
1024 return S2
= Standard_Location
;
1026 elsif S2
= Standard_Location
then
1030 return Get_Source_Unit
(N1
) = Get_Source_Unit
(N2
);
1031 end In_Same_Source_Unit
;
1033 -----------------------------------
1034 -- Increment_Primary_Stack_Count --
1035 -----------------------------------
1037 procedure Increment_Primary_Stack_Count
(Increment
: Int
) is
1038 PSC
: Int
renames Units
.Table
(Current_Sem_Unit
).Primary_Stack_Count
;
1040 PSC
:= PSC
+ Increment
;
1041 end Increment_Primary_Stack_Count
;
1043 -------------------------------
1044 -- Increment_Sec_Stack_Count --
1045 -------------------------------
1047 procedure Increment_Sec_Stack_Count
(Increment
: Int
) is
1048 SSC
: Int
renames Units
.Table
(Current_Sem_Unit
).Sec_Stack_Count
;
1050 SSC
:= SSC
+ Increment
;
1051 end Increment_Sec_Stack_Count
;
1053 -----------------------------
1054 -- Increment_Serial_Number --
1055 -----------------------------
1057 function Increment_Serial_Number
return Nat
is
1058 TSN
: Int
renames Units
.Table
(Current_Sem_Unit
).Serial_Number
;
1062 end Increment_Serial_Number
;
1064 ----------------------
1065 -- Init_Unit_Name --
1066 ----------------------
1068 procedure Init_Unit_Name
(U
: Unit_Number_Type
; N
: Unit_Name_Type
) is
1070 Units
.Table
(U
).Unit_Name
:= N
;
1071 Unit_Names
.Set
(N
, U
);
1078 procedure Initialize
is
1080 Linker_Option_Lines
.Init
;
1084 Compilation_Switches
.Init
;
1091 function Is_Loaded
(Uname
: Unit_Name_Type
) return Boolean is
1093 return Unit_Names
.Get
(Uname
) /= No_Unit
;
1100 function Last_Unit
return Unit_Number_Type
is
1109 procedure List
(File_Names_Only
: Boolean := False) is separate;
1117 Linker_Option_Lines
.Release
;
1118 Linker_Option_Lines
.Locked
:= True;
1120 Load_Stack
.Locked
:= True;
1122 Units
.Locked
:= True;
1129 function Num_Units
return Nat
is
1131 return Int
(Units
.Last
) - Int
(Main_Unit
) + 1;
1138 procedure Remove_Unit
(U
: Unit_Number_Type
) is
1140 pragma Assert
(U
= Units
.Last
);
1141 Unit_Names
.Set
(Unit_Name
(U
), No_Unit
);
1142 Units
.Decrement_Last
;
1145 ----------------------------------
1146 -- Replace_Linker_Option_String --
1147 ----------------------------------
1149 procedure Replace_Linker_Option_String
1150 (S
: String_Id
; Match_String
: String)
1153 if Match_String
'Length > 0 then
1154 for J
in 1 .. Linker_Option_Lines
.Last
loop
1155 String_To_Name_Buffer
(Linker_Option_Lines
.Table
(J
).Option
);
1157 if Match_String
= Name_Buffer
(1 .. Match_String
'Length) then
1158 Linker_Option_Lines
.Table
(J
).Option
:= S
;
1164 Store_Linker_Option_String
(S
);
1165 end Replace_Linker_Option_String
;
1171 procedure Sort
(Tbl
: in out Unit_Ref_Table
) is separate;
1173 ------------------------------
1174 -- Store_Compilation_Switch --
1175 ------------------------------
1177 procedure Store_Compilation_Switch
(Switch
: String) is
1179 if Switch_Storing_Enabled
then
1180 Compilation_Switches
.Increment_Last
;
1181 Compilation_Switches
.Table
(Compilation_Switches
.Last
) :=
1182 new String'(Switch);
1184 -- Fix up --RTS flag which has been transformed by the gcc driver
1187 if Switch'Last >= Switch'First + 4
1188 and then Switch (Switch'First .. Switch'First + 4) = "-fRTS"
1190 Compilation_Switches.Table
1191 (Compilation_Switches.Last) (Switch'First + 1) := '-';
1194 end Store_Compilation_Switch;
1196 --------------------------------
1197 -- Store_Linker_Option_String --
1198 --------------------------------
1200 procedure Store_Linker_Option_String (S : String_Id) is
1202 Linker_Option_Lines.Append ((Option => S, Unit => Current_Sem_Unit));
1203 end Store_Linker_Option_String;
1209 procedure Store_Note (N : Node_Id) is
1210 Sfile : constant Source_File_Index := Get_Source_File_Index (Sloc (N));
1213 -- Notes for a generic are emitted when processing the template, never
1216 if In_Extended_Main_Code_Unit (N)
1217 and then Instance (Sfile) = No_Instance_Id
1223 -------------------------------
1224 -- Synchronize_Serial_Number --
1225 -------------------------------
1227 procedure Synchronize_Serial_Number (SN : Nat) is
1228 TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
1230 -- We should not be trying to synchronize downward
1232 pragma Assert (TSN <= SN);
1237 end Synchronize_Serial_Number;
1239 --------------------
1240 -- Unit_Name_Hash --
1241 --------------------
1243 function Unit_Name_Hash (Id : Unit_Name_Type) return Unit_Name_Header_Num is
1245 return Unit_Name_Header_Num (Id mod Unit_Name_Table_Size);
1254 Linker_Option_Lines.Locked := False;
1255 Load_Stack.Locked := False;
1256 Units.Locked := False;
1263 function Version_Get (U : Unit_Number_Type) return Word_Hex_String is
1265 return Get_Hex_String (Units.Table (U).Version);
1268 ------------------------
1269 -- Version_Referenced --
1270 ------------------------
1272 procedure Version_Referenced (S : String_Id) is
1274 Version_Ref.Append (S);
1275 end Version_Referenced;
1277 ---------------------
1278 -- Write_Unit_Info --
1279 ---------------------
1281 procedure Write_Unit_Info
1282 (Unit_Num : Unit_Number_Type;
1284 Prefix : String := "";
1285 Withs : Boolean := False)
1289 Write_Unit_Name (Unit_Name (Unit_Num));
1290 Write_Str (", unit ");
1291 Write_Int (Int (Unit_Num));
1293 Write_Int (Int (Item));
1295 Write_Str (Node_Kind'Image (Nkind (Item)));
1297 if Is_Rewrite_Substitution (Item) then
1298 Write_Str (", orig = ");
1299 Write_Int (Int (Original_Node (Item)));
1301 Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
1306 -- Skip the rest if we're not supposed to print the withs
1313 Context_Item : Node_Id;
1316 Context_Item := First (Context_Items (Cunit (Unit_Num)));
1317 while Present (Context_Item)
1318 and then (Nkind (Context_Item) /= N_With_Clause
1319 or else Limited_Present (Context_Item))
1321 Next (Context_Item);
1324 if Present (Context_Item) then
1326 Write_Line ("withs:");
1329 while Present (Context_Item) loop
1330 if Nkind (Context_Item) = N_With_Clause
1331 and then not Limited_Present (Context_Item)
1333 pragma Assert (Present (Library_Unit (Context_Item)));
1336 (Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
1338 if Implicit_With (Context_Item) then
1339 Write_Str (" -- implicit");
1345 Next (Context_Item);
1349 Write_Line ("end withs");
1353 end Write_Unit_Info;