1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, 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
324 elsif S1
= Standard_Location
then
325 if S2
= Standard_Location
then
331 elsif S2
= Standard_Location
then
338 Unum1
:= Get_Source_Unit
(Sloc1
);
339 Unum2
:= Get_Source_Unit
(Sloc2
);
342 -- Step 1: Check whether the two locations are in the same source
345 Sind1
:= Get_Source_File_Index
(Sloc1
);
346 Sind2
:= Get_Source_File_Index
(Sloc2
);
348 if Sind1
= Sind2
then
349 if Sloc1
< Sloc2
then
351 elsif Sloc1
> Sloc2
then
358 -- Step 2: Check subunits. If a subunit is instantiated, follow the
359 -- instantiation chain rather than the stub chain.
361 -- Note that we must handle the case where the subunit exists in the
362 -- same body as the main unit (which may happen when Naming gets
363 -- manually specified within a project file or through tools like
364 -- gprname). Otherwise, we will have an infinite loop jumping around
367 Unit1
:= Unit
(Cunit
(Unum1
));
368 Unit2
:= Unit
(Cunit
(Unum2
));
369 Inst1
:= Instantiation
(Sind1
);
370 Inst2
:= Instantiation
(Sind2
);
372 if Nkind
(Unit1
) = N_Subunit
373 and then Present
(Corresponding_Stub
(Unit1
))
374 and then Inst1
= No_Location
376 if Nkind
(Unit2
) = N_Subunit
377 and then Present
(Corresponding_Stub
(Unit2
))
378 and then Inst2
= No_Location
380 -- Both locations refer to subunits which may have a common
381 -- ancestor. If they do, the deeper subunit must have a longer
382 -- unit name. Replace the deeper one with its corresponding
383 -- stub in order to find the nearest ancestor.
385 if Length_Of_Name
(Unit_Name
(Unum1
)) <
386 Length_Of_Name
(Unit_Name
(Unum2
))
388 Sloc2
:= Sloc
(Corresponding_Stub
(Unit2
));
390 if Unum2
/= Get_Source_Unit
(Sloc2
) then
391 Unum2
:= Get_Source_Unit
(Sloc2
);
394 null; -- Unum2 already designates the correct unit
397 Sloc1
:= Sloc
(Corresponding_Stub
(Unit1
));
399 if Unum1
/= Get_Source_Unit
(Sloc1
) then
400 Unum1
:= Get_Source_Unit
(Sloc1
);
403 null; -- Unum1 already designates the correct unit
407 -- Sloc1 in subunit, Sloc2 not
410 Sloc1
:= Sloc
(Corresponding_Stub
(Unit1
));
412 if Unum1
/= Get_Source_Unit
(Sloc1
) then
413 Unum1
:= Get_Source_Unit
(Sloc1
);
416 null; -- Unum1 already designates the correct unit
420 -- Sloc2 in subunit, Sloc1 not
422 elsif Nkind
(Unit2
) = N_Subunit
423 and then Present
(Corresponding_Stub
(Unit2
))
424 and then Inst2
= No_Location
426 Sloc2
:= Sloc
(Corresponding_Stub
(Unit2
));
428 if Unum2
/= Get_Source_Unit
(Sloc2
) then
429 Unum2
:= Get_Source_Unit
(Sloc2
);
432 null; -- Unum2 already designates the correct unit
436 -- Step 3: Check instances. The two locations may yield a common
439 if Inst1
/= No_Location
then
440 if Inst2
/= No_Location
then
442 -- Both locations denote instantiations
444 Depth1
:= Instantiation_Depth
(Sloc1
);
445 Depth2
:= Instantiation_Depth
(Sloc2
);
447 if Depth1
< Depth2
then
449 Unum2
:= Get_Source_Unit
(Sloc2
);
452 elsif Depth1
> Depth2
then
454 Unum1
:= Get_Source_Unit
(Sloc1
);
460 Unum1
:= Get_Source_Unit
(Sloc1
);
461 Unum2
:= Get_Source_Unit
(Sloc2
);
465 -- Sloc1 is an instantiation
469 Unum1
:= Get_Source_Unit
(Sloc1
);
473 -- Sloc2 is an instantiation
475 elsif Inst2
/= No_Location
then
477 Unum2
:= Get_Source_Unit
(Sloc2
);
481 -- Step 4: One location in the spec, the other in the corresponding
482 -- body of the same unit. The location in the spec is considered
485 if Nkind
(Unit1
) in N_Subprogram_Body | N_Package_Body
then
486 if Library_Unit
(Cunit
(Unum1
)) = Cunit
(Unum2
) then
490 elsif Nkind
(Unit2
) in N_Subprogram_Body | N_Package_Body
then
491 if Library_Unit
(Cunit
(Unum2
)) = Cunit
(Unum1
) then
496 -- At this point it is certain that the two locations denote two
497 -- entirely separate units.
502 Counter
:= Counter
+ 1;
504 -- Prevent looping forever
506 if Counter
> Max_Iterations
then
508 -- In CodePeer_Mode, return a value to be able to generate SCIL
509 -- files and hope for the best.
511 if CodePeer_Mode
then
518 end Check_Same_Extended_Unit
;
520 -------------------------------
521 -- Compilation_Switches_Last --
522 -------------------------------
524 function Compilation_Switches_Last
return Nat
is
526 return Compilation_Switches
.Last
;
527 end Compilation_Switches_Last
;
529 ---------------------------
530 -- Enable_Switch_Storing --
531 ---------------------------
533 procedure Enable_Switch_Storing
is
535 Switch_Storing_Enabled
:= True;
536 end Enable_Switch_Storing
;
538 ----------------------------
539 -- Disable_Switch_Storing --
540 ----------------------------
542 procedure Disable_Switch_Storing
is
544 Switch_Storing_Enabled
:= False;
545 end Disable_Switch_Storing
;
547 ------------------------------
548 -- Earlier_In_Extended_Unit --
549 ------------------------------
551 function Earlier_In_Extended_Unit
553 S2
: Source_Ptr
) return Boolean
556 return Check_Same_Extended_Unit
(S1
, S2
) = Yes_Before
;
557 end Earlier_In_Extended_Unit
;
559 function Earlier_In_Extended_Unit
560 (N1
: Node_Or_Entity_Id
;
561 N2
: Node_Or_Entity_Id
) return Boolean
564 return Earlier_In_Extended_Unit
(Sloc
(N1
), Sloc
(N2
));
565 end Earlier_In_Extended_Unit
;
567 -----------------------
568 -- Exact_Source_Name --
569 -----------------------
571 function Exact_Source_Name
(Loc
: Source_Ptr
) return String is
572 U
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
573 Buf
: constant Source_Buffer_Ptr
:= Source_Text
(Source_Index
(U
));
574 Orig
: constant Source_Ptr
:= Original_Location
(Loc
);
579 pragma Warnings
(Off
, WC
);
580 pragma Warnings
(Off
, Err
);
583 -- Entity is character literal
585 if Buf
(Orig
) = ''' then
586 return String (Buf
(Orig
.. Orig
+ 2));
588 -- Entity is operator symbol
590 elsif Buf
(Orig
) = '"' or else Buf
(Orig
) = '%' then
595 exit when Buf
(P
) = Buf
(Orig
);
598 return String (Buf
(Orig
.. P
));
600 -- Entity is identifier
606 if Is_Start_Of_Wide_Char
(Buf
, P
) then
607 Scan_Wide
(Buf
, P
, WC
, Err
);
608 elsif not Identifier_Char
(Buf
(P
)) then
615 -- Write out the identifier by copying the exact source characters
616 -- used in its declaration. Note that this means wide characters will
617 -- be in their original encoded form.
619 return String (Buf
(Orig
.. P
- 1));
621 end Exact_Source_Name
;
623 ----------------------------
624 -- Entity_Is_In_Main_Unit --
625 ----------------------------
627 function Entity_Is_In_Main_Unit
(E
: Entity_Id
) return Boolean is
633 while S
/= Standard_Standard
loop
634 if S
= Main_Unit_Entity
then
636 elsif Ekind
(S
) = E_Package
and then Is_Child_Unit
(S
) then
644 end Entity_Is_In_Main_Unit
;
646 --------------------------
647 -- Generic_May_Lack_ALI --
648 --------------------------
650 function Generic_May_Lack_ALI
(Unum
: Unit_Number_Type
) return Boolean is
652 -- We allow internal generic units to be used without having a
653 -- corresponding ALI files to help bootstrapping with older compilers
654 -- that did not support generating ALIs for such generics. It is safe
655 -- to do so because the only thing the generated code would contain
656 -- is the elaboration boolean, and we are careful to elaborate all
657 -- predefined units first anyway.
659 return Is_Internal_Unit
(Unum
);
660 end Generic_May_Lack_ALI
;
662 -----------------------------
663 -- Get_Code_Or_Source_Unit --
664 -----------------------------
666 function Get_Code_Or_Source_Unit
668 Unwind_Instances
: Boolean;
669 Unwind_Subunits
: Boolean) return Unit_Number_Type
672 -- Search table unless we have No_Location, which can happen if the
673 -- relevant location has not been set yet. Happens for example when
674 -- we obtain Sloc (Cunit (Main_Unit)) before it is set.
676 if S
/= No_Location
then
678 Source_File
: Source_File_Index
;
679 Source_Unit
: Unit_Number_Type
;
683 Source_File
:= Get_Source_File_Index
(S
);
685 if Unwind_Instances
then
686 while Template
(Source_File
) > No_Source_File
loop
687 Source_File
:= Template
(Source_File
);
691 Source_Unit
:= Unit
(Source_File
);
693 if Unwind_Subunits
then
694 Unit_Node
:= Unit
(Cunit
(Source_Unit
));
696 while Nkind
(Unit_Node
) = N_Subunit
697 and then Present
(Corresponding_Stub
(Unit_Node
))
700 Get_Code_Or_Source_Unit
701 (Sloc
(Corresponding_Stub
(Unit_Node
)),
702 Unwind_Instances
=> Unwind_Instances
,
703 Unwind_Subunits
=> Unwind_Subunits
);
704 Unit_Node
:= Unit
(Cunit
(Source_Unit
));
708 if Source_Unit
/= No_Unit
then
714 -- If S was No_Location, or was not in the table, we must be in the main
715 -- source unit (and the value has not been placed in the table yet),
716 -- or in one of the configuration pragma files.
719 end Get_Code_Or_Source_Unit
;
725 function Get_Code_Unit
(S
: Source_Ptr
) return Unit_Number_Type
is
728 Get_Code_Or_Source_Unit
729 (Top_Level_Location
(S
),
730 Unwind_Instances
=> False,
731 Unwind_Subunits
=> False);
734 function Get_Code_Unit
(N
: Node_Or_Entity_Id
) return Unit_Number_Type
is
736 return Get_Code_Unit
(Sloc
(N
));
739 ----------------------------
740 -- Get_Compilation_Switch --
741 ----------------------------
743 function Get_Compilation_Switch
(N
: Pos
) return String_Ptr
is
745 if N
<= Compilation_Switches
.Last
then
746 return Compilation_Switches
.Table
(N
);
750 end Get_Compilation_Switch
;
752 ----------------------------------
753 -- Get_Cunit_Entity_Unit_Number --
754 ----------------------------------
756 function Get_Cunit_Entity_Unit_Number
757 (E
: Entity_Id
) return Unit_Number_Type
760 for U
in Units
.First
.. Units
.Last
loop
761 if Cunit_Entity
(U
) = E
then
766 -- If not in the table, must be the main source unit, and we just
767 -- have not got it put into the table yet.
770 end Get_Cunit_Entity_Unit_Number
;
772 ---------------------------
773 -- Get_Cunit_Unit_Number --
774 ---------------------------
776 function Get_Cunit_Unit_Number
(N
: Node_Id
) return Unit_Number_Type
is
778 for U
in Units
.First
.. Units
.Last
loop
779 if Cunit
(U
) = N
then
784 -- If not in the table, must be a spec created for a main unit that is a
785 -- child subprogram body which we have not inserted into the table yet.
787 if N
= Library_Unit
(Cunit
(Main_Unit
)) then
790 -- If it is anything else, something is seriously wrong, and we really
791 -- don't want to proceed, even if assertions are off, so we explicitly
792 -- raise an exception in this case to terminate compilation.
797 end Get_Cunit_Unit_Number
;
799 ---------------------
800 -- Get_Source_Unit --
801 ---------------------
803 function Get_Source_Unit
(S
: Source_Ptr
) return Unit_Number_Type
is
806 Get_Code_Or_Source_Unit
808 Unwind_Instances
=> True,
809 Unwind_Subunits
=> False);
812 function Get_Source_Unit
(N
: Node_Or_Entity_Id
) return Unit_Number_Type
is
814 return Get_Source_Unit
(Sloc
(N
));
817 -----------------------------
818 -- Get_Top_Level_Code_Unit --
819 -----------------------------
821 function Get_Top_Level_Code_Unit
(S
: Source_Ptr
) return Unit_Number_Type
is
824 Get_Code_Or_Source_Unit
825 (Top_Level_Location
(S
),
826 Unwind_Instances
=> False,
827 Unwind_Subunits
=> True);
828 end Get_Top_Level_Code_Unit
;
830 function Get_Top_Level_Code_Unit
831 (N
: Node_Or_Entity_Id
) return Unit_Number_Type
is
833 return Get_Top_Level_Code_Unit
(Sloc
(N
));
834 end Get_Top_Level_Code_Unit
;
836 --------------------------------
837 -- In_Extended_Main_Code_Unit --
838 --------------------------------
840 function In_Extended_Main_Code_Unit
841 (N
: Node_Or_Entity_Id
) return Boolean
844 if Sloc
(N
) = Standard_Location
then
847 elsif Sloc
(N
) = No_Location
then
850 -- Special case Itypes to test the Sloc of the associated node. The
851 -- reason we do this is for possible calls from gigi after -gnatD
852 -- processing is complete in sprint. This processing updates the
853 -- sloc fields of all nodes in the tree, but itypes are not in the
854 -- tree so their slocs do not get updated.
856 elsif Nkind
(N
) = N_Defining_Identifier
857 and then Is_Itype
(N
)
859 return In_Extended_Main_Code_Unit
(Associated_Node_For_Itype
(N
));
861 -- Otherwise see if we are in the main unit
863 elsif Get_Code_Unit
(Sloc
(N
)) = Get_Code_Unit
(Cunit
(Main_Unit
)) then
866 -- Node may be in spec (or subunit etc) of main unit
869 return In_Same_Extended_Unit
(N
, Cunit
(Main_Unit
));
871 end In_Extended_Main_Code_Unit
;
873 function In_Extended_Main_Code_Unit
(Loc
: Source_Ptr
) return Boolean is
875 if Loc
= Standard_Location
then
878 elsif Loc
= No_Location
then
881 -- Otherwise see if we are in the main unit
883 elsif Get_Code_Unit
(Loc
) = Get_Code_Unit
(Cunit
(Main_Unit
)) then
886 -- Location may be in spec (or subunit etc) of main unit
889 return In_Same_Extended_Unit
(Loc
, Sloc
(Cunit
(Main_Unit
)));
891 end In_Extended_Main_Code_Unit
;
893 ----------------------------------
894 -- In_Extended_Main_Source_Unit --
895 ----------------------------------
897 function In_Extended_Main_Source_Unit
898 (N
: Node_Or_Entity_Id
) return Boolean
900 Nloc
: constant Source_Ptr
:= Sloc
(N
);
901 Mloc
: constant Source_Ptr
:= Sloc
(Cunit
(Main_Unit
));
904 -- If parsing, then use the global flag to indicate result
906 if Compiler_State
= Parsing
then
907 return Parsing_Main_Extended_Source
;
909 -- Special value cases
911 elsif Nloc
= Standard_Location
then
914 elsif Nloc
= No_Location
then
917 -- Special case Itypes to test the Sloc of the associated node. The
918 -- reason we do this is for possible calls from gigi after -gnatD
919 -- processing is complete in sprint. This processing updates the
920 -- sloc fields of all nodes in the tree, but itypes are not in the
921 -- tree so their slocs do not get updated.
923 elsif Nkind
(N
) = N_Defining_Identifier
924 and then Is_Itype
(N
)
926 return In_Extended_Main_Source_Unit
(Associated_Node_For_Itype
(N
));
928 -- Otherwise compare original locations to see if in same unit
932 In_Same_Extended_Unit
933 (Original_Location
(Nloc
), Original_Location
(Mloc
));
935 end In_Extended_Main_Source_Unit
;
937 function In_Extended_Main_Source_Unit
938 (Loc
: Source_Ptr
) return Boolean
940 Mloc
: constant Source_Ptr
:= Sloc
(Cunit
(Main_Unit
));
943 -- If parsing, then use the global flag to indicate result
945 if Compiler_State
= Parsing
then
946 return Parsing_Main_Extended_Source
;
948 -- Special value cases
950 elsif Loc
= Standard_Location
then
953 elsif Loc
= No_Location
then
956 -- Otherwise compare original locations to see if in same unit
960 In_Same_Extended_Unit
961 (Original_Location
(Loc
), Original_Location
(Mloc
));
963 end In_Extended_Main_Source_Unit
;
965 ----------------------
966 -- In_Internal_Unit --
967 ----------------------
969 function In_Internal_Unit
(N
: Node_Or_Entity_Id
) return Boolean is
971 return In_Internal_Unit
(Sloc
(N
));
972 end In_Internal_Unit
;
974 function In_Internal_Unit
(S
: Source_Ptr
) return Boolean is
975 Unit
: constant Unit_Number_Type
:= Get_Source_Unit
(S
);
977 return Is_Internal_Unit
(Unit
);
978 end In_Internal_Unit
;
980 ----------------------------
981 -- In_Predefined_Renaming --
982 ----------------------------
984 function In_Predefined_Renaming
(N
: Node_Or_Entity_Id
) return Boolean is
986 return In_Predefined_Renaming
(Sloc
(N
));
987 end In_Predefined_Renaming
;
989 function In_Predefined_Renaming
(S
: Source_Ptr
) return Boolean is
990 Unit
: constant Unit_Number_Type
:= Get_Source_Unit
(S
);
992 return Is_Predefined_Renaming
(Unit
);
993 end In_Predefined_Renaming
;
995 ------------------------
996 -- In_Predefined_Unit --
997 ------------------------
999 function In_Predefined_Unit
(N
: Node_Or_Entity_Id
) return Boolean is
1001 return In_Predefined_Unit
(Sloc
(N
));
1002 end In_Predefined_Unit
;
1004 function In_Predefined_Unit
(S
: Source_Ptr
) return Boolean is
1005 Unit
: constant Unit_Number_Type
:= Get_Source_Unit
(S
);
1007 return Is_Predefined_Unit
(Unit
);
1008 end In_Predefined_Unit
;
1010 -----------------------
1011 -- In_Same_Code_Unit --
1012 -----------------------
1014 function In_Same_Code_Unit
(N1
, N2
: Node_Or_Entity_Id
) return Boolean is
1015 S1
: constant Source_Ptr
:= Sloc
(N1
);
1016 S2
: constant Source_Ptr
:= Sloc
(N2
);
1019 if S1
= No_Location
or else S2
= No_Location
then
1022 elsif S1
= Standard_Location
then
1023 return S2
= Standard_Location
;
1025 elsif S2
= Standard_Location
then
1029 return Get_Code_Unit
(N1
) = Get_Code_Unit
(N2
);
1030 end In_Same_Code_Unit
;
1032 ---------------------------
1033 -- In_Same_Extended_Unit --
1034 ---------------------------
1036 function In_Same_Extended_Unit
1037 (N1
, N2
: Node_Or_Entity_Id
) return Boolean
1040 return Check_Same_Extended_Unit
(Sloc
(N1
), Sloc
(N2
)) /= No
;
1041 end In_Same_Extended_Unit
;
1043 function In_Same_Extended_Unit
(S1
, S2
: Source_Ptr
) return Boolean is
1045 return Check_Same_Extended_Unit
(S1
, S2
) /= No
;
1046 end In_Same_Extended_Unit
;
1048 -------------------------
1049 -- In_Same_Source_Unit --
1050 -------------------------
1052 function In_Same_Source_Unit
(N1
, N2
: Node_Or_Entity_Id
) return Boolean is
1053 S1
: constant Source_Ptr
:= Sloc
(N1
);
1054 S2
: constant Source_Ptr
:= Sloc
(N2
);
1057 if S1
= No_Location
or else S2
= No_Location
then
1060 elsif S1
= Standard_Location
then
1061 return S2
= Standard_Location
;
1063 elsif S2
= Standard_Location
then
1067 return Get_Source_Unit
(N1
) = Get_Source_Unit
(N2
);
1068 end In_Same_Source_Unit
;
1070 -----------------------------------
1071 -- Increment_Primary_Stack_Count --
1072 -----------------------------------
1074 procedure Increment_Primary_Stack_Count
(Increment
: Int
) is
1075 PSC
: Int
renames Units
.Table
(Current_Sem_Unit
).Primary_Stack_Count
;
1077 PSC
:= PSC
+ Increment
;
1078 end Increment_Primary_Stack_Count
;
1080 -------------------------------
1081 -- Increment_Sec_Stack_Count --
1082 -------------------------------
1084 procedure Increment_Sec_Stack_Count
(Increment
: Int
) is
1085 SSC
: Int
renames Units
.Table
(Current_Sem_Unit
).Sec_Stack_Count
;
1087 SSC
:= SSC
+ Increment
;
1088 end Increment_Sec_Stack_Count
;
1090 -----------------------------
1091 -- Increment_Serial_Number --
1092 -----------------------------
1094 function Increment_Serial_Number
return Nat
is
1095 TSN
: Int
renames Units
.Table
(Current_Sem_Unit
).Serial_Number
;
1099 end Increment_Serial_Number
;
1101 ----------------------
1102 -- Init_Unit_Name --
1103 ----------------------
1105 procedure Init_Unit_Name
(U
: Unit_Number_Type
; N
: Unit_Name_Type
) is
1107 Units
.Table
(U
).Unit_Name
:= N
;
1108 Unit_Names
.Set
(N
, U
);
1115 procedure Initialize
is
1117 Linker_Option_Lines
.Init
;
1121 Compilation_Switches
.Init
;
1128 function Is_Loaded
(Uname
: Unit_Name_Type
) return Boolean is
1130 return Unit_Names
.Get
(Uname
) /= No_Unit
;
1137 function Last_Unit
return Unit_Number_Type
is
1146 procedure List
(File_Names_Only
: Boolean := False) is separate;
1154 Linker_Option_Lines
.Release
;
1155 Linker_Option_Lines
.Locked
:= True;
1157 Load_Stack
.Locked
:= True;
1159 Units
.Locked
:= True;
1166 function Num_Units
return Nat
is
1168 return Int
(Units
.Last
) - Int
(Main_Unit
) + 1;
1175 procedure Remove_Unit
(U
: Unit_Number_Type
) is
1177 pragma Assert
(U
= Units
.Last
);
1178 Unit_Names
.Set
(Unit_Name
(U
), No_Unit
);
1179 Units
.Decrement_Last
;
1182 ----------------------------------
1183 -- Replace_Linker_Option_String --
1184 ----------------------------------
1186 procedure Replace_Linker_Option_String
1187 (S
: String_Id
; Match_String
: String)
1190 if Match_String
'Length > 0 then
1191 for J
in 1 .. Linker_Option_Lines
.Last
loop
1192 String_To_Name_Buffer
(Linker_Option_Lines
.Table
(J
).Option
);
1194 if Match_String
= Name_Buffer
(1 .. Match_String
'Length) then
1195 Linker_Option_Lines
.Table
(J
).Option
:= S
;
1201 Store_Linker_Option_String
(S
);
1202 end Replace_Linker_Option_String
;
1208 procedure Sort
(Tbl
: in out Unit_Ref_Table
) is separate;
1210 ------------------------------
1211 -- Store_Compilation_Switch --
1212 ------------------------------
1214 procedure Store_Compilation_Switch
(Switch
: String) is
1216 if Switch_Storing_Enabled
then
1217 Compilation_Switches
.Increment_Last
;
1218 Compilation_Switches
.Table
(Compilation_Switches
.Last
) :=
1219 new String'(Switch);
1221 -- Fix up --RTS flag which has been transformed by the gcc driver
1224 if Switch'Last >= Switch'First + 4
1225 and then Switch (Switch'First .. Switch'First + 4) = "-fRTS"
1227 Compilation_Switches.Table
1228 (Compilation_Switches.Last) (Switch'First + 1) := '-';
1231 end Store_Compilation_Switch;
1233 --------------------------------
1234 -- Store_Linker_Option_String --
1235 --------------------------------
1237 procedure Store_Linker_Option_String (S : String_Id) is
1239 Linker_Option_Lines.Append ((Option => S, Unit => Current_Sem_Unit));
1240 end Store_Linker_Option_String;
1246 procedure Store_Note (N : Node_Id) is
1247 Sfile : constant Source_File_Index := Get_Source_File_Index (Sloc (N));
1250 -- Notes for a generic are emitted when processing the template, never
1253 if In_Extended_Main_Code_Unit (N)
1254 and then Instance (Sfile) = No_Instance_Id
1260 -------------------------------
1261 -- Synchronize_Serial_Number --
1262 -------------------------------
1264 procedure Synchronize_Serial_Number (SN : Nat) is
1265 TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
1267 -- We should not be trying to synchronize downward
1269 pragma Assert (TSN <= SN);
1274 end Synchronize_Serial_Number;
1276 --------------------
1277 -- Unit_Name_Hash --
1278 --------------------
1280 function Unit_Name_Hash (Id : Unit_Name_Type) return Unit_Name_Header_Num is
1282 return Unit_Name_Header_Num (Id mod Unit_Name_Table_Size);
1291 Linker_Option_Lines.Locked := False;
1292 Load_Stack.Locked := False;
1293 Units.Locked := False;
1300 function Version_Get (U : Unit_Number_Type) return Word_Hex_String is
1302 return Get_Hex_String (Units.Table (U).Version);
1305 ------------------------
1306 -- Version_Referenced --
1307 ------------------------
1309 procedure Version_Referenced (S : String_Id) is
1311 Version_Ref.Append (S);
1312 end Version_Referenced;
1314 ---------------------
1315 -- Write_Unit_Info --
1316 ---------------------
1318 procedure Write_Unit_Info
1319 (Unit_Num : Unit_Number_Type;
1321 Prefix : String := "";
1322 Withs : Boolean := False)
1326 Write_Unit_Name (Unit_Name (Unit_Num));
1327 Write_Str (", unit ");
1328 Write_Int (Int (Unit_Num));
1330 Write_Int (Int (Item));
1332 Write_Str (Node_Kind'Image (Nkind (Item)));
1334 if Is_Rewrite_Substitution (Item) then
1335 Write_Str (", orig = ");
1336 Write_Int (Int (Original_Node (Item)));
1338 Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
1343 -- Skip the rest if we're not supposed to print the withs
1350 Context_Item : Node_Id;
1353 Context_Item := First (Context_Items (Cunit (Unit_Num)));
1354 while Present (Context_Item)
1355 and then (Nkind (Context_Item) /= N_With_Clause
1356 or else Limited_Present (Context_Item))
1358 Next (Context_Item);
1361 if Present (Context_Item) then
1363 Write_Line ("withs:");
1366 while Present (Context_Item) loop
1367 if Nkind (Context_Item) = N_With_Clause
1368 and then not Limited_Present (Context_Item)
1370 pragma Assert (Present (Library_Unit (Context_Item)));
1373 (Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
1375 if Implicit_With (Context_Item) then
1376 Write_Str (" -- implicit");
1382 Next (Context_Item);
1386 Write_Line ("end withs");
1390 end Write_Unit_Info;