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 -- The Par.Load procedure loads all units that are definitely required before
27 -- it makes any sense at all to proceed with semantic analysis, including
28 -- with'ed units, corresponding specs for bodies, parents of child specs,
29 -- and parents of subunits. All these units are loaded and pointers installed
30 -- in the tree as described in the spec of package Lib.
32 with Fname
.UF
; use Fname
.UF
;
33 with Lib
.Load
; use Lib
.Load
;
34 with Namet
.Sp
; use Namet
.Sp
;
35 with Uname
; use Uname
;
36 with Osint
; use Osint
;
37 with Sinput
.L
; use Sinput
.L
;
38 with Stylesw
; use Stylesw
;
40 with GNAT
.Spelling_Checker
; use GNAT
.Spelling_Checker
;
45 File_Name
: File_Name_Type
;
46 -- Name of file for current unit, derived from unit name
48 Cur_Unum
: constant Unit_Number_Type
:= Current_Source_Unit
;
49 -- Unit number of unit that we just finished parsing. Note that we need
50 -- to capture this, because Source_Unit will change as we parse new
51 -- source files in the multiple main source file case.
53 Curunit
: constant Node_Id
:= Cunit
(Cur_Unum
);
54 -- Compilation unit node for current compilation unit
56 Loc
: Source_Ptr
:= Sloc
(Curunit
);
57 -- Source location for compilation unit node
59 Save_Style_Check
: Boolean;
60 Save_Style_Checks
: Style_Check_Options
;
61 -- Save style check so it can be restored later
64 -- Compilation unit node for withed unit
66 Context_Node
: Node_Id
;
67 -- Next node in context items list
72 Spec_Name
: Unit_Name_Type
;
73 -- Unit name of required spec
75 Body_Name
: Unit_Name_Type
;
76 -- Unit name of corresponding body
78 Unum
: Unit_Number_Type
;
79 -- Unit number of loaded unit
81 Limited_With_Found
: Boolean := False;
82 -- We load the context items in two rounds: the first round handles normal
83 -- withed units and the second round handles Ada 2005 limited-withed units.
84 -- This is required to allow the low-level circuitry that detects circular
85 -- dependencies of units the correct notification of errors (see comment
86 -- bellow). This variable is used to indicate that the second round is
89 function Same_File_Name_Except_For_Case
90 (Expected_File_Name
: File_Name_Type
;
91 Actual_File_Name
: File_Name_Type
) return Boolean;
92 -- Given an actual file name and an expected file name (the latter being
93 -- derived from the unit name), determine if they are the same except for
94 -- possibly different casing of letters.
96 ------------------------------------
97 -- Same_File_Name_Except_For_Case --
98 ------------------------------------
100 function Same_File_Name_Except_For_Case
101 (Expected_File_Name
: File_Name_Type
;
102 Actual_File_Name
: File_Name_Type
) return Boolean
105 Get_Name_String
(Actual_File_Name
);
106 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
109 Lower_Case_Actual_File_Name
: String (1 .. Name_Len
);
112 Lower_Case_Actual_File_Name
:= Name_Buffer
(1 .. Name_Len
);
113 Get_Name_String
(Expected_File_Name
);
114 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
115 return Lower_Case_Actual_File_Name
= Name_Buffer
(1 .. Name_Len
);
118 end Same_File_Name_Except_For_Case
;
120 -- Start of processing for Load
123 -- Don't do any loads if we already had a fatal error
125 if Fatal_Error
(Cur_Unum
) = Error_Detected
then
129 Save_Style_Check_Options
(Save_Style_Checks
);
130 Save_Style_Check
:= Opt
.Style_Check
;
132 -- If main unit, set Main_Unit_Entity (this will get overwritten if the
133 -- main unit has a separate spec, that happens later on in Load).
135 if Cur_Unum
= Main_Unit
then
136 Main_Unit_Entity
:= Cunit_Entity
(Main_Unit
);
139 -- If we have no unit name, things are seriously messed up by previous
140 -- errors, and we should not try to continue compilation.
142 if Unit_Name
(Cur_Unum
) = No_Unit_Name
then
143 raise Unrecoverable_Error
;
146 -- Next step, make sure that the unit name matches the file name
147 -- and issue a warning message if not. We only output this for the
148 -- main unit, since for other units it is more serious and is
149 -- caught in a separate test below. We also inhibit the message in
150 -- multiple unit per file mode, because in this case the relation
151 -- between file name and unit name is broken.
155 (Unit_Name
(Cur_Unum
),
156 Subunit
=> Nkind
(Unit
(Cunit
(Cur_Unum
))) = N_Subunit
);
158 if Cur_Unum
= Main_Unit
159 and then Multiple_Unit_Index
= 0
160 and then File_Name
/= Unit_File_Name
(Cur_Unum
)
161 and then (File_Names_Case_Sensitive
162 or not Same_File_Name_Except_For_Case
163 (File_Name
, Unit_File_Name
(Cur_Unum
)))
165 Error_Msg_File_1
:= File_Name
;
167 ("??file name does not match unit name, should be{", Sloc
(Curunit
));
170 -- For units other than the main unit, the expected unit name is set and
171 -- must be the same as the actual unit name, or we are in big trouble, and
172 -- abandon the compilation since there are situations where this really
173 -- gets us into bad trouble (e.g. some subunit situations).
175 if Cur_Unum
/= Main_Unit
176 and then Expected_Unit
(Cur_Unum
) /= Unit_Name
(Cur_Unum
)
178 Loc
:= Error_Location
(Cur_Unum
);
179 Error_Msg_File_1
:= Unit_File_Name
(Cur_Unum
);
180 Get_Name_String
(Error_Msg_File_1
);
182 -- Check for predefined file case
185 and then Name_Buffer
(1) in 'a' |
's' |
'i' |
'g'
186 and then Name_Buffer
(2) = '-'
189 Expect_Name
: constant Unit_Name_Type
:= Expected_Unit
(Cur_Unum
);
190 Actual_Name
: constant Unit_Name_Type
:= Unit_Name
(Cur_Unum
);
193 Error_Msg_Unit_1
:= Expect_Name
;
195 ("$$ is not a predefined library unit!", Loc
);
197 -- In the predefined file case, we know the user did not
198 -- construct their own package, but we got the wrong one.
199 -- This means that the name supplied by the user crunched
200 -- to something we recognized, but then the file did not
201 -- contain the unit expected. Most likely this is due to
202 -- a misspelling, e.g.
204 -- with Ada.Calender;
206 -- This crunches to a-calend, which indeed contains the unit
207 -- Ada.Calendar, and we can diagnose the misspelling. This
208 -- is a simple heuristic, but it catches many common cases
209 -- of misspelling of predefined unit names without needing
210 -- a full list of them.
212 -- Before actually issuing the message, we will check that the
213 -- unit name is indeed a plausible misspelling of the one we got.
215 if Is_Bad_Spelling_Of
216 (Name_Id
(Expect_Name
), Name_Id
(Actual_Name
))
218 Error_Msg_Unit_1
:= Actual_Name
;
220 ("possible misspelling of $$!", Loc
);
224 -- Non-predefined file name case. In this case we generate a message
225 -- and then we quit, because we are in big trouble, and if we try
226 -- to continue compilation, we get into some nasty situations
227 -- (for example in some subunit cases).
230 Error_Msg
("file { does not contain expected unit!", Loc
);
231 Error_Msg_Unit_1
:= Expected_Unit
(Cur_Unum
);
232 Error_Msg
("\\expected unit $!", Loc
);
233 Error_Msg_Unit_1
:= Unit_Name
(Cur_Unum
);
234 Error_Msg
("\\found unit $!", Loc
);
237 -- In both cases, flag the fatal error and give up
239 Set_Fatal_Error
(Cur_Unum
, Error_Detected
);
243 -- If current unit is a body, load its corresponding spec
245 if Nkind
(Unit
(Curunit
)) in N_Package_Body | N_Subprogram_Body
then
246 Spec_Name
:= Get_Spec_Name
(Unit_Name
(Cur_Unum
));
249 (Load_Name
=> Spec_Name
,
252 Error_Node
=> Curunit
,
253 Corr_Body
=> Cur_Unum
,
254 PMES
=> (Cur_Unum
= Main_Unit
));
256 -- If we successfully load the unit, then set the spec/body pointers.
257 -- Once again note that if the loaded unit has a fatal error, Load will
258 -- have set our Fatal_Error flag to propagate this condition.
260 if Unum
/= No_Unit
then
261 Set_Library_Unit
(Curunit
, Cunit
(Unum
));
262 Set_Library_Unit
(Cunit
(Unum
), Curunit
);
264 -- If this is a separate spec for the main unit, then we reset
265 -- Main_Unit_Entity to point to the entity for this separate spec
266 -- and this is also where we generate the SCO's for this spec.
268 if Cur_Unum
= Main_Unit
then
270 -- We generate code for the main unit body, so we need to generate
271 -- code for its spec too.
273 Set_Generate_Code
(Unum
, True);
275 Main_Unit_Entity
:= Cunit_Entity
(Unum
);
278 SCO_Record_Raw
(Unum
);
282 -- If we don't find the spec, then if we have a subprogram body, we
283 -- are still OK, we just have a case of a body acting as its own spec
285 elsif Nkind
(Unit
(Curunit
)) = N_Subprogram_Body
then
286 Set_Acts_As_Spec
(Curunit
, True);
287 Set_Library_Unit
(Curunit
, Curunit
);
289 -- Otherwise we do have an error, repeat the load request for the spec
290 -- with Required set True to generate an appropriate error message.
295 (Load_Name
=> Spec_Name
,
298 Error_Node
=> Curunit
);
302 -- If current unit is a child unit spec, load its parent. If the child unit
303 -- is loaded through a limited with, the parent must be as well.
305 elsif Nkind
(Unit
(Curunit
)) in N_Package_Declaration
306 | N_Subprogram_Declaration
307 | N_Generic_Declaration
308 | N_Generic_Instantiation
309 | N_Renaming_Declaration
311 -- Turn style checks off for parent unit
313 if not GNAT_Mode
then
314 Reset_Style_Check_Options
;
317 Spec_Name
:= Get_Parent_Spec_Name
(Unit_Name
(Cur_Unum
));
319 if Present
(Spec_Name
) then
322 (Load_Name
=> Spec_Name
,
325 Error_Node
=> Curunit
);
327 if Unum
/= No_Unit
then
328 Set_Parent_Spec
(Unit
(Curunit
), Cunit
(Unum
));
332 -- If current unit is a subunit, then load its parent body
334 elsif Nkind
(Unit
(Curunit
)) = N_Subunit
then
335 Body_Name
:= Get_Parent_Body_Name
(Unit_Name
(Cur_Unum
));
338 (Load_Name
=> Body_Name
,
341 Error_Node
=> Name
(Unit
(Curunit
)));
343 if Unum
/= No_Unit
then
344 Set_Library_Unit
(Curunit
, Cunit
(Unum
));
348 -- Now we load with'ed units, with style checks turned off
350 if not GNAT_Mode
then
351 Reset_Style_Check_Options
;
354 -- Load the context items in two rounds: the first round handles normal
355 -- withed units and the second round handles Ada 2005 limited-withed units.
356 -- This is required to allow the low-level circuitry that detects circular
357 -- dependencies of units the correct notification of the following error:
361 -- package C is ... package D is ...
363 for Round
in 1 .. 2 loop
364 Context_Node
:= First
(Context_Items
(Curunit
));
365 while Present
(Context_Node
) loop
367 -- During the first round we check if there is some limited-with
368 -- context clause; otherwise the second round will be skipped
370 if Nkind
(Context_Node
) = N_With_Clause
372 and then Limited_Present
(Context_Node
)
374 Limited_With_Found
:= True;
377 if Nkind
(Context_Node
) = N_With_Clause
378 and then ((Round
= 1 and then not Limited_Present
(Context_Node
))
380 (Round
= 2 and then Limited_Present
(Context_Node
)))
382 With_Node
:= Context_Node
;
383 Spec_Name
:= Get_Unit_Name
(With_Node
);
387 (Load_Name
=> Spec_Name
,
390 Error_Node
=> With_Node
,
392 With_Node
=> Context_Node
);
394 -- If we find the unit, then set spec pointer in the N_With_Clause
395 -- to point to the compilation unit for the spec. Remember that
396 -- the Load routine itself sets our Fatal_Error flag if the loaded
397 -- unit gets a fatal error, so we don't need to worry about that.
399 if Unum
/= No_Unit
then
400 Set_Library_Unit
(With_Node
, Cunit
(Unum
));
402 -- If the spec isn't found, then try finding the corresponding
403 -- body, since it is possible that we have a subprogram body
404 -- that is acting as a spec (since no spec is present).
407 Body_Name
:= Get_Body_Name
(Spec_Name
);
410 (Load_Name
=> Body_Name
,
413 Error_Node
=> With_Node
,
416 -- If we got a subprogram body, then mark that we are using
417 -- the body as a spec in the file table, and set the spec
418 -- pointer in the N_With_Clause to point to the body entity.
421 and then Nkind
(Unit
(Cunit
(Unum
))) = N_Subprogram_Body
423 With_Cunit
:= Cunit
(Unum
);
424 Set_Library_Unit
(With_Node
, With_Cunit
);
425 Set_Acts_As_Spec
(With_Cunit
, True);
426 Set_Library_Unit
(With_Cunit
, With_Cunit
);
428 -- If we couldn't find the body, or if it wasn't a body spec
429 -- then we are in trouble. We make one more call to Load to
430 -- require the spec. We know it will fail of course, the
431 -- purpose is to generate the required error message (we prefer
432 -- that this message refer to the missing spec, not the body)
437 (Load_Name
=> Spec_Name
,
440 Error_Node
=> With_Node
,
443 -- Here we create a dummy package unit for the missing unit
445 Unum
:= Create_Dummy_Package_Unit
(With_Node
, Spec_Name
);
446 Set_Library_Unit
(With_Node
, Cunit
(Unum
));
454 exit when not Limited_With_Found
;
457 -- Restore style/validity check mode for main unit
459 Set_Style_Check_Options
(Save_Style_Checks
);
460 Opt
.Style_Check
:= Save_Style_Check
;