1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
28 -- The Par.Load procedure loads all units that are definitely required before
29 -- it makes any sense at all to proceed with semantic analysis, including
30 -- with'ed units, corresponding specs for bodies, parents of child specs,
31 -- and parents of subunits. All these units are loaded and pointers installed
32 -- in the tree as described in the spec of package Lib.
34 with Fname
; use Fname
;
35 with Fname
.UF
; use Fname
.UF
;
36 with Lib
.Load
; use Lib
.Load
;
37 with Uname
; use Uname
;
38 with Namet
; use Namet
;
39 with Casing
; use Casing
;
41 with Osint
; use Osint
;
42 with Sinput
.L
; use Sinput
.L
;
43 with Stylesw
; use Stylesw
;
44 with Validsw
; use Validsw
;
49 File_Name
: File_Name_Type
;
50 -- Name of file for current unit, derived from unit name
52 Cur_Unum
: Unit_Number_Type
:= Current_Source_Unit
;
53 -- Unit number of unit that we just finished parsing. Note that we need
54 -- to capture this, because Source_Unit will change as we parse new
55 -- source files in the multiple main source file case.
57 Curunit
: constant Node_Id
:= Cunit
(Cur_Unum
);
58 -- Compilation unit node for current compilation unit
60 Loc
: Source_Ptr
:= Sloc
(Curunit
);
61 -- Source location for compilation unit node
63 Save_Style_Check
: Boolean;
64 Save_Style_Checks
: Style_Check_Options
;
65 -- Save style check so it can be restored later
67 Save_Validity_Check
: Boolean;
68 Save_Validity_Checks
: Validity_Check_Options
;
69 -- Save validity check so it can be restored later
72 -- Compilation unit node for withed unit
74 Context_Node
: Node_Id
;
75 -- Next node in context items list
80 Spec_Name
: Unit_Name_Type
;
81 -- Unit name of required spec
83 Body_Name
: Unit_Name_Type
;
84 -- Unit name of corresponding body
86 Unum
: Unit_Number_Type
;
87 -- Unit number of loaded unit
89 function Same_File_Name_Except_For_Case
90 (Expected_File_Name
: File_Name_Type
;
91 Actual_File_Name
: File_Name_Type
)
93 -- Given an actual file name and an expected file name (the latter being
94 -- derived from the unit name), determine if they are the same except for
95 -- possibly different casing of letters.
97 function Same_File_Name_Except_For_Case
98 (Expected_File_Name
: File_Name_Type
;
99 Actual_File_Name
: File_Name_Type
)
103 Get_Name_String
(Actual_File_Name
);
104 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
107 Lower_Case_Actual_File_Name
: String (1 .. Name_Len
);
110 Lower_Case_Actual_File_Name
:= Name_Buffer
(1 .. Name_Len
);
111 Get_Name_String
(Expected_File_Name
);
112 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
113 return Lower_Case_Actual_File_Name
= Name_Buffer
(1 .. Name_Len
);
116 end Same_File_Name_Except_For_Case
;
118 -- Start of processing for Load
121 -- Don't do any loads if we already had a fatal error
123 if Fatal_Error
(Cur_Unum
) then
127 Save_Style_Check_Options
(Save_Style_Checks
);
128 Save_Style_Check
:= Opt
.Style_Check
;
130 Save_Validity_Check_Options
(Save_Validity_Checks
);
131 Save_Validity_Check
:= Opt
.Validity_Checks_On
;
133 -- If main unit, set Main_Unit_Entity (this will get overwritten if
134 -- the main unit has a separate spec, that happens later on in Load)
136 if Cur_Unum
= Main_Unit
then
137 Main_Unit_Entity
:= Cunit_Entity
(Main_Unit
);
140 -- If we have no unit name, things are seriously messed up by previous
141 -- errors, and we should not try to continue compilation.
143 if Unit_Name
(Cur_Unum
) = No_Name
then
144 raise Unrecoverable_Error
;
147 -- Next step, make sure that the unit name matches the file name
148 -- and issue a warning message if not. We only output this for the
149 -- main unit, since for other units it is more serious and is
150 -- caught in a separate test below.
154 (Unit_Name
(Cur_Unum
),
155 Subunit
=> Nkind
(Unit
(Cunit
(Cur_Unum
))) = N_Subunit
);
157 if Cur_Unum
= Main_Unit
158 and then File_Name
/= Unit_File_Name
(Cur_Unum
)
159 and then (File_Names_Case_Sensitive
160 or not Same_File_Name_Except_For_Case
161 (File_Name
, Unit_File_Name
(Cur_Unum
)))
163 Error_Msg_Name_1
:= File_Name
;
165 ("?file name does not match unit name, should be{", Sloc
(Curunit
));
168 -- For units other than the main unit, the expected unit name is set and
169 -- must be the same as the actual unit name, or we are in big trouble, and
170 -- abandon the compilation since there are situations where this really
171 -- gets us into bad trouble (e.g. some subunit situations).
173 if Cur_Unum
/= Main_Unit
174 and then Expected_Unit
(Cur_Unum
) /= Unit_Name
(Cur_Unum
)
176 Loc
:= Error_Location
(Cur_Unum
);
177 Error_Msg_Name_1
:= Unit_File_Name
(Cur_Unum
);
178 Get_Name_String
(Error_Msg_Name_1
);
180 -- Check for predefined file case
183 and then Name_Buffer
(2) = '-'
184 and then (Name_Buffer
(1) = 'a'
186 Name_Buffer
(1) = 's'
188 Name_Buffer
(1) = 'i'
190 Name_Buffer
(1) = 'g')
192 -- In the predefined file case, we know the user did not construct
193 -- their own package, but we got the wrong one. This means that the
194 -- name supplied by the user crunched to something we recognized,
195 -- but then the file did not contain the unit expected. Most likely
196 -- this is due to a misspelling, e.g.
198 -- with Ada.Calender;
200 -- This crunches to a-calend, which indeed contains the unit
201 -- Ada.Calendar, and we can diagnose the misspelling. This is
202 -- a simple heuristic, but it catches many common cases of
203 -- misspelling of predefined unit names without needing a full
206 Error_Msg_Name_1
:= Expected_Unit
(Cur_Unum
);
207 Error_Msg
("% is not a predefined library unit!", Loc
);
208 Error_Msg_Name_1
:= Unit_Name
(Cur_Unum
);
209 Error_Msg
("possible misspelling of %!", Loc
);
211 -- Non-predefined file name case
214 Error_Msg
("file { does not contain expected unit!", Loc
);
215 Error_Msg_Unit_1
:= Expected_Unit
(Cur_Unum
);
216 Error_Msg
("expected unit $!", Loc
);
217 Error_Msg_Unit_1
:= Unit_Name
(Cur_Unum
);
218 Error_Msg
("found unit $!", Loc
);
221 raise Unrecoverable_Error
;
224 -- If current unit is a body, load its corresponding spec
226 if Nkind
(Unit
(Curunit
)) = N_Package_Body
227 or else Nkind
(Unit
(Curunit
)) = N_Subprogram_Body
229 Spec_Name
:= Get_Spec_Name
(Unit_Name
(Cur_Unum
));
232 (Load_Name
=> Spec_Name
,
235 Error_Node
=> Curunit
,
236 Corr_Body
=> Cur_Unum
);
238 -- If we successfully load the unit, then set the spec pointer. Once
239 -- again note that if the loaded unit has a fatal error, Load will
240 -- have set our Fatal_Error flag to propagate this condition.
242 if Unum
/= No_Unit
then
243 Set_Library_Unit
(Curunit
, Cunit
(Unum
));
245 -- If this is a separate spec for the main unit, then we reset
246 -- Main_Unit_Entity to point to the entity for this separate spec
248 if Cur_Unum
= Main_Unit
then
249 Main_Unit_Entity
:= Cunit_Entity
(Unum
);
252 -- If we don't find the spec, then if we have a subprogram body, we
253 -- are still OK, we just have a case of a body acting as its own spec
255 elsif Nkind
(Unit
(Curunit
)) = N_Subprogram_Body
then
256 Set_Acts_As_Spec
(Curunit
, True);
257 Set_Library_Unit
(Curunit
, Curunit
);
259 -- Otherwise we do have an error, repeat the load request for the spec
260 -- with Required set True to generate an appropriate error message.
265 (Load_Name
=> Spec_Name
,
268 Error_Node
=> Curunit
);
272 -- If current unit is a child unit spec, load its parent
274 elsif Nkind
(Unit
(Curunit
)) = N_Package_Declaration
275 or else Nkind
(Unit
(Curunit
)) = N_Subprogram_Declaration
276 or else Nkind
(Unit
(Curunit
)) in N_Generic_Declaration
277 or else Nkind
(Unit
(Curunit
)) in N_Generic_Instantiation
278 or else Nkind
(Unit
(Curunit
)) in N_Renaming_Declaration
280 -- Turn style and validity checks off for parent unit
282 if not GNAT_Mode
then
283 Reset_Style_Check_Options
;
284 Reset_Validity_Check_Options
;
287 Spec_Name
:= Get_Parent_Spec_Name
(Unit_Name
(Cur_Unum
));
289 if Spec_Name
/= No_Name
then
292 (Load_Name
=> Spec_Name
,
295 Error_Node
=> Curunit
);
297 if Unum
/= No_Unit
then
298 Set_Parent_Spec
(Unit
(Curunit
), Cunit
(Unum
));
302 -- If current unit is a subunit, then load its parent body
304 elsif Nkind
(Unit
(Curunit
)) = N_Subunit
then
305 Body_Name
:= Get_Parent_Body_Name
(Unit_Name
(Cur_Unum
));
308 (Load_Name
=> Body_Name
,
311 Error_Node
=> Name
(Unit
(Curunit
)));
313 if Unum
/= No_Unit
then
314 Set_Library_Unit
(Curunit
, Cunit
(Unum
));
319 -- Now we load with'ed units, with style/validity checks turned off
321 if not GNAT_Mode
then
322 Reset_Style_Check_Options
;
323 Reset_Validity_Check_Options
;
326 -- Loop through context items
328 Context_Node
:= First
(Context_Items
(Curunit
));
329 while Present
(Context_Node
) loop
331 if Nkind
(Context_Node
) = N_With_Clause
then
332 With_Node
:= Context_Node
;
333 Spec_Name
:= Get_Unit_Name
(With_Node
);
337 (Load_Name
=> Spec_Name
,
340 Error_Node
=> With_Node
,
343 -- If we find the unit, then set spec pointer in the N_With_Clause
344 -- to point to the compilation unit for the spec. Remember that
345 -- the Load routine itself sets our Fatal_Error flag if the loaded
346 -- unit gets a fatal error, so we don't need to worry about that.
348 if Unum
/= No_Unit
then
349 Set_Library_Unit
(With_Node
, Cunit
(Unum
));
351 -- If the spec isn't found, then try finding the corresponding
352 -- body, since it is possible that we have a subprogram body
353 -- that is acting as a spec (since no spec is present).
356 Body_Name
:= Get_Body_Name
(Spec_Name
);
359 (Load_Name
=> Body_Name
,
362 Error_Node
=> With_Node
,
365 -- If we got a subprogram body, then mark that we are using
366 -- the body as a spec in the file table, and set the spec
367 -- pointer in the N_With_Clause to point to the body entity.
370 and then Nkind
(Unit
(Cunit
(Unum
))) = N_Subprogram_Body
372 With_Cunit
:= Cunit
(Unum
);
373 Set_Library_Unit
(With_Node
, With_Cunit
);
374 Set_Acts_As_Spec
(With_Cunit
, True);
375 Set_Library_Unit
(With_Cunit
, With_Cunit
);
377 -- If we couldn't find the body, or if it wasn't a body spec
378 -- then we are in trouble. We make one more call to Load to
379 -- require the spec. We know it will fail of course, the
380 -- purpose is to generate the required error message (we prefer
381 -- that this message refer to the missing spec, not the body)
386 (Load_Name
=> Spec_Name
,
389 Error_Node
=> With_Node
,
392 -- Here we create a dummy package unit for the missing unit
394 Unum
:= Create_Dummy_Package_Unit
(With_Node
, Spec_Name
);
395 Set_Library_Unit
(With_Node
, Cunit
(Unum
));
403 -- Restore style/validity check mode for main unit
405 Set_Style_Check_Options
(Save_Style_Checks
);
406 Opt
.Style_Check
:= Save_Style_Check
;
407 Set_Validity_Check_Options
(Save_Validity_Checks
);
408 Opt
.Validity_Checks_On
:= Save_Validity_Check
;