|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- P A R . L O A D --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
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. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
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.
|
|
|
31
|
|
|
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;
|
|
|
39 with Validsw; use Validsw;
|
|
|
40
|
|
|
41 with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
|
|
|
42
|
|
|
43 separate (Par)
|
|
|
44 procedure Load is
|
|
|
45
|
|
|
46 File_Name : File_Name_Type;
|
|
|
47 -- Name of file for current unit, derived from unit name
|
|
|
48
|
|
|
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.
|
|
|
53
|
|
|
54 Curunit : constant Node_Id := Cunit (Cur_Unum);
|
|
|
55 -- Compilation unit node for current compilation unit
|
|
|
56
|
|
|
57 Loc : Source_Ptr := Sloc (Curunit);
|
|
|
58 -- Source location for compilation unit node
|
|
|
59
|
|
|
60 Save_Style_Check : Boolean;
|
|
|
61 Save_Style_Checks : Style_Check_Options;
|
|
|
62 -- Save style check so it can be restored later
|
|
|
63
|
|
|
64 Save_Validity_Check : Boolean;
|
|
|
65 Save_Validity_Checks : Validity_Check_Options;
|
|
|
66 -- Save validity check so it can be restored later
|
|
|
67
|
|
|
68 With_Cunit : Node_Id;
|
|
|
69 -- Compilation unit node for withed unit
|
|
|
70
|
|
|
71 Context_Node : Node_Id;
|
|
|
72 -- Next node in context items list
|
|
|
73
|
|
|
74 With_Node : Node_Id;
|
|
|
75 -- N_With_Clause node
|
|
|
76
|
|
|
77 Spec_Name : Unit_Name_Type;
|
|
|
78 -- Unit name of required spec
|
|
|
79
|
|
|
80 Body_Name : Unit_Name_Type;
|
|
|
81 -- Unit name of corresponding body
|
|
|
82
|
|
|
83 Unum : Unit_Number_Type;
|
|
|
84 -- Unit number of loaded unit
|
|
|
85
|
|
|
86 Limited_With_Found : Boolean := False;
|
|
|
87 -- We load the context items in two rounds: the first round handles normal
|
|
|
88 -- withed units and the second round handles Ada 2005 limited-withed units.
|
|
|
89 -- This is required to allow the low-level circuitry that detects circular
|
|
|
90 -- dependencies of units the correct notification of errors (see comment
|
|
|
91 -- bellow). This variable is used to indicate that the second round is
|
|
|
92 -- required.
|
|
|
93
|
|
|
94 function Same_File_Name_Except_For_Case
|
|
|
95 (Expected_File_Name : File_Name_Type;
|
|
|
96 Actual_File_Name : File_Name_Type) return Boolean;
|
|
|
97 -- Given an actual file name and an expected file name (the latter being
|
|
|
98 -- derived from the unit name), determine if they are the same except for
|
|
|
99 -- possibly different casing of letters.
|
|
|
100
|
|
|
101 ------------------------------------
|
|
|
102 -- Same_File_Name_Except_For_Case --
|
|
|
103 ------------------------------------
|
|
|
104
|
|
|
105 function Same_File_Name_Except_For_Case
|
|
|
106 (Expected_File_Name : File_Name_Type;
|
|
|
107 Actual_File_Name : File_Name_Type) return Boolean
|
|
|
108 is
|
|
|
109 begin
|
|
|
110 Get_Name_String (Actual_File_Name);
|
|
|
111 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
|
|
112
|
|
|
113 declare
|
|
|
114 Lower_Case_Actual_File_Name : String (1 .. Name_Len);
|
|
|
115
|
|
|
116 begin
|
|
|
117 Lower_Case_Actual_File_Name := Name_Buffer (1 .. Name_Len);
|
|
|
118 Get_Name_String (Expected_File_Name);
|
|
|
119 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
|
|
120 return Lower_Case_Actual_File_Name = Name_Buffer (1 .. Name_Len);
|
|
|
121 end;
|
|
|
122
|
|
|
123 end Same_File_Name_Except_For_Case;
|
|
|
124
|
|
|
125 -- Start of processing for Load
|
|
|
126
|
|
|
127 begin
|
|
|
128 -- Don't do any loads if we already had a fatal error
|
|
|
129
|
|
|
130 if Fatal_Error (Cur_Unum) = Error_Detected then
|
|
|
131 return;
|
|
|
132 end if;
|
|
|
133
|
|
|
134 Save_Style_Check_Options (Save_Style_Checks);
|
|
|
135 Save_Style_Check := Opt.Style_Check;
|
|
|
136
|
|
|
137 Save_Validity_Check_Options (Save_Validity_Checks);
|
|
|
138 Save_Validity_Check := Opt.Validity_Checks_On;
|
|
|
139
|
|
|
140 -- If main unit, set Main_Unit_Entity (this will get overwritten if
|
|
|
141 -- the main unit has a separate spec, that happens later on in Load)
|
|
|
142
|
|
|
143 if Cur_Unum = Main_Unit then
|
|
|
144 Main_Unit_Entity := Cunit_Entity (Main_Unit);
|
|
|
145 end if;
|
|
|
146
|
|
|
147 -- If we have no unit name, things are seriously messed up by previous
|
|
|
148 -- errors, and we should not try to continue compilation.
|
|
|
149
|
|
|
150 if Unit_Name (Cur_Unum) = No_Unit_Name then
|
|
|
151 raise Unrecoverable_Error;
|
|
|
152 end if;
|
|
|
153
|
|
|
154 -- Next step, make sure that the unit name matches the file name
|
|
|
155 -- and issue a warning message if not. We only output this for the
|
|
|
156 -- main unit, since for other units it is more serious and is
|
|
|
157 -- caught in a separate test below. We also inhibit the message in
|
|
|
158 -- multiple unit per file mode, because in this case the relation
|
|
|
159 -- between file name and unit name is broken.
|
|
|
160
|
|
|
161 File_Name :=
|
|
|
162 Get_File_Name
|
|
|
163 (Unit_Name (Cur_Unum),
|
|
|
164 Subunit => Nkind (Unit (Cunit (Cur_Unum))) = N_Subunit);
|
|
|
165
|
|
|
166 if Cur_Unum = Main_Unit
|
|
|
167 and then Multiple_Unit_Index = 0
|
|
|
168 and then File_Name /= Unit_File_Name (Cur_Unum)
|
|
|
169 and then (File_Names_Case_Sensitive
|
|
|
170 or not Same_File_Name_Except_For_Case
|
|
|
171 (File_Name, Unit_File_Name (Cur_Unum)))
|
|
|
172 then
|
|
|
173 Error_Msg_File_1 := File_Name;
|
|
|
174 Error_Msg
|
|
|
175 ("??file name does not match unit name, should be{", Sloc (Curunit));
|
|
|
176 end if;
|
|
|
177
|
|
|
178 -- For units other than the main unit, the expected unit name is set and
|
|
|
179 -- must be the same as the actual unit name, or we are in big trouble, and
|
|
|
180 -- abandon the compilation since there are situations where this really
|
|
|
181 -- gets us into bad trouble (e.g. some subunit situations).
|
|
|
182
|
|
|
183 if Cur_Unum /= Main_Unit
|
|
|
184 and then Expected_Unit (Cur_Unum) /= Unit_Name (Cur_Unum)
|
|
|
185 then
|
|
|
186 Loc := Error_Location (Cur_Unum);
|
|
|
187 Error_Msg_File_1 := Unit_File_Name (Cur_Unum);
|
|
|
188 Get_Name_String (Error_Msg_File_1);
|
|
|
189
|
|
|
190 -- Check for predefined file case
|
|
|
191
|
|
|
192 if Name_Len > 1
|
|
|
193 and then Name_Buffer (2) = '-'
|
|
|
194 and then (Name_Buffer (1) = 'a'
|
|
|
195 or else
|
|
|
196 Name_Buffer (1) = 's'
|
|
|
197 or else
|
|
|
198 Name_Buffer (1) = 'i'
|
|
|
199 or else
|
|
|
200 Name_Buffer (1) = 'g')
|
|
|
201 then
|
|
|
202 declare
|
|
|
203 Expect_Name : constant Unit_Name_Type := Expected_Unit (Cur_Unum);
|
|
|
204 Actual_Name : constant Unit_Name_Type := Unit_Name (Cur_Unum);
|
|
|
205
|
|
|
206 begin
|
|
|
207 Error_Msg_Unit_1 := Expect_Name;
|
|
|
208 Error_Msg -- CODEFIX
|
|
|
209 ("$$ is not a predefined library unit!", Loc);
|
|
|
210
|
|
|
211 -- In the predefined file case, we know the user did not
|
|
|
212 -- construct their own package, but we got the wrong one.
|
|
|
213 -- This means that the name supplied by the user crunched
|
|
|
214 -- to something we recognized, but then the file did not
|
|
|
215 -- contain the unit expected. Most likely this is due to
|
|
|
216 -- a misspelling, e.g.
|
|
|
217
|
|
|
218 -- with Ada.Calender;
|
|
|
219
|
|
|
220 -- This crunches to a-calend, which indeed contains the unit
|
|
|
221 -- Ada.Calendar, and we can diagnose the misspelling. This
|
|
|
222 -- is a simple heuristic, but it catches many common cases
|
|
|
223 -- of misspelling of predefined unit names without needing
|
|
|
224 -- a full list of them.
|
|
|
225
|
|
|
226 -- Before actually issuing the message, we will check that the
|
|
|
227 -- unit name is indeed a plausible misspelling of the one we got.
|
|
|
228
|
|
|
229 if Is_Bad_Spelling_Of
|
|
|
230 (Name_Id (Expect_Name), Name_Id (Actual_Name))
|
|
|
231 then
|
|
|
232 Error_Msg_Unit_1 := Actual_Name;
|
|
|
233 Error_Msg -- CODEFIX
|
|
|
234 ("possible misspelling of $$!", Loc);
|
|
|
235 end if;
|
|
|
236 end;
|
|
|
237
|
|
|
238 -- Non-predefined file name case. In this case we generate a message
|
|
|
239 -- and then we quit, because we are in big trouble, and if we try
|
|
|
240 -- to continue compilation, we get into some nasty situations
|
|
|
241 -- (for example in some subunit cases).
|
|
|
242
|
|
|
243 else
|
|
|
244 Error_Msg ("file { does not contain expected unit!", Loc);
|
|
|
245 Error_Msg_Unit_1 := Expected_Unit (Cur_Unum);
|
|
|
246 Error_Msg ("\\expected unit $!", Loc);
|
|
|
247 Error_Msg_Unit_1 := Unit_Name (Cur_Unum);
|
|
|
248 Error_Msg ("\\found unit $!", Loc);
|
|
|
249 end if;
|
|
|
250
|
|
|
251 -- In both cases, remove the unit if it is the last unit (which it
|
|
|
252 -- normally (always?) will be) so that it is out of the way later.
|
|
|
253
|
|
|
254 Remove_Unit (Cur_Unum);
|
|
|
255 end if;
|
|
|
256
|
|
|
257 -- If current unit is a body, load its corresponding spec
|
|
|
258
|
|
|
259 if Nkind (Unit (Curunit)) = N_Package_Body
|
|
|
260 or else Nkind (Unit (Curunit)) = N_Subprogram_Body
|
|
|
261 then
|
|
|
262 Spec_Name := Get_Spec_Name (Unit_Name (Cur_Unum));
|
|
|
263 Unum :=
|
|
|
264 Load_Unit
|
|
|
265 (Load_Name => Spec_Name,
|
|
|
266 Required => False,
|
|
|
267 Subunit => False,
|
|
|
268 Error_Node => Curunit,
|
|
|
269 Corr_Body => Cur_Unum,
|
|
|
270 PMES => (Cur_Unum = Main_Unit));
|
|
|
271
|
|
|
272 -- If we successfully load the unit, then set the spec/body pointers.
|
|
|
273 -- Once again note that if the loaded unit has a fatal error, Load will
|
|
|
274 -- have set our Fatal_Error flag to propagate this condition.
|
|
|
275
|
|
|
276 if Unum /= No_Unit then
|
|
|
277 Set_Library_Unit (Curunit, Cunit (Unum));
|
|
|
278 Set_Library_Unit (Cunit (Unum), Curunit);
|
|
|
279
|
|
|
280 -- If this is a separate spec for the main unit, then we reset
|
|
|
281 -- Main_Unit_Entity to point to the entity for this separate spec
|
|
|
282 -- and this is also where we generate the SCO's for this spec.
|
|
|
283
|
|
|
284 if Cur_Unum = Main_Unit then
|
|
|
285 Main_Unit_Entity := Cunit_Entity (Unum);
|
|
|
286
|
|
|
287 if Generate_SCO then
|
|
|
288 SCO_Record_Raw (Unum);
|
|
|
289 end if;
|
|
|
290 end if;
|
|
|
291
|
|
|
292 -- If we don't find the spec, then if we have a subprogram body, we
|
|
|
293 -- are still OK, we just have a case of a body acting as its own spec
|
|
|
294
|
|
|
295 elsif Nkind (Unit (Curunit)) = N_Subprogram_Body then
|
|
|
296 Set_Acts_As_Spec (Curunit, True);
|
|
|
297 Set_Library_Unit (Curunit, Curunit);
|
|
|
298
|
|
|
299 -- Otherwise we do have an error, repeat the load request for the spec
|
|
|
300 -- with Required set True to generate an appropriate error message.
|
|
|
301
|
|
|
302 else
|
|
|
303 Unum :=
|
|
|
304 Load_Unit
|
|
|
305 (Load_Name => Spec_Name,
|
|
|
306 Required => True,
|
|
|
307 Subunit => False,
|
|
|
308 Error_Node => Curunit);
|
|
|
309 return;
|
|
|
310 end if;
|
|
|
311
|
|
|
312 -- If current unit is a child unit spec, load its parent. If the child unit
|
|
|
313 -- is loaded through a limited with, the parent must be as well.
|
|
|
314
|
|
|
315 elsif Nkind (Unit (Curunit)) = N_Package_Declaration
|
|
|
316 or else Nkind (Unit (Curunit)) = N_Subprogram_Declaration
|
|
|
317 or else Nkind (Unit (Curunit)) in N_Generic_Declaration
|
|
|
318 or else Nkind (Unit (Curunit)) in N_Generic_Instantiation
|
|
|
319 or else Nkind (Unit (Curunit)) in N_Renaming_Declaration
|
|
|
320 then
|
|
|
321 -- Turn style and validity checks off for parent unit
|
|
|
322
|
|
|
323 if not GNAT_Mode then
|
|
|
324 Reset_Style_Check_Options;
|
|
|
325 Reset_Validity_Check_Options;
|
|
|
326 end if;
|
|
|
327
|
|
|
328 Spec_Name := Get_Parent_Spec_Name (Unit_Name (Cur_Unum));
|
|
|
329
|
|
|
330 if Spec_Name /= No_Unit_Name then
|
|
|
331 Unum :=
|
|
|
332 Load_Unit
|
|
|
333 (Load_Name => Spec_Name,
|
|
|
334 Required => True,
|
|
|
335 Subunit => False,
|
|
|
336 Error_Node => Curunit);
|
|
|
337
|
|
|
338 if Unum /= No_Unit then
|
|
|
339 Set_Parent_Spec (Unit (Curunit), Cunit (Unum));
|
|
|
340 end if;
|
|
|
341 end if;
|
|
|
342
|
|
|
343 -- If current unit is a subunit, then load its parent body
|
|
|
344
|
|
|
345 elsif Nkind (Unit (Curunit)) = N_Subunit then
|
|
|
346 Body_Name := Get_Parent_Body_Name (Unit_Name (Cur_Unum));
|
|
|
347 Unum :=
|
|
|
348 Load_Unit
|
|
|
349 (Load_Name => Body_Name,
|
|
|
350 Required => True,
|
|
|
351 Subunit => False,
|
|
|
352 Error_Node => Name (Unit (Curunit)));
|
|
|
353
|
|
|
354 if Unum /= No_Unit then
|
|
|
355 Set_Library_Unit (Curunit, Cunit (Unum));
|
|
|
356 end if;
|
|
|
357 end if;
|
|
|
358
|
|
|
359 -- Now we load with'ed units, with style/validity checks turned off
|
|
|
360
|
|
|
361 if not GNAT_Mode then
|
|
|
362 Reset_Style_Check_Options;
|
|
|
363 Reset_Validity_Check_Options;
|
|
|
364 end if;
|
|
|
365
|
|
|
366 -- Load the context items in two rounds: the first round handles normal
|
|
|
367 -- withed units and the second round handles Ada 2005 limited-withed units.
|
|
|
368 -- This is required to allow the low-level circuitry that detects circular
|
|
|
369 -- dependencies of units the correct notification of the following error:
|
|
|
370
|
|
|
371 -- limited with D;
|
|
|
372 -- with D; with C;
|
|
|
373 -- package C is ... package D is ...
|
|
|
374
|
|
|
375 for Round in 1 .. 2 loop
|
|
|
376 Context_Node := First (Context_Items (Curunit));
|
|
|
377 while Present (Context_Node) loop
|
|
|
378
|
|
|
379 -- During the first round we check if there is some limited-with
|
|
|
380 -- context clause; otherwise the second round will be skipped
|
|
|
381
|
|
|
382 if Nkind (Context_Node) = N_With_Clause
|
|
|
383 and then Round = 1
|
|
|
384 and then Limited_Present (Context_Node)
|
|
|
385 then
|
|
|
386 Limited_With_Found := True;
|
|
|
387 end if;
|
|
|
388
|
|
|
389 if Nkind (Context_Node) = N_With_Clause
|
|
|
390 and then ((Round = 1 and then not Limited_Present (Context_Node))
|
|
|
391 or else
|
|
|
392 (Round = 2 and then Limited_Present (Context_Node)))
|
|
|
393 then
|
|
|
394 With_Node := Context_Node;
|
|
|
395 Spec_Name := Get_Unit_Name (With_Node);
|
|
|
396
|
|
|
397 Unum :=
|
|
|
398 Load_Unit
|
|
|
399 (Load_Name => Spec_Name,
|
|
|
400 Required => False,
|
|
|
401 Subunit => False,
|
|
|
402 Error_Node => With_Node,
|
|
|
403 Renamings => True,
|
|
|
404 With_Node => Context_Node);
|
|
|
405
|
|
|
406 -- If we find the unit, then set spec pointer in the N_With_Clause
|
|
|
407 -- to point to the compilation unit for the spec. Remember that
|
|
|
408 -- the Load routine itself sets our Fatal_Error flag if the loaded
|
|
|
409 -- unit gets a fatal error, so we don't need to worry about that.
|
|
|
410
|
|
|
411 if Unum /= No_Unit then
|
|
|
412 Set_Library_Unit (With_Node, Cunit (Unum));
|
|
|
413
|
|
|
414 -- If the spec isn't found, then try finding the corresponding
|
|
|
415 -- body, since it is possible that we have a subprogram body
|
|
|
416 -- that is acting as a spec (since no spec is present).
|
|
|
417
|
|
|
418 else
|
|
|
419 Body_Name := Get_Body_Name (Spec_Name);
|
|
|
420 Unum :=
|
|
|
421 Load_Unit
|
|
|
422 (Load_Name => Body_Name,
|
|
|
423 Required => False,
|
|
|
424 Subunit => False,
|
|
|
425 Error_Node => With_Node,
|
|
|
426 Renamings => True);
|
|
|
427
|
|
|
428 -- If we got a subprogram body, then mark that we are using
|
|
|
429 -- the body as a spec in the file table, and set the spec
|
|
|
430 -- pointer in the N_With_Clause to point to the body entity.
|
|
|
431
|
|
|
432 if Unum /= No_Unit
|
|
|
433 and then Nkind (Unit (Cunit (Unum))) = N_Subprogram_Body
|
|
|
434 then
|
|
|
435 With_Cunit := Cunit (Unum);
|
|
|
436 Set_Library_Unit (With_Node, With_Cunit);
|
|
|
437 Set_Acts_As_Spec (With_Cunit, True);
|
|
|
438 Set_Library_Unit (With_Cunit, With_Cunit);
|
|
|
439
|
|
|
440 -- If we couldn't find the body, or if it wasn't a body spec
|
|
|
441 -- then we are in trouble. We make one more call to Load to
|
|
|
442 -- require the spec. We know it will fail of course, the
|
|
|
443 -- purpose is to generate the required error message (we prefer
|
|
|
444 -- that this message refer to the missing spec, not the body)
|
|
|
445
|
|
|
446 else
|
|
|
447 Unum :=
|
|
|
448 Load_Unit
|
|
|
449 (Load_Name => Spec_Name,
|
|
|
450 Required => True,
|
|
|
451 Subunit => False,
|
|
|
452 Error_Node => With_Node,
|
|
|
453 Renamings => True);
|
|
|
454
|
|
|
455 -- Here we create a dummy package unit for the missing unit
|
|
|
456
|
|
|
457 Unum := Create_Dummy_Package_Unit (With_Node, Spec_Name);
|
|
|
458 Set_Library_Unit (With_Node, Cunit (Unum));
|
|
|
459 end if;
|
|
|
460 end if;
|
|
|
461 end if;
|
|
|
462
|
|
|
463 Next (Context_Node);
|
|
|
464 end loop;
|
|
|
465
|
|
|
466 exit when not Limited_With_Found;
|
|
|
467 end loop;
|
|
|
468
|
|
|
469 -- Restore style/validity check mode for main unit
|
|
|
470
|
|
|
471 Set_Style_Check_Options (Save_Style_Checks);
|
|
|
472 Opt.Style_Check := Save_Style_Check;
|
|
|
473 Set_Validity_Check_Options (Save_Validity_Checks);
|
|
|
474 Opt.Validity_Checks_On := Save_Validity_Check;
|
|
|
475 end Load;
|
