1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 -- The Par.Load procedure loads all units that are definitely required before
28 -- it makes any sense at all to proceed with semantic analysis, including
29 -- with'ed units, corresponding specs for bodies, parents of child specs,
30 -- and parents of subunits. All these units are loaded and pointers installed
31 -- in the tree as described in the spec of package Lib.
33 with Fname
.UF
; use Fname
.UF
;
34 with Lib
.Load
; use Lib
.Load
;
35 with Uname
; use Uname
;
36 with Osint
; use Osint
;
37 with Sinput
.L
; use Sinput
.L
;
38 with Stylesw
; use Stylesw
;
39 with Validsw
; use Validsw
;
41 with GNAT
.Spelling_Checker
; use GNAT
.Spelling_Checker
;
46 File_Name
: File_Name_Type
;
47 -- Name of file for current unit, derived from unit name
49 Cur_Unum
: constant Unit_Number_Type
:= Current_Source_Unit
;
50 -- Unit number of unit that we just finished parsing. Note that we need
51 -- to capture this, because Source_Unit will change as we parse new
52 -- source files in the multiple main source file case.
54 Curunit
: constant Node_Id
:= Cunit
(Cur_Unum
);
55 -- Compilation unit node for current compilation unit
57 Loc
: Source_Ptr
:= Sloc
(Curunit
);
58 -- Source location for compilation unit node
60 Save_Style_Check
: Boolean;
61 Save_Style_Checks
: Style_Check_Options
;
62 -- Save style check so it can be restored later
64 Save_Validity_Check
: Boolean;
65 Save_Validity_Checks
: Validity_Check_Options
;
66 -- Save validity check so it can be restored later
69 -- Compilation unit node for withed unit
71 Context_Node
: Node_Id
;
72 -- Next node in context items list
77 Spec_Name
: Unit_Name_Type
;
78 -- Unit name of required spec
80 Body_Name
: Unit_Name_Type
;
81 -- Unit name of corresponding body
83 Unum
: Unit_Number_Type
;
84 -- Unit number of loaded unit
86 Limited_With_Found
: Boolean := False;
87 -- Set True if a limited WITH is found, used to ???
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
) then
129 Save_Style_Check_Options
(Save_Style_Checks
);
130 Save_Style_Check
:= Opt
.Style_Check
;
132 Save_Validity_Check_Options
(Save_Validity_Checks
);
133 Save_Validity_Check
:= Opt
.Validity_Checks_On
;
135 -- If main unit, set Main_Unit_Entity (this will get overwritten if
136 -- the main unit has a separate spec, that happens later on in Load)
138 if Cur_Unum
= Main_Unit
then
139 Main_Unit_Entity
:= Cunit_Entity
(Main_Unit
);
142 -- If we have no unit name, things are seriously messed up by previous
143 -- errors, and we should not try to continue compilation.
145 if Unit_Name
(Cur_Unum
) = No_Name
then
146 raise Unrecoverable_Error
;
149 -- Next step, make sure that the unit name matches the file name
150 -- and issue a warning message if not. We only output this for the
151 -- main unit, since for other units it is more serious and is
152 -- caught in a separate test below. We also inhibit the message in
153 -- multiple unit per file mode, because in this case the relation
154 -- between file name and unit name is broken.
158 (Unit_Name
(Cur_Unum
),
159 Subunit
=> Nkind
(Unit
(Cunit
(Cur_Unum
))) = N_Subunit
);
161 if Cur_Unum
= Main_Unit
162 and then Multiple_Unit_Index
= 0
163 and then File_Name
/= Unit_File_Name
(Cur_Unum
)
164 and then (File_Names_Case_Sensitive
165 or not Same_File_Name_Except_For_Case
166 (File_Name
, Unit_File_Name
(Cur_Unum
)))
168 Error_Msg_Name_1
:= File_Name
;
170 ("?file name does not match unit name, should be{", Sloc
(Curunit
));
173 -- For units other than the main unit, the expected unit name is set and
174 -- must be the same as the actual unit name, or we are in big trouble, and
175 -- abandon the compilation since there are situations where this really
176 -- gets us into bad trouble (e.g. some subunit situations).
178 if Cur_Unum
/= Main_Unit
179 and then Expected_Unit
(Cur_Unum
) /= Unit_Name
(Cur_Unum
)
181 Loc
:= Error_Location
(Cur_Unum
);
182 Error_Msg_Name_1
:= Unit_File_Name
(Cur_Unum
);
183 Get_Name_String
(Error_Msg_Name_1
);
185 -- Check for predefined file case
188 and then Name_Buffer
(2) = '-'
189 and then (Name_Buffer
(1) = 'a'
191 Name_Buffer
(1) = 's'
193 Name_Buffer
(1) = 'i'
195 Name_Buffer
(1) = 'g')
198 Expect_Name
: constant Name_Id
:= Expected_Unit
(Cur_Unum
);
199 Actual_Name
: constant Name_Id
:= Unit_Name
(Cur_Unum
);
202 Error_Msg_Name_1
:= Expect_Name
;
203 Error_Msg
("% is not a predefined library unit!", Loc
);
205 -- In the predefined file case, we know the user did not
206 -- construct their own package, but we got the wrong one.
207 -- This means that the name supplied by the user crunched
208 -- to something we recognized, but then the file did not
209 -- contain the unit expected. Most likely this is due to
210 -- a misspelling, e.g.
212 -- with Ada.Calender;
214 -- This crunches to a-calend, which indeed contains the unit
215 -- Ada.Calendar, and we can diagnose the misspelling. This
216 -- is a simple heuristic, but it catches many common cases
217 -- of misspelling of predefined unit names without needing
218 -- a full list of them.
220 -- Before actually issinying the message, we will check that the
221 -- unit name is indeed a plausible misspelling of the one we got.
223 if Is_Bad_Spelling_Of
224 (Found
=> Get_Name_String
(Expect_Name
),
225 Expect
=> Get_Name_String
(Actual_Name
))
227 Error_Msg_Name_1
:= Actual_Name
;
228 Error_Msg
("possible misspelling of %!", Loc
);
232 -- Non-predefined file name case. In this case we generate a message
233 -- and then we quit, because we are in big trouble, and if we try
234 -- to continue compilation, we get into some nasty situations
235 -- (for example in some subunit cases).
238 Error_Msg
("file { does not contain expected unit!", Loc
);
239 Error_Msg_Unit_1
:= Expected_Unit
(Cur_Unum
);
240 Error_Msg
("\\expected unit $!", Loc
);
241 Error_Msg_Unit_1
:= Unit_Name
(Cur_Unum
);
242 Error_Msg
("\\found unit $!", Loc
);
245 -- In both cases, remove the unit if it is the last unit (which it
246 -- normally (always?) will be) so that it is out of the way later.
248 Remove_Unit
(Cur_Unum
);
251 -- If current unit is a body, load its corresponding spec
253 if Nkind
(Unit
(Curunit
)) = N_Package_Body
254 or else Nkind
(Unit
(Curunit
)) = N_Subprogram_Body
256 Spec_Name
:= Get_Spec_Name
(Unit_Name
(Cur_Unum
));
259 (Load_Name
=> Spec_Name
,
262 Error_Node
=> Curunit
,
263 Corr_Body
=> Cur_Unum
);
265 -- If we successfully load the unit, then set the spec pointer. Once
266 -- again note that if the loaded unit has a fatal error, Load will
267 -- have set our Fatal_Error flag to propagate this condition.
269 if Unum
/= No_Unit
then
270 Set_Library_Unit
(Curunit
, Cunit
(Unum
));
272 -- If this is a separate spec for the main unit, then we reset
273 -- Main_Unit_Entity to point to the entity for this separate spec
275 if Cur_Unum
= Main_Unit
then
276 Main_Unit_Entity
:= Cunit_Entity
(Unum
);
279 -- If we don't find the spec, then if we have a subprogram body, we
280 -- are still OK, we just have a case of a body acting as its own spec
282 elsif Nkind
(Unit
(Curunit
)) = N_Subprogram_Body
then
283 Set_Acts_As_Spec
(Curunit
, True);
284 Set_Library_Unit
(Curunit
, Curunit
);
286 -- Otherwise we do have an error, repeat the load request for the spec
287 -- with Required set True to generate an appropriate error message.
292 (Load_Name
=> Spec_Name
,
295 Error_Node
=> Curunit
);
299 -- If current unit is a child unit spec, load its parent. If the child unit
300 -- is loaded through a limited with, the parent must be as well.
302 elsif Nkind
(Unit
(Curunit
)) = N_Package_Declaration
303 or else Nkind
(Unit
(Curunit
)) = N_Subprogram_Declaration
304 or else Nkind
(Unit
(Curunit
)) in N_Generic_Declaration
305 or else Nkind
(Unit
(Curunit
)) in N_Generic_Instantiation
306 or else Nkind
(Unit
(Curunit
)) in N_Renaming_Declaration
308 -- Turn style and validity checks off for parent unit
310 if not GNAT_Mode
then
311 Reset_Style_Check_Options
;
312 Reset_Validity_Check_Options
;
315 Spec_Name
:= Get_Parent_Spec_Name
(Unit_Name
(Cur_Unum
));
317 if Spec_Name
/= No_Name
then
320 (Load_Name
=> Spec_Name
,
323 Error_Node
=> Curunit
,
324 From_Limited_With
=> From_Limited_With
);
326 if Unum
/= No_Unit
then
327 Set_Parent_Spec
(Unit
(Curunit
), Cunit
(Unum
));
331 -- If current unit is a subunit, then load its parent body
333 elsif Nkind
(Unit
(Curunit
)) = N_Subunit
then
334 Body_Name
:= Get_Parent_Body_Name
(Unit_Name
(Cur_Unum
));
337 (Load_Name
=> Body_Name
,
340 Error_Node
=> Name
(Unit
(Curunit
)));
342 if Unum
/= No_Unit
then
343 Set_Library_Unit
(Curunit
, Cunit
(Unum
));
347 -- Now we load with'ed units, with style/validity checks turned off
349 if not GNAT_Mode
then
350 Reset_Style_Check_Options
;
351 Reset_Validity_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 From_Limited_With
=> From_Limited_With
394 Limited_Present
(Context_Node
));
396 -- If we find the unit, then set spec pointer in the N_With_Clause
397 -- to point to the compilation unit for the spec. Remember that
398 -- the Load routine itself sets our Fatal_Error flag if the loaded
399 -- unit gets a fatal error, so we don't need to worry about that.
401 if Unum
/= No_Unit
then
402 Set_Library_Unit
(With_Node
, Cunit
(Unum
));
404 -- If the spec isn't found, then try finding the corresponding
405 -- body, since it is possible that we have a subprogram body
406 -- that is acting as a spec (since no spec is present).
409 Body_Name
:= Get_Body_Name
(Spec_Name
);
412 (Load_Name
=> Body_Name
,
415 Error_Node
=> With_Node
,
418 -- If we got a subprogram body, then mark that we are using
419 -- the body as a spec in the file table, and set the spec
420 -- pointer in the N_With_Clause to point to the body entity.
423 and then Nkind
(Unit
(Cunit
(Unum
))) = N_Subprogram_Body
425 With_Cunit
:= Cunit
(Unum
);
426 Set_Library_Unit
(With_Node
, With_Cunit
);
427 Set_Acts_As_Spec
(With_Cunit
, True);
428 Set_Library_Unit
(With_Cunit
, With_Cunit
);
430 -- If we couldn't find the body, or if it wasn't a body spec
431 -- then we are in trouble. We make one more call to Load to
432 -- require the spec. We know it will fail of course, the
433 -- purpose is to generate the required error message (we prefer
434 -- that this message refer to the missing spec, not the body)
439 (Load_Name
=> Spec_Name
,
442 Error_Node
=> With_Node
,
445 -- Here we create a dummy package unit for the missing unit
447 Unum
:= Create_Dummy_Package_Unit
(With_Node
, Spec_Name
);
448 Set_Library_Unit
(With_Node
, Cunit
(Unum
));
456 exit when not Limited_With_Found
;
459 -- Restore style/validity check mode for main unit
461 Set_Style_Check_Options
(Save_Style_Checks
);
462 Opt
.Style_Check
:= Save_Style_Check
;
463 Set_Validity_Check_Options
(Save_Validity_Checks
);
464 Opt
.Validity_Checks_On
:= Save_Validity_Check
;