1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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 Fname
; use Fname
;
40 with Nlists
; use Nlists
;
42 with Output
; use Output
;
43 with Sinfo
; use Sinfo
;
44 with Sinput
; use Sinput
;
45 with Stand
; use Stand
;
46 with Stringt
; use Stringt
;
47 with Tree_IO
; use Tree_IO
;
48 with Uname
; use Uname
;
49 with Widechar
; use Widechar
;
53 Switch_Storing_Enabled
: Boolean := True;
54 -- Controlled by Enable_Switch_Storing/Disable_Switch_Storing
56 -----------------------
57 -- Local Subprograms --
58 -----------------------
61 Yes_Before
, -- S1 is in same extended unit as S2 and appears before it
62 Yes_Same
, -- S1 is in same extended unit as S2, Slocs are the same
63 Yes_After
, -- S1 is in same extended unit as S2, and appears after it
64 No
); -- S2 is not in same extended unit as S2
66 function Check_Same_Extended_Unit
(S1
, S2
: Source_Ptr
) return SEU_Result
;
67 -- Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns
68 -- value as described above.
70 function Get_Code_Or_Source_Unit
72 Unwind_Instances
: Boolean;
73 Unwind_Subunits
: Boolean) return Unit_Number_Type
;
74 -- Common processing for routines Get_Code_Unit, Get_Source_Unit, and
75 -- Get_Top_Level_Code_Unit. Unwind_Instances is True when the unit for the
76 -- top-level instantiation should be returned instead of the unit for the
77 -- template, in the case of an instantiation. Unwind_Subunits is True when
78 -- the corresponding top-level unit should be returned instead of a
79 -- subunit, in the case of a subunit.
81 --------------------------------------------
82 -- Access Functions for Unit Table Fields --
83 --------------------------------------------
85 function Cunit
(U
: Unit_Number_Type
) return Node_Id
is
87 return Units
.Table
(U
).Cunit
;
90 function Cunit_Entity
(U
: Unit_Number_Type
) return Entity_Id
is
92 return Units
.Table
(U
).Cunit_Entity
;
95 function Dependency_Num
(U
: Unit_Number_Type
) return Nat
is
97 return Units
.Table
(U
).Dependency_Num
;
100 function Dynamic_Elab
(U
: Unit_Number_Type
) return Boolean is
102 return Units
.Table
(U
).Dynamic_Elab
;
105 function Error_Location
(U
: Unit_Number_Type
) return Source_Ptr
is
107 return Units
.Table
(U
).Error_Location
;
110 function Expected_Unit
(U
: Unit_Number_Type
) return Unit_Name_Type
is
112 return Units
.Table
(U
).Expected_Unit
;
115 function Fatal_Error
(U
: Unit_Number_Type
) return Fatal_Type
is
117 return Units
.Table
(U
).Fatal_Error
;
120 function Generate_Code
(U
: Unit_Number_Type
) return Boolean is
122 return Units
.Table
(U
).Generate_Code
;
125 function Has_RACW
(U
: Unit_Number_Type
) return Boolean is
127 return Units
.Table
(U
).Has_RACW
;
130 function Ident_String
(U
: Unit_Number_Type
) return Node_Id
is
132 return Units
.Table
(U
).Ident_String
;
135 function Loading
(U
: Unit_Number_Type
) return Boolean is
137 return Units
.Table
(U
).Loading
;
140 function Main_CPU
(U
: Unit_Number_Type
) return Int
is
142 return Units
.Table
(U
).Main_CPU
;
145 function Main_Priority
(U
: Unit_Number_Type
) return Int
is
147 return Units
.Table
(U
).Main_Priority
;
150 function Munit_Index
(U
: Unit_Number_Type
) return Nat
is
152 return Units
.Table
(U
).Munit_Index
;
155 function No_Elab_Code_All
(U
: Unit_Number_Type
) return Boolean is
157 return Units
.Table
(U
).No_Elab_Code_All
;
158 end No_Elab_Code_All
;
160 function OA_Setting
(U
: Unit_Number_Type
) return Character is
162 return Units
.Table
(U
).OA_Setting
;
165 function Source_Index
(U
: Unit_Number_Type
) return Source_File_Index
is
167 return Units
.Table
(U
).Source_Index
;
170 function Unit_File_Name
(U
: Unit_Number_Type
) return File_Name_Type
is
172 return Units
.Table
(U
).Unit_File_Name
;
175 function Unit_Name
(U
: Unit_Number_Type
) return Unit_Name_Type
is
177 return Units
.Table
(U
).Unit_Name
;
180 ------------------------------------------
181 -- Subprograms to Set Unit Table Fields --
182 ------------------------------------------
184 procedure Set_Cunit
(U
: Unit_Number_Type
; N
: Node_Id
) is
186 Units
.Table
(U
).Cunit
:= N
;
189 procedure Set_Cunit_Entity
(U
: Unit_Number_Type
; E
: Entity_Id
) is
191 Units
.Table
(U
).Cunit_Entity
:= E
;
192 Set_Is_Compilation_Unit
(E
);
193 end Set_Cunit_Entity
;
195 procedure Set_Dynamic_Elab
(U
: Unit_Number_Type
; B
: Boolean := True) is
197 Units
.Table
(U
).Dynamic_Elab
:= B
;
198 end Set_Dynamic_Elab
;
200 procedure Set_Error_Location
(U
: Unit_Number_Type
; W
: Source_Ptr
) is
202 Units
.Table
(U
).Error_Location
:= W
;
203 end Set_Error_Location
;
205 procedure Set_Fatal_Error
(U
: Unit_Number_Type
; V
: Fatal_Type
) is
207 Units
.Table
(U
).Fatal_Error
:= V
;
210 procedure Set_Generate_Code
(U
: Unit_Number_Type
; B
: Boolean := True) is
212 Units
.Table
(U
).Generate_Code
:= B
;
213 end Set_Generate_Code
;
215 procedure Set_Has_RACW
(U
: Unit_Number_Type
; B
: Boolean := True) is
217 Units
.Table
(U
).Has_RACW
:= B
;
220 procedure Set_Ident_String
(U
: Unit_Number_Type
; N
: Node_Id
) is
222 Units
.Table
(U
).Ident_String
:= N
;
223 end Set_Ident_String
;
225 procedure Set_Loading
(U
: Unit_Number_Type
; B
: Boolean := True) is
227 Units
.Table
(U
).Loading
:= B
;
230 procedure Set_Main_CPU
(U
: Unit_Number_Type
; P
: Int
) is
232 Units
.Table
(U
).Main_CPU
:= P
;
235 procedure Set_Main_Priority
(U
: Unit_Number_Type
; P
: Int
) is
237 Units
.Table
(U
).Main_Priority
:= P
;
238 end Set_Main_Priority
;
240 procedure Set_No_Elab_Code_All
241 (U
: Unit_Number_Type
;
245 Units
.Table
(U
).No_Elab_Code_All
:= B
;
246 end Set_No_Elab_Code_All
;
248 procedure Set_OA_Setting
(U
: Unit_Number_Type
; C
: Character) is
250 Units
.Table
(U
).OA_Setting
:= C
;
253 procedure Set_Unit_Name
(U
: Unit_Number_Type
; N
: Unit_Name_Type
) is
255 Units
.Table
(U
).Unit_Name
:= N
;
258 ------------------------------
259 -- Check_Same_Extended_Unit --
260 ------------------------------
262 function Check_Same_Extended_Unit
(S1
, S2
: Source_Ptr
) return SEU_Result
is
263 Max_Iterations
: constant Nat
:= Maximum_Instantiations
* 2;
264 -- Limit to prevent a potential infinite loop
271 Sind1
: Source_File_Index
;
272 Sind2
: Source_File_Index
;
277 Unum1
: Unit_Number_Type
;
278 Unum2
: Unit_Number_Type
;
281 if S1
= No_Location
or else S2
= No_Location
then
284 elsif S1
= Standard_Location
then
285 if S2
= Standard_Location
then
291 elsif S2
= Standard_Location
then
298 Unum1
:= Get_Source_Unit
(Sloc1
);
299 Unum2
:= Get_Source_Unit
(Sloc2
);
302 -- Step 1: Check whether the two locations are in the same source
305 Sind1
:= Get_Source_File_Index
(Sloc1
);
306 Sind2
:= Get_Source_File_Index
(Sloc2
);
308 if Sind1
= Sind2
then
309 if Sloc1
< Sloc2
then
311 elsif Sloc1
> Sloc2
then
318 -- Step 2: Check subunits. If a subunit is instantiated, follow the
319 -- instantiation chain rather than the stub chain.
321 Unit1
:= Unit
(Cunit
(Unum1
));
322 Unit2
:= Unit
(Cunit
(Unum2
));
323 Inst1
:= Instantiation
(Sind1
);
324 Inst2
:= Instantiation
(Sind2
);
326 if Nkind
(Unit1
) = N_Subunit
327 and then Present
(Corresponding_Stub
(Unit1
))
328 and then Inst1
= No_Location
330 if Nkind
(Unit2
) = N_Subunit
331 and then Present
(Corresponding_Stub
(Unit2
))
332 and then Inst2
= No_Location
334 -- Both locations refer to subunits which may have a common
335 -- ancestor. If they do, the deeper subunit must have a longer
336 -- unit name. Replace the deeper one with its corresponding
337 -- stub in order to find the nearest ancestor.
339 if Length_Of_Name
(Unit_Name
(Unum1
)) <
340 Length_Of_Name
(Unit_Name
(Unum2
))
342 Sloc2
:= Sloc
(Corresponding_Stub
(Unit2
));
343 Unum2
:= Get_Source_Unit
(Sloc2
);
347 Sloc1
:= Sloc
(Corresponding_Stub
(Unit1
));
348 Unum1
:= Get_Source_Unit
(Sloc1
);
352 -- Sloc1 in subunit, Sloc2 not
355 Sloc1
:= Sloc
(Corresponding_Stub
(Unit1
));
356 Unum1
:= Get_Source_Unit
(Sloc1
);
360 -- Sloc2 in subunit, Sloc1 not
362 elsif Nkind
(Unit2
) = N_Subunit
363 and then Present
(Corresponding_Stub
(Unit2
))
364 and then Inst2
= No_Location
366 Sloc2
:= Sloc
(Corresponding_Stub
(Unit2
));
367 Unum2
:= Get_Source_Unit
(Sloc2
);
371 -- Step 3: Check instances. The two locations may yield a common
374 if Inst1
/= No_Location
then
375 if Inst2
/= No_Location
then
377 -- Both locations denote instantiations
379 Depth1
:= Instantiation_Depth
(Sloc1
);
380 Depth2
:= Instantiation_Depth
(Sloc2
);
382 if Depth1
< Depth2
then
384 Unum2
:= Get_Source_Unit
(Sloc2
);
387 elsif Depth1
> Depth2
then
389 Unum1
:= Get_Source_Unit
(Sloc1
);
395 Unum1
:= Get_Source_Unit
(Sloc1
);
396 Unum2
:= Get_Source_Unit
(Sloc2
);
400 -- Sloc1 is an instantiation
404 Unum1
:= Get_Source_Unit
(Sloc1
);
408 -- Sloc2 is an instantiation
410 elsif Inst2
/= No_Location
then
412 Unum2
:= Get_Source_Unit
(Sloc2
);
416 -- Step 4: One location in the spec, the other in the corresponding
417 -- body of the same unit. The location in the spec is considered
420 if Nkind
(Unit1
) = N_Subprogram_Body
422 Nkind
(Unit1
) = N_Package_Body
424 if Library_Unit
(Cunit
(Unum1
)) = Cunit
(Unum2
) then
428 elsif Nkind
(Unit2
) = N_Subprogram_Body
430 Nkind
(Unit2
) = N_Package_Body
432 if Library_Unit
(Cunit
(Unum2
)) = Cunit
(Unum1
) then
437 -- At this point it is certain that the two locations denote two
438 -- entirely separate units.
443 Counter
:= Counter
+ 1;
445 -- Prevent looping forever
447 if Counter
> Max_Iterations
then
448 -- ??? Not quite right, but return a value to be able to generate
449 -- SCIL files and hope for the best.
451 if CodePeer_Mode
then
458 end Check_Same_Extended_Unit
;
460 -------------------------------
461 -- Compilation_Switches_Last --
462 -------------------------------
464 function Compilation_Switches_Last
return Nat
is
466 return Compilation_Switches
.Last
;
467 end Compilation_Switches_Last
;
469 ---------------------------
470 -- Enable_Switch_Storing --
471 ---------------------------
473 procedure Enable_Switch_Storing
is
475 Switch_Storing_Enabled
:= True;
476 end Enable_Switch_Storing
;
478 ----------------------------
479 -- Disable_Switch_Storing --
480 ----------------------------
482 procedure Disable_Switch_Storing
is
484 Switch_Storing_Enabled
:= False;
485 end Disable_Switch_Storing
;
487 ------------------------------
488 -- Earlier_In_Extended_Unit --
489 ------------------------------
491 function Earlier_In_Extended_Unit
(S1
, S2
: Source_Ptr
) return Boolean is
493 return Check_Same_Extended_Unit
(S1
, S2
) = Yes_Before
;
494 end Earlier_In_Extended_Unit
;
496 -----------------------
497 -- Exact_Source_Name --
498 -----------------------
500 function Exact_Source_Name
(Loc
: Source_Ptr
) return String is
501 U
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
502 Buf
: constant Source_Buffer_Ptr
:= Source_Text
(Source_Index
(U
));
503 Orig
: constant Source_Ptr
:= Original_Location
(Loc
);
508 pragma Warnings
(Off
, WC
);
509 pragma Warnings
(Off
, Err
);
512 -- Entity is character literal
514 if Buf
(Orig
) = ''' then
515 return String (Buf
(Orig
.. Orig
+ 2));
517 -- Entity is operator symbol
519 elsif Buf
(Orig
) = '"' or else Buf
(Orig
) = '%' then
524 exit when Buf
(P
) = Buf
(Orig
);
527 return String (Buf
(Orig
.. P
));
529 -- Entity is identifier
535 if Is_Start_Of_Wide_Char
(Buf
, P
) then
536 Scan_Wide
(Buf
, P
, WC
, Err
);
537 elsif not Identifier_Char
(Buf
(P
)) then
544 -- Write out the identifier by copying the exact source characters
545 -- used in its declaration. Note that this means wide characters will
546 -- be in their original encoded form.
548 return String (Buf
(Orig
.. P
- 1));
550 end Exact_Source_Name
;
552 ----------------------------
553 -- Entity_Is_In_Main_Unit --
554 ----------------------------
556 function Entity_Is_In_Main_Unit
(E
: Entity_Id
) return Boolean is
562 while S
/= Standard_Standard
loop
563 if S
= Main_Unit_Entity
then
565 elsif Ekind
(S
) = E_Package
and then Is_Child_Unit
(S
) then
573 end Entity_Is_In_Main_Unit
;
575 --------------------------
576 -- Generic_May_Lack_ALI --
577 --------------------------
579 function Generic_May_Lack_ALI
(Sfile
: File_Name_Type
) return Boolean is
581 -- We allow internal generic units to be used without having a
582 -- corresponding ALI files to help bootstrapping with older compilers
583 -- that did not support generating ALIs for such generics. It is safe
584 -- to do so because the only thing the generated code would contain
585 -- is the elaboration boolean, and we are careful to elaborate all
586 -- predefined units first anyway.
588 return Is_Internal_File_Name
590 Renamings_Included
=> True);
591 end Generic_May_Lack_ALI
;
593 -----------------------------
594 -- Get_Code_Or_Source_Unit --
595 -----------------------------
597 function Get_Code_Or_Source_Unit
599 Unwind_Instances
: Boolean;
600 Unwind_Subunits
: Boolean) return Unit_Number_Type
603 -- Search table unless we have No_Location, which can happen if the
604 -- relevant location has not been set yet. Happens for example when
605 -- we obtain Sloc (Cunit (Main_Unit)) before it is set.
607 if S
/= No_Location
then
609 Source_File
: Source_File_Index
;
610 Source_Unit
: Unit_Number_Type
;
614 Source_File
:= Get_Source_File_Index
(S
);
616 if Unwind_Instances
then
617 while Template
(Source_File
) /= No_Source_File
loop
618 Source_File
:= Template
(Source_File
);
622 Source_Unit
:= Unit
(Source_File
);
624 if Unwind_Subunits
then
625 Unit_Node
:= Unit
(Cunit
(Source_Unit
));
627 while Nkind
(Unit_Node
) = N_Subunit
628 and then Present
(Corresponding_Stub
(Unit_Node
))
631 Get_Code_Or_Source_Unit
632 (Sloc
(Corresponding_Stub
(Unit_Node
)),
633 Unwind_Instances
=> Unwind_Instances
,
634 Unwind_Subunits
=> Unwind_Subunits
);
635 Unit_Node
:= Unit
(Cunit
(Source_Unit
));
639 if Source_Unit
/= No_Unit
then
645 -- If S was No_Location, or was not in the table, we must be in the main
646 -- source unit (and the value has not been placed in the table yet),
647 -- or in one of the configuration pragma files.
650 end Get_Code_Or_Source_Unit
;
656 function Get_Code_Unit
(S
: Source_Ptr
) return Unit_Number_Type
is
659 Get_Code_Or_Source_Unit
660 (Top_Level_Location
(S
),
661 Unwind_Instances
=> False,
662 Unwind_Subunits
=> False);
665 function Get_Code_Unit
(N
: Node_Or_Entity_Id
) return Unit_Number_Type
is
667 return Get_Code_Unit
(Sloc
(N
));
670 ----------------------------
671 -- Get_Compilation_Switch --
672 ----------------------------
674 function Get_Compilation_Switch
(N
: Pos
) return String_Ptr
is
676 if N
<= Compilation_Switches
.Last
then
677 return Compilation_Switches
.Table
(N
);
681 end Get_Compilation_Switch
;
683 ----------------------------------
684 -- Get_Cunit_Entity_Unit_Number --
685 ----------------------------------
687 function Get_Cunit_Entity_Unit_Number
688 (E
: Entity_Id
) return Unit_Number_Type
691 for U
in Units
.First
.. Units
.Last
loop
692 if Cunit_Entity
(U
) = E
then
697 -- If not in the table, must be the main source unit, and we just
698 -- have not got it put into the table yet.
701 end Get_Cunit_Entity_Unit_Number
;
703 ---------------------------
704 -- Get_Cunit_Unit_Number --
705 ---------------------------
707 function Get_Cunit_Unit_Number
(N
: Node_Id
) return Unit_Number_Type
is
709 for U
in Units
.First
.. Units
.Last
loop
710 if Cunit
(U
) = N
then
715 -- If not in the table, must be a spec created for a main unit that is a
716 -- child subprogram body which we have not inserted into the table yet.
718 if N
= Library_Unit
(Cunit
(Main_Unit
)) then
721 -- If it is anything else, something is seriously wrong, and we really
722 -- don't want to proceed, even if assertions are off, so we explicitly
723 -- raise an exception in this case to terminate compilation.
728 end Get_Cunit_Unit_Number
;
730 ---------------------
731 -- Get_Source_Unit --
732 ---------------------
734 function Get_Source_Unit
(S
: Source_Ptr
) return Unit_Number_Type
is
737 Get_Code_Or_Source_Unit
738 (S
, Unwind_Instances
=> True, Unwind_Subunits
=> False);
741 function Get_Source_Unit
(N
: Node_Or_Entity_Id
) return Unit_Number_Type
is
743 return Get_Source_Unit
(Sloc
(N
));
746 -----------------------------
747 -- Get_Top_Level_Code_Unit --
748 -----------------------------
750 function Get_Top_Level_Code_Unit
(S
: Source_Ptr
) return Unit_Number_Type
is
753 Get_Code_Or_Source_Unit
754 (Top_Level_Location
(S
),
755 Unwind_Instances
=> False,
756 Unwind_Subunits
=> True);
757 end Get_Top_Level_Code_Unit
;
759 function Get_Top_Level_Code_Unit
760 (N
: Node_Or_Entity_Id
) return Unit_Number_Type
is
762 return Get_Top_Level_Code_Unit
(Sloc
(N
));
763 end Get_Top_Level_Code_Unit
;
765 --------------------------------
766 -- In_Extended_Main_Code_Unit --
767 --------------------------------
769 function In_Extended_Main_Code_Unit
770 (N
: Node_Or_Entity_Id
) return Boolean
773 if Sloc
(N
) = Standard_Location
then
776 elsif Sloc
(N
) = No_Location
then
779 -- Special case Itypes to test the Sloc of the associated node. The
780 -- reason we do this is for possible calls from gigi after -gnatD
781 -- processing is complete in sprint. This processing updates the
782 -- sloc fields of all nodes in the tree, but itypes are not in the
783 -- tree so their slocs do not get updated.
785 elsif Nkind
(N
) = N_Defining_Identifier
786 and then Is_Itype
(N
)
788 return In_Extended_Main_Code_Unit
(Associated_Node_For_Itype
(N
));
790 -- Otherwise see if we are in the main unit
792 elsif Get_Code_Unit
(Sloc
(N
)) = Get_Code_Unit
(Cunit
(Main_Unit
)) then
795 -- Node may be in spec (or subunit etc) of main unit
799 In_Same_Extended_Unit
(N
, Cunit
(Main_Unit
));
801 end In_Extended_Main_Code_Unit
;
803 function In_Extended_Main_Code_Unit
(Loc
: Source_Ptr
) return Boolean is
805 if Loc
= Standard_Location
then
808 elsif Loc
= No_Location
then
811 -- Otherwise see if we are in the main unit
813 elsif Get_Code_Unit
(Loc
) = Get_Code_Unit
(Cunit
(Main_Unit
)) then
816 -- Location may be in spec (or subunit etc) of main unit
820 In_Same_Extended_Unit
(Loc
, Sloc
(Cunit
(Main_Unit
)));
822 end In_Extended_Main_Code_Unit
;
824 ----------------------------------
825 -- In_Extended_Main_Source_Unit --
826 ----------------------------------
828 function In_Extended_Main_Source_Unit
829 (N
: Node_Or_Entity_Id
) return Boolean
831 Nloc
: constant Source_Ptr
:= Sloc
(N
);
832 Mloc
: constant Source_Ptr
:= Sloc
(Cunit
(Main_Unit
));
835 -- If parsing, then use the global flag to indicate result
837 if Compiler_State
= Parsing
then
838 return Parsing_Main_Extended_Source
;
840 -- Special value cases
842 elsif Nloc
= Standard_Location
then
845 elsif Nloc
= No_Location
then
848 -- Special case Itypes to test the Sloc of the associated node. The
849 -- reason we do this is for possible calls from gigi after -gnatD
850 -- processing is complete in sprint. This processing updates the
851 -- sloc fields of all nodes in the tree, but itypes are not in the
852 -- tree so their slocs do not get updated.
854 elsif Nkind
(N
) = N_Defining_Identifier
855 and then Is_Itype
(N
)
857 return In_Extended_Main_Source_Unit
(Associated_Node_For_Itype
(N
));
859 -- Otherwise compare original locations to see if in same unit
863 In_Same_Extended_Unit
864 (Original_Location
(Nloc
), Original_Location
(Mloc
));
866 end In_Extended_Main_Source_Unit
;
868 function In_Extended_Main_Source_Unit
869 (Loc
: Source_Ptr
) return Boolean
871 Mloc
: constant Source_Ptr
:= Sloc
(Cunit
(Main_Unit
));
874 -- If parsing, then use the global flag to indicate result
876 if Compiler_State
= Parsing
then
877 return Parsing_Main_Extended_Source
;
879 -- Special value cases
881 elsif Loc
= Standard_Location
then
884 elsif Loc
= No_Location
then
887 -- Otherwise compare original locations to see if in same unit
891 In_Same_Extended_Unit
892 (Original_Location
(Loc
), Original_Location
(Mloc
));
894 end In_Extended_Main_Source_Unit
;
896 ------------------------
897 -- In_Predefined_Unit --
898 ------------------------
900 function In_Predefined_Unit
(N
: Node_Or_Entity_Id
) return Boolean is
902 return In_Predefined_Unit
(Sloc
(N
));
903 end In_Predefined_Unit
;
905 function In_Predefined_Unit
(S
: Source_Ptr
) return Boolean is
906 Unit
: constant Unit_Number_Type
:= Get_Source_Unit
(S
);
907 File
: constant File_Name_Type
:= Unit_File_Name
(Unit
);
909 return Is_Predefined_File_Name
(File
);
910 end In_Predefined_Unit
;
912 -----------------------
913 -- In_Same_Code_Unit --
914 -----------------------
916 function In_Same_Code_Unit
(N1
, N2
: Node_Or_Entity_Id
) return Boolean is
917 S1
: constant Source_Ptr
:= Sloc
(N1
);
918 S2
: constant Source_Ptr
:= Sloc
(N2
);
921 if S1
= No_Location
or else S2
= No_Location
then
924 elsif S1
= Standard_Location
then
925 return S2
= Standard_Location
;
927 elsif S2
= Standard_Location
then
931 return Get_Code_Unit
(N1
) = Get_Code_Unit
(N2
);
932 end In_Same_Code_Unit
;
934 ---------------------------
935 -- In_Same_Extended_Unit --
936 ---------------------------
938 function In_Same_Extended_Unit
939 (N1
, N2
: Node_Or_Entity_Id
) return Boolean
942 return Check_Same_Extended_Unit
(Sloc
(N1
), Sloc
(N2
)) /= No
;
943 end In_Same_Extended_Unit
;
945 function In_Same_Extended_Unit
(S1
, S2
: Source_Ptr
) return Boolean is
947 return Check_Same_Extended_Unit
(S1
, S2
) /= No
;
948 end In_Same_Extended_Unit
;
950 -------------------------
951 -- In_Same_Source_Unit --
952 -------------------------
954 function In_Same_Source_Unit
(N1
, N2
: Node_Or_Entity_Id
) return Boolean is
955 S1
: constant Source_Ptr
:= Sloc
(N1
);
956 S2
: constant Source_Ptr
:= Sloc
(N2
);
959 if S1
= No_Location
or else S2
= No_Location
then
962 elsif S1
= Standard_Location
then
963 return S2
= Standard_Location
;
965 elsif S2
= Standard_Location
then
969 return Get_Source_Unit
(N1
) = Get_Source_Unit
(N2
);
970 end In_Same_Source_Unit
;
972 -----------------------------
973 -- Increment_Serial_Number --
974 -----------------------------
976 function Increment_Serial_Number
return Nat
is
977 TSN
: Int
renames Units
.Table
(Current_Sem_Unit
).Serial_Number
;
981 end Increment_Serial_Number
;
987 procedure Initialize
is
989 Linker_Option_Lines
.Init
;
993 Compilation_Switches
.Init
;
1000 function Is_Loaded
(Uname
: Unit_Name_Type
) return Boolean is
1002 for Unum
in Units
.First
.. Units
.Last
loop
1003 if Uname
= Unit_Name
(Unum
) then
1015 function Last_Unit
return Unit_Number_Type
is
1024 procedure List
(File_Names_Only
: Boolean := False) is separate;
1032 Linker_Option_Lines
.Locked
:= True;
1033 Load_Stack
.Locked
:= True;
1034 Units
.Locked
:= True;
1035 Linker_Option_Lines
.Release
;
1044 function Num_Units
return Nat
is
1046 return Int
(Units
.Last
) - Int
(Main_Unit
) + 1;
1053 procedure Remove_Unit
(U
: Unit_Number_Type
) is
1055 if U
= Units
.Last
then
1056 Units
.Decrement_Last
;
1060 ----------------------------------
1061 -- Replace_Linker_Option_String --
1062 ----------------------------------
1064 procedure Replace_Linker_Option_String
1065 (S
: String_Id
; Match_String
: String)
1068 if Match_String
'Length > 0 then
1069 for J
in 1 .. Linker_Option_Lines
.Last
loop
1070 String_To_Name_Buffer
(Linker_Option_Lines
.Table
(J
).Option
);
1072 if Match_String
= Name_Buffer
(1 .. Match_String
'Length) then
1073 Linker_Option_Lines
.Table
(J
).Option
:= S
;
1079 Store_Linker_Option_String
(S
);
1080 end Replace_Linker_Option_String
;
1086 procedure Sort
(Tbl
: in out Unit_Ref_Table
) is separate;
1088 ------------------------------
1089 -- Store_Compilation_Switch --
1090 ------------------------------
1092 procedure Store_Compilation_Switch
(Switch
: String) is
1094 if Switch_Storing_Enabled
then
1095 Compilation_Switches
.Increment_Last
;
1096 Compilation_Switches
.Table
(Compilation_Switches
.Last
) :=
1097 new String'(Switch);
1099 -- Fix up --RTS flag which has been transformed by the gcc driver
1102 if Switch'Last >= Switch'First + 4
1103 and then Switch (Switch'First .. Switch'First + 4) = "-fRTS"
1105 Compilation_Switches.Table
1106 (Compilation_Switches.Last) (Switch'First + 1) := '-';
1109 end Store_Compilation_Switch;
1111 --------------------------------
1112 -- Store_Linker_Option_String --
1113 --------------------------------
1115 procedure Store_Linker_Option_String (S : String_Id) is
1117 Linker_Option_Lines.Append ((Option => S, Unit => Current_Sem_Unit));
1118 end Store_Linker_Option_String;
1124 procedure Store_Note (N : Node_Id) is
1125 Sfile : constant Source_File_Index := Get_Source_File_Index (Sloc (N));
1128 -- Notes for a generic are emitted when processing the template, never
1131 if In_Extended_Main_Code_Unit (N)
1132 and then Instance (Sfile) = No_Instance_Id
1138 -------------------------------
1139 -- Synchronize_Serial_Number --
1140 -------------------------------
1142 procedure Synchronize_Serial_Number is
1143 TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
1146 end Synchronize_Serial_Number;
1152 procedure Tree_Read is
1159 -- Read Compilation_Switches table. First release the memory occupied
1160 -- by the previously loaded switches.
1162 for J in Compilation_Switches.First .. Compilation_Switches.Last loop
1163 Free (Compilation_Switches.Table (J));
1167 Compilation_Switches.Set_Last (N);
1169 for J in 1 .. N loop
1171 Compilation_Switches.Table (J) := S;
1179 procedure Tree_Write is
1183 -- Write Compilation_Switches table
1185 Tree_Write_Int (Compilation_Switches.Last);
1187 for J in 1 .. Compilation_Switches.Last loop
1188 Tree_Write_Str (Compilation_Switches.Table (J));
1198 Linker_Option_Lines.Locked := False;
1199 Load_Stack.Locked := False;
1200 Units.Locked := False;
1207 function Version_Get (U : Unit_Number_Type) return Word_Hex_String is
1209 return Get_Hex_String (Units.Table (U).Version);
1212 ------------------------
1213 -- Version_Referenced --
1214 ------------------------
1216 procedure Version_Referenced (S : String_Id) is
1218 Version_Ref.Append (S);
1219 end Version_Referenced;
1221 ---------------------
1222 -- Write_Unit_Info --
1223 ---------------------
1225 procedure Write_Unit_Info
1226 (Unit_Num : Unit_Number_Type;
1228 Prefix : String := "";
1229 Withs : Boolean := False)
1233 Write_Unit_Name (Unit_Name (Unit_Num));
1234 Write_Str (", unit ");
1235 Write_Int (Int (Unit_Num));
1237 Write_Int (Int (Item));
1239 Write_Str (Node_Kind'Image (Nkind (Item)));
1241 if Item /= Original_Node (Item) then
1242 Write_Str (", orig = ");
1243 Write_Int (Int (Original_Node (Item)));
1245 Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
1250 -- Skip the rest if we're not supposed to print the withs
1257 Context_Item : Node_Id;
1260 Context_Item := First (Context_Items (Cunit (Unit_Num)));
1261 while Present (Context_Item)
1262 and then (Nkind (Context_Item) /= N_With_Clause
1263 or else Limited_Present (Context_Item))
1265 Context_Item := Next (Context_Item);
1268 if Present (Context_Item) then
1270 Write_Line ("withs:");
1273 while Present (Context_Item) loop
1274 if Nkind (Context_Item) = N_With_Clause
1275 and then not Limited_Present (Context_Item)
1277 pragma Assert (Present (Library_Unit (Context_Item)));
1280 (Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
1282 if Implicit_With (Context_Item) then
1283 Write_Str (" -- implicit");
1289 Context_Item := Next (Context_Item);
1293 Write_Line ("end withs");
1297 end Write_Unit_Info;