]>
Commit | Line | Data |
---|---|---|
38cbfe40 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- L I B . L O A D -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
0712790c | 9 | -- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- |
38cbfe40 RK |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
38cbfe40 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
38cbfe40 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
38cbfe40 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | with Atree; use Atree; | |
27 | with Debug; use Debug; | |
fbf5a39b | 28 | with Einfo; use Einfo; |
38cbfe40 RK |
29 | with Errout; use Errout; |
30 | with Fname; use Fname; | |
31 | with Fname.UF; use Fname.UF; | |
38cbfe40 RK |
32 | with Nlists; use Nlists; |
33 | with Nmake; use Nmake; | |
34 | with Opt; use Opt; | |
35 | with Osint; use Osint; | |
07fc65c4 | 36 | with Osint.C; use Osint.C; |
38cbfe40 RK |
37 | with Output; use Output; |
38 | with Par; | |
e9437007 | 39 | with Restrict; use Restrict; |
38cbfe40 RK |
40 | with Scn; use Scn; |
41 | with Sinfo; use Sinfo; | |
42 | with Sinput; use Sinput; | |
43 | with Sinput.L; use Sinput.L; | |
fbf5a39b | 44 | with Stand; use Stand; |
38cbfe40 RK |
45 | with Tbuild; use Tbuild; |
46 | with Uname; use Uname; | |
47 | ||
48 | package body Lib.Load is | |
49 | ||
50 | ----------------------- | |
51 | -- Local Subprograms -- | |
52 | ----------------------- | |
53 | ||
33c423c8 | 54 | function From_Limited_With_Chain return Boolean; |
2f1b20a9 ES |
55 | -- Check whether a possible circular dependence includes units that |
56 | -- have been loaded through limited_with clauses, in which case there | |
57 | -- is no real circularity. | |
58 | ||
38cbfe40 RK |
59 | function Spec_Is_Irrelevant |
60 | (Spec_Unit : Unit_Number_Type; | |
2e071734 | 61 | Body_Unit : Unit_Number_Type) return Boolean; |
38cbfe40 RK |
62 | -- The Spec_Unit and Body_Unit parameters are the unit numbers of the |
63 | -- spec file that corresponds to the main unit which is a body. This | |
64 | -- function determines if the spec file is irrelevant and will be | |
65 | -- overridden by the body as described in RM 10.1.4(4). See description | |
66 | -- in "Special Handling of Subprogram Bodies" for further details. | |
67 | ||
68 | procedure Write_Dependency_Chain; | |
69 | -- This procedure is used to generate error message info lines that | |
70 | -- trace the current dependency chain when a load error occurs. | |
71 | ||
0712790c ES |
72 | ------------------------------ |
73 | -- Change_Main_Unit_To_Spec -- | |
74 | ------------------------------ | |
75 | ||
76 | procedure Change_Main_Unit_To_Spec is | |
77 | U : Unit_Record renames Units.Table (Main_Unit); | |
78 | N : File_Name_Type; | |
79 | X : Source_File_Index; | |
80 | ||
81 | begin | |
82 | -- Get name of unit body | |
83 | ||
84 | Get_Name_String (U.Unit_File_Name); | |
85 | ||
86 | -- Note: for the following we should really generalize and consult the | |
87 | -- file name pattern data, but for now we just deal with the common | |
88 | -- naming cases, which is probably good enough in practice ??? | |
89 | ||
90 | -- Change .adb to .ads | |
91 | ||
92 | if Name_Len >= 5 | |
93 | and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" | |
94 | then | |
95 | Name_Buffer (Name_Len) := 's'; | |
96 | ||
97 | -- Change .2.ada to .1.ada (Rational convention) | |
98 | ||
99 | elsif Name_Len >= 7 | |
100 | and then Name_Buffer (Name_Len - 5 .. Name_Len) = ".2.ada" | |
101 | then | |
102 | Name_Buffer (Name_Len - 4) := '1'; | |
103 | ||
104 | -- Change .ada to _.ada (DEC convention) | |
105 | ||
106 | elsif Name_Len >= 5 | |
107 | and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".ada" | |
108 | then | |
109 | Name_Buffer (Name_Len - 3 .. Name_Len + 1) := "_.ada"; | |
110 | Name_Len := Name_Len + 1; | |
111 | ||
112 | -- No match, don't make the change | |
113 | ||
114 | else | |
115 | return; | |
116 | end if; | |
117 | ||
118 | -- Try loading the spec | |
119 | ||
120 | N := Name_Find; | |
121 | X := Load_Source_File (N); | |
122 | ||
123 | -- No change if we did not find the spec | |
124 | ||
125 | if X = No_Source_File then | |
126 | return; | |
127 | end if; | |
128 | ||
129 | -- Otherwise modify Main_Unit entry to point to spec | |
130 | ||
131 | U.Unit_File_Name := N; | |
132 | U.Source_Index := X; | |
133 | end Change_Main_Unit_To_Spec; | |
134 | ||
38cbfe40 RK |
135 | ------------------------------- |
136 | -- Create_Dummy_Package_Unit -- | |
137 | ------------------------------- | |
138 | ||
139 | function Create_Dummy_Package_Unit | |
140 | (With_Node : Node_Id; | |
2e071734 | 141 | Spec_Name : Unit_Name_Type) return Unit_Number_Type |
38cbfe40 RK |
142 | is |
143 | Unum : Unit_Number_Type; | |
144 | Cunit_Entity : Entity_Id; | |
145 | Cunit : Node_Id; | |
146 | Du_Name : Node_Or_Entity_Id; | |
147 | End_Lab : Node_Id; | |
148 | Save_CS : constant Boolean := Get_Comes_From_Source_Default; | |
149 | ||
150 | begin | |
151 | -- The created dummy package unit does not come from source | |
152 | ||
153 | Set_Comes_From_Source_Default (False); | |
154 | ||
155 | -- Normal package | |
156 | ||
157 | if Nkind (Name (With_Node)) = N_Identifier then | |
158 | Cunit_Entity := | |
159 | Make_Defining_Identifier (No_Location, | |
160 | Chars => Chars (Name (With_Node))); | |
161 | Du_Name := Cunit_Entity; | |
162 | End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location); | |
163 | ||
164 | -- Child package | |
165 | ||
9596236a | 166 | else |
38cbfe40 RK |
167 | Cunit_Entity := |
168 | Make_Defining_Identifier (No_Location, | |
169 | Chars => Chars (Selector_Name (Name (With_Node)))); | |
170 | Du_Name := | |
171 | Make_Defining_Program_Unit_Name (No_Location, | |
172 | Name => New_Copy_Tree (Prefix (Name (With_Node))), | |
173 | Defining_Identifier => Cunit_Entity); | |
fbf5a39b AC |
174 | |
175 | Set_Is_Child_Unit (Cunit_Entity); | |
176 | ||
38cbfe40 RK |
177 | End_Lab := |
178 | Make_Designator (No_Location, | |
179 | Name => New_Copy_Tree (Prefix (Name (With_Node))), | |
180 | Identifier => New_Occurrence_Of (Cunit_Entity, No_Location)); | |
181 | end if; | |
182 | ||
9596236a | 183 | Set_Scope (Cunit_Entity, Standard_Standard); |
fbf5a39b | 184 | |
38cbfe40 RK |
185 | Cunit := |
186 | Make_Compilation_Unit (No_Location, | |
187 | Context_Items => Empty_List, | |
188 | Unit => | |
189 | Make_Package_Declaration (No_Location, | |
190 | Specification => | |
191 | Make_Package_Specification (No_Location, | |
192 | Defining_Unit_Name => Du_Name, | |
193 | Visible_Declarations => Empty_List, | |
194 | End_Label => End_Lab)), | |
195 | Aux_Decls_Node => | |
196 | Make_Compilation_Unit_Aux (No_Location)); | |
197 | ||
fbf5a39b AC |
198 | -- Mark the dummy package as analyzed to prevent analysis of this |
199 | -- (non-existent) unit in -gnatQ mode because at the moment the | |
200 | -- structure and attributes of this dummy package does not allow | |
201 | -- a normal analysis of this unit | |
202 | ||
203 | Set_Analyzed (Cunit); | |
204 | ||
38cbfe40 RK |
205 | Units.Increment_Last; |
206 | Unum := Units.Last; | |
207 | ||
208 | Units.Table (Unum) := ( | |
209 | Cunit => Cunit, | |
210 | Cunit_Entity => Cunit_Entity, | |
211 | Dependency_Num => 0, | |
38cbfe40 RK |
212 | Dynamic_Elab => False, |
213 | Error_Location => Sloc (With_Node), | |
214 | Expected_Unit => Spec_Name, | |
215 | Fatal_Error => True, | |
216 | Generate_Code => False, | |
217 | Has_RACW => False, | |
218 | Ident_String => Empty, | |
219 | Loading => False, | |
220 | Main_Priority => Default_Main_Priority, | |
2820d220 | 221 | Munit_Index => 0, |
38cbfe40 RK |
222 | Serial_Number => 0, |
223 | Source_Index => No_Source_File, | |
224 | Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False), | |
225 | Unit_Name => Spec_Name, | |
226 | Version => 0); | |
227 | ||
228 | Set_Comes_From_Source_Default (Save_CS); | |
229 | Set_Error_Posted (Cunit_Entity); | |
230 | Set_Error_Posted (Cunit); | |
231 | return Unum; | |
232 | end Create_Dummy_Package_Unit; | |
233 | ||
2f1b20a9 ES |
234 | ----------------------------- |
235 | -- From_Limited_With_Chain -- | |
236 | ----------------------------- | |
237 | ||
33c423c8 AC |
238 | function From_Limited_With_Chain return Boolean is |
239 | Curr_Num : constant Unit_Number_Type := | |
240 | Load_Stack.Table (Load_Stack.Last).Unit_Number; | |
241 | ||
2f1b20a9 ES |
242 | begin |
243 | -- True if the current load operation is through a limited_with clause | |
33c423c8 | 244 | -- and we are not within a loop of regular with_clauses. |
2f1b20a9 | 245 | |
33c423c8 AC |
246 | for U in reverse Load_Stack.First .. Load_Stack.Last - 1 loop |
247 | if Load_Stack.Table (U).Unit_Number = Curr_Num then | |
248 | return False; | |
2f1b20a9 | 249 | |
33c423c8 AC |
250 | elsif Present (Load_Stack.Table (U).With_Node) |
251 | and then Limited_Present (Load_Stack.Table (U).With_Node) | |
252 | then | |
253 | return True; | |
254 | end if; | |
255 | end loop; | |
2f1b20a9 ES |
256 | |
257 | return False; | |
258 | end From_Limited_With_Chain; | |
259 | ||
38cbfe40 RK |
260 | ---------------- |
261 | -- Initialize -- | |
262 | ---------------- | |
263 | ||
264 | procedure Initialize is | |
38cbfe40 RK |
265 | begin |
266 | Units.Init; | |
267 | Load_Stack.Init; | |
fbf5a39b AC |
268 | end Initialize; |
269 | ||
270 | ------------------------ | |
271 | -- Initialize_Version -- | |
272 | ------------------------ | |
273 | ||
274 | procedure Initialize_Version (U : Unit_Number_Type) is | |
275 | begin | |
276 | Units.Table (U).Version := Source_Checksum (Source_Index (U)); | |
277 | end Initialize_Version; | |
278 | ||
279 | ---------------------- | |
280 | -- Load_Main_Source -- | |
281 | ---------------------- | |
282 | ||
283 | procedure Load_Main_Source is | |
0712790c ES |
284 | Fname : File_Name_Type; |
285 | Version : Word := 0; | |
fbf5a39b AC |
286 | |
287 | begin | |
38cbfe40 | 288 | Load_Stack.Increment_Last; |
33c423c8 | 289 | Load_Stack.Table (Load_Stack.Last) := (Main_Unit, Empty); |
38cbfe40 RK |
290 | |
291 | -- Initialize unit table entry for Main_Unit. Note that we don't know | |
292 | -- the unit name yet, that gets filled in when the parser parses the | |
293 | -- main unit, at which time a check is made that it matches the main | |
294 | -- file name, and then the Unit_Name field is set. The Cunit and | |
295 | -- Cunit_Entity fields also get filled in later by the parser. | |
296 | ||
297 | Units.Increment_Last; | |
298 | Fname := Next_Main_Source; | |
299 | ||
300 | Units.Table (Main_Unit).Unit_File_Name := Fname; | |
301 | ||
302 | if Fname /= No_File then | |
38cbfe40 RK |
303 | Main_Source_File := Load_Source_File (Fname); |
304 | Current_Error_Source_File := Main_Source_File; | |
305 | ||
0712790c ES |
306 | if Main_Source_File /= No_Source_File then |
307 | Version := Source_Checksum (Main_Source_File); | |
308 | end if; | |
309 | ||
38cbfe40 RK |
310 | Units.Table (Main_Unit) := ( |
311 | Cunit => Empty, | |
312 | Cunit_Entity => Empty, | |
313 | Dependency_Num => 0, | |
38cbfe40 RK |
314 | Dynamic_Elab => False, |
315 | Error_Location => No_Location, | |
0712790c | 316 | Expected_Unit => No_Unit_Name, |
38cbfe40 RK |
317 | Fatal_Error => False, |
318 | Generate_Code => False, | |
319 | Has_RACW => False, | |
38cbfe40 | 320 | Ident_String => Empty, |
2820d220 | 321 | Loading => True, |
38cbfe40 | 322 | Main_Priority => Default_Main_Priority, |
2820d220 | 323 | Munit_Index => 0, |
38cbfe40 RK |
324 | Serial_Number => 0, |
325 | Source_Index => Main_Source_File, | |
326 | Unit_File_Name => Fname, | |
0712790c ES |
327 | Unit_Name => No_Unit_Name, |
328 | Version => Version); | |
38cbfe40 | 329 | end if; |
fbf5a39b | 330 | end Load_Main_Source; |
38cbfe40 RK |
331 | |
332 | --------------- | |
333 | -- Load_Unit -- | |
334 | --------------- | |
335 | ||
336 | function Load_Unit | |
e9437007 JM |
337 | (Load_Name : Unit_Name_Type; |
338 | Required : Boolean; | |
339 | Error_Node : Node_Id; | |
340 | Subunit : Boolean; | |
341 | Corr_Body : Unit_Number_Type := No_Unit; | |
342 | Renamings : Boolean := False; | |
33c423c8 | 343 | With_Node : Node_Id := Empty) return Unit_Number_Type |
38cbfe40 RK |
344 | is |
345 | Calling_Unit : Unit_Number_Type; | |
346 | Uname_Actual : Unit_Name_Type; | |
347 | Unum : Unit_Number_Type; | |
348 | Unump : Unit_Number_Type; | |
349 | Fname : File_Name_Type; | |
350 | Src_Ind : Source_File_Index; | |
38cbfe40 | 351 | |
38cbfe40 RK |
352 | -- Start of processing for Load_Unit |
353 | ||
354 | begin | |
355 | -- If renamings are allowed and we have a child unit name, then we | |
356 | -- must first load the parent to deal with finding the real name. | |
357 | ||
358 | if Renamings and then Is_Child_Name (Load_Name) then | |
359 | Unump := | |
360 | Load_Unit | |
361 | (Load_Name => Get_Parent_Spec_Name (Load_Name), | |
362 | Required => Required, | |
363 | Subunit => False, | |
364 | Renamings => True, | |
365 | Error_Node => Error_Node); | |
366 | ||
367 | if Unump = No_Unit then | |
368 | return No_Unit; | |
369 | end if; | |
370 | ||
371 | -- If parent is a renaming, then we use the renamed package as | |
372 | -- the actual parent for the subsequent load operation. | |
373 | ||
0712790c | 374 | if Nkind (Unit (Cunit (Unump))) = N_Package_Renaming_Declaration then |
38cbfe40 RK |
375 | Uname_Actual := |
376 | New_Child | |
0712790c | 377 | (Load_Name, Get_Unit_Name (Name (Unit (Cunit (Unump))))); |
38cbfe40 RK |
378 | |
379 | -- Save the renaming entity, to establish its visibility when | |
380 | -- installing the context. The implicit with is on this entity, | |
381 | -- not on the package it renames. | |
382 | ||
383 | if Nkind (Error_Node) = N_With_Clause | |
384 | and then Nkind (Name (Error_Node)) = N_Selected_Component | |
385 | then | |
386 | declare | |
387 | Par : Node_Id := Name (Error_Node); | |
388 | ||
389 | begin | |
390 | while Nkind (Par) = N_Selected_Component | |
391 | and then Chars (Selector_Name (Par)) /= | |
392 | Chars (Cunit_Entity (Unump)) | |
393 | loop | |
394 | Par := Prefix (Par); | |
395 | end loop; | |
396 | ||
2e071734 | 397 | -- Case of some intermediate parent is a renaming |
38cbfe40 | 398 | |
2e071734 | 399 | if Nkind (Par) = N_Selected_Component then |
38cbfe40 RK |
400 | Set_Entity (Selector_Name (Par), Cunit_Entity (Unump)); |
401 | ||
2e071734 | 402 | -- Case where the ultimate parent is a renaming |
38cbfe40 | 403 | |
2e071734 | 404 | else |
38cbfe40 RK |
405 | Set_Entity (Par, Cunit_Entity (Unump)); |
406 | end if; | |
407 | end; | |
408 | end if; | |
409 | ||
410 | -- If the parent is not a renaming, then get its name (this may | |
411 | -- be different from the parent spec name obtained above because | |
412 | -- of renamings higher up in the hierarchy). | |
413 | ||
414 | else | |
415 | Uname_Actual := New_Child (Load_Name, Unit_Name (Unump)); | |
416 | end if; | |
417 | ||
418 | -- Here if unit to be loaded is not a child unit | |
419 | ||
420 | else | |
421 | Uname_Actual := Load_Name; | |
422 | end if; | |
423 | ||
424 | Fname := Get_File_Name (Uname_Actual, Subunit); | |
425 | ||
426 | if Debug_Flag_L then | |
427 | Write_Eol; | |
428 | Write_Str ("*** Load request for unit: "); | |
429 | Write_Unit_Name (Load_Name); | |
430 | ||
431 | if Required then | |
432 | Write_Str (" (Required = True)"); | |
433 | else | |
434 | Write_Str (" (Required = False)"); | |
435 | end if; | |
436 | ||
437 | Write_Eol; | |
438 | ||
439 | if Uname_Actual /= Load_Name then | |
440 | Write_Str ("*** Actual unit loaded: "); | |
441 | Write_Unit_Name (Uname_Actual); | |
442 | end if; | |
443 | end if; | |
444 | ||
445 | -- Capture error location if it is for the main unit. The idea is to | |
446 | -- post errors on the main unit location, not the most recent unit. | |
fbf5a39b | 447 | -- Note: Unit_Name (Main_Unit) is not set if we are parsing gnat.adc. |
38cbfe40 | 448 | |
fbf5a39b | 449 | if Present (Error_Node) |
0712790c | 450 | and then Unit_Name (Main_Unit) /= No_Unit_Name |
fbf5a39b | 451 | then |
38cbfe40 RK |
452 | -- It seems like In_Extended_Main_Source_Unit (Error_Node) would |
453 | -- do the trick here, but that's wrong, it is much too early to | |
454 | -- call this routine. We are still in the parser, and the required | |
455 | -- semantic information is not established yet. So we base the | |
456 | -- judgment on unit names. | |
457 | ||
458 | Get_External_Unit_Name_String (Unit_Name (Main_Unit)); | |
459 | ||
460 | declare | |
461 | Main_Unit_Name : constant String := Name_Buffer (1 .. Name_Len); | |
462 | ||
463 | begin | |
464 | Get_External_Unit_Name_String | |
465 | (Unit_Name (Get_Source_Unit (Error_Node))); | |
466 | ||
467 | -- If the two names are identical, then for sure we are part | |
468 | -- of the extended main unit | |
469 | ||
470 | if Main_Unit_Name = Name_Buffer (1 .. Name_Len) then | |
471 | Load_Msg_Sloc := Sloc (Error_Node); | |
472 | ||
473 | -- If the load is called from a with_type clause, the error | |
474 | -- node is correct. | |
475 | ||
38cbfe40 RK |
476 | -- Otherwise, check for the subunit case, and if so, consider |
477 | -- we have a match if one name is a prefix of the other name. | |
478 | ||
479 | else | |
480 | if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit | |
481 | or else | |
482 | Nkind (Unit (Cunit (Get_Source_Unit (Error_Node)))) = | |
483 | N_Subunit | |
484 | then | |
485 | Name_Len := Integer'Min (Name_Len, Main_Unit_Name'Length); | |
486 | ||
487 | if Name_Buffer (1 .. Name_Len) | |
488 | = | |
489 | Main_Unit_Name (1 .. Name_Len) | |
490 | then | |
491 | Load_Msg_Sloc := Sloc (Error_Node); | |
492 | end if; | |
493 | end if; | |
494 | end if; | |
495 | end; | |
496 | end if; | |
497 | ||
498 | -- If we are generating error messages, then capture calling unit | |
499 | ||
500 | if Present (Error_Node) then | |
501 | Calling_Unit := Get_Source_Unit (Error_Node); | |
502 | else | |
503 | Calling_Unit := No_Unit; | |
504 | end if; | |
505 | ||
506 | -- See if we already have an entry for this unit | |
507 | ||
508 | Unum := Main_Unit; | |
509 | ||
510 | while Unum <= Units.Last loop | |
511 | exit when Uname_Actual = Units.Table (Unum).Unit_Name; | |
512 | Unum := Unum + 1; | |
513 | end loop; | |
514 | ||
515 | -- Whether or not the entry was found, Unum is now the right value, | |
516 | -- since it is one more than Units.Last (i.e. the index of the new | |
517 | -- entry we will create) in the not found case. | |
518 | ||
519 | -- A special check is necessary in the unit not found case. If the unit | |
520 | -- is not found, but the file in which it lives has already been loaded, | |
521 | -- then we have the problem that the file does not contain the unit that | |
522 | -- is needed. We simply treat this as a file not found condition. | |
523 | ||
2820d220 AC |
524 | -- We skip this test in multiple unit per file mode since in this |
525 | -- case we can have multiple units from the same source file. | |
526 | ||
53973dcf | 527 | if Unum > Units.Last and then Get_Unit_Index (Uname_Actual) = 0 then |
38cbfe40 RK |
528 | for J in Units.First .. Units.Last loop |
529 | if Fname = Units.Table (J).Unit_File_Name then | |
530 | if Debug_Flag_L then | |
531 | Write_Str (" file does not contain unit, Unit_Number = "); | |
532 | Write_Int (Int (Unum)); | |
533 | Write_Eol; | |
534 | Write_Eol; | |
535 | end if; | |
536 | ||
537 | if Present (Error_Node) then | |
38cbfe40 | 538 | if Is_Predefined_File_Name (Fname) then |
0712790c | 539 | Error_Msg_Unit_1 := Uname_Actual; |
38cbfe40 | 540 | Error_Msg |
0712790c | 541 | ("$$ is not a language defined unit", Load_Msg_Sloc); |
38cbfe40 | 542 | else |
0712790c | 543 | Error_Msg_File_1 := Fname; |
38cbfe40 | 544 | Error_Msg_Unit_1 := Uname_Actual; |
0712790c | 545 | Error_Msg ("File{ does not contain unit$", Load_Msg_Sloc); |
38cbfe40 RK |
546 | end if; |
547 | ||
548 | Write_Dependency_Chain; | |
549 | return No_Unit; | |
550 | ||
551 | else | |
552 | return No_Unit; | |
553 | end if; | |
554 | end if; | |
555 | end loop; | |
556 | end if; | |
557 | ||
2f1b20a9 ES |
558 | -- If we are proceeding with load, then make load stack entry, |
559 | -- and indicate the kind of with_clause responsible for the load. | |
38cbfe40 RK |
560 | |
561 | Load_Stack.Increment_Last; | |
33c423c8 | 562 | Load_Stack.Table (Load_Stack.Last) := (Unum, With_Node); |
38cbfe40 RK |
563 | |
564 | -- Case of entry already in table | |
565 | ||
566 | if Unum <= Units.Last then | |
567 | ||
568 | -- Here is where we check for a circular dependency, which is | |
569 | -- an attempt to load a unit which is currently in the process | |
570 | -- of being loaded. We do *not* care about a circular chain that | |
571 | -- leads back to a body, because this kind of circular dependence | |
572 | -- legitimately occurs (e.g. two package bodies that contain | |
573 | -- inlined subprogram referenced by the other). | |
574 | ||
0ab80019 | 575 | -- Ada 2005 (AI-50217): We also ignore limited_with clauses, because |
19f0526a | 576 | -- their purpose is precisely to create legal circular structures. |
fbf5a39b | 577 | |
38cbfe40 RK |
578 | if Loading (Unum) |
579 | and then (Is_Spec_Name (Units.Table (Unum).Unit_Name) | |
580 | or else Acts_As_Spec (Units.Table (Unum).Cunit)) | |
fbf5a39b AC |
581 | and then (Nkind (Error_Node) /= N_With_Clause |
582 | or else not Limited_Present (Error_Node)) | |
33c423c8 | 583 | and then not From_Limited_With_Chain |
38cbfe40 RK |
584 | then |
585 | if Debug_Flag_L then | |
586 | Write_Str (" circular dependency encountered"); | |
587 | Write_Eol; | |
588 | end if; | |
589 | ||
590 | if Present (Error_Node) then | |
591 | Error_Msg ("circular unit dependency", Load_Msg_Sloc); | |
592 | Write_Dependency_Chain; | |
593 | else | |
594 | Load_Stack.Decrement_Last; | |
595 | end if; | |
596 | ||
597 | return No_Unit; | |
598 | end if; | |
599 | ||
600 | if Debug_Flag_L then | |
601 | Write_Str (" unit already in file table, Unit_Number = "); | |
602 | Write_Int (Int (Unum)); | |
603 | Write_Eol; | |
604 | end if; | |
605 | ||
606 | Load_Stack.Decrement_Last; | |
38cbfe40 RK |
607 | return Unum; |
608 | ||
2820d220 | 609 | -- Unit is not already in table, so try to open the file |
38cbfe40 RK |
610 | |
611 | else | |
612 | if Debug_Flag_L then | |
613 | Write_Str (" attempt unit load, Unit_Number = "); | |
614 | Write_Int (Int (Unum)); | |
615 | Write_Eol; | |
616 | end if; | |
617 | ||
618 | Src_Ind := Load_Source_File (Fname); | |
619 | ||
620 | -- Make a partial entry in the file table, used even in the file not | |
621 | -- found case to print the dependency chain including the last entry | |
622 | ||
623 | Units.Increment_Last; | |
624 | Units.Table (Unum).Unit_Name := Uname_Actual; | |
625 | ||
626 | -- File was found | |
627 | ||
628 | if Src_Ind /= No_Source_File then | |
629 | Units.Table (Unum) := ( | |
630 | Cunit => Empty, | |
631 | Cunit_Entity => Empty, | |
632 | Dependency_Num => 0, | |
38cbfe40 RK |
633 | Dynamic_Elab => False, |
634 | Error_Location => Sloc (Error_Node), | |
635 | Expected_Unit => Uname_Actual, | |
636 | Fatal_Error => False, | |
637 | Generate_Code => False, | |
638 | Has_RACW => False, | |
639 | Ident_String => Empty, | |
640 | Loading => True, | |
641 | Main_Priority => Default_Main_Priority, | |
2820d220 | 642 | Munit_Index => 0, |
38cbfe40 RK |
643 | Serial_Number => 0, |
644 | Source_Index => Src_Ind, | |
645 | Unit_File_Name => Fname, | |
646 | Unit_Name => Uname_Actual, | |
647 | Version => Source_Checksum (Src_Ind)); | |
648 | ||
649 | -- Parse the new unit | |
650 | ||
2820d220 AC |
651 | declare |
652 | Save_Index : constant Nat := Multiple_Unit_Index; | |
653 | begin | |
654 | Multiple_Unit_Index := Get_Unit_Index (Uname_Actual); | |
655 | Units.Table (Unum).Munit_Index := Multiple_Unit_Index; | |
656 | Initialize_Scanner (Unum, Source_Index (Unum)); | |
33c423c8 | 657 | Discard_List (Par (Configuration_Pragmas => False)); |
2820d220 AC |
658 | Multiple_Unit_Index := Save_Index; |
659 | Set_Loading (Unum, False); | |
660 | end; | |
38cbfe40 RK |
661 | |
662 | -- If spec is irrelevant, then post errors and quit | |
663 | ||
664 | if Corr_Body /= No_Unit | |
665 | and then Spec_Is_Irrelevant (Unum, Corr_Body) | |
666 | then | |
0712790c | 667 | Error_Msg_File_1 := Unit_File_Name (Corr_Body); |
38cbfe40 | 668 | Error_Msg |
0712790c ES |
669 | ("cannot compile subprogram in file {!", Load_Msg_Sloc); |
670 | Error_Msg_File_1 := Unit_File_Name (Unum); | |
38cbfe40 | 671 | Error_Msg |
53973dcf | 672 | ("\incorrect spec in file { must be removed first!", |
38cbfe40 RK |
673 | Load_Msg_Sloc); |
674 | return No_Unit; | |
675 | end if; | |
676 | ||
677 | -- If loaded unit had a fatal error, then caller inherits it! | |
678 | ||
679 | if Units.Table (Unum).Fatal_Error | |
680 | and then Present (Error_Node) | |
681 | then | |
682 | Units.Table (Calling_Unit).Fatal_Error := True; | |
683 | end if; | |
684 | ||
685 | -- Remove load stack entry and return the entry in the file table | |
686 | ||
687 | Load_Stack.Decrement_Last; | |
38cbfe40 RK |
688 | return Unum; |
689 | ||
690 | -- Case of file not found | |
691 | ||
692 | else | |
693 | if Debug_Flag_L then | |
694 | Write_Str (" file was not found, load failed"); | |
695 | Write_Eol; | |
696 | end if; | |
697 | ||
698 | -- Generate message if unit required | |
699 | ||
700 | if Required and then Present (Error_Node) then | |
38cbfe40 | 701 | if Is_Predefined_File_Name (Fname) then |
e9437007 JM |
702 | |
703 | -- This is a predefined library unit which is not present | |
704 | -- in the run time. If a predefined unit is not available | |
705 | -- it may very likely be the case that there is also pragma | |
706 | -- Restriction forbidding its usage. This is typically the | |
707 | -- case when building a configurable run time, where the | |
708 | -- usage of certain run-time units units is restricted by | |
709 | -- means of both the corresponding pragma Restriction (such | |
710 | -- as No_Calendar), and by not including the unit. Hence, | |
711 | -- we check whether this predefined unit is forbidden, so | |
712 | -- that the message about the restriction violation is | |
713 | -- generated, if needed. | |
714 | ||
715 | Check_Restricted_Unit (Load_Name, Error_Node); | |
716 | ||
0712790c | 717 | Error_Msg_Unit_1 := Uname_Actual; |
38cbfe40 | 718 | Error_Msg |
0712790c | 719 | ("$$ is not a predefined library unit", Load_Msg_Sloc); |
38cbfe40 RK |
720 | |
721 | else | |
0712790c | 722 | Error_Msg_File_1 := Fname; |
38cbfe40 RK |
723 | Error_Msg ("file{ not found", Load_Msg_Sloc); |
724 | end if; | |
725 | ||
726 | Write_Dependency_Chain; | |
727 | ||
728 | -- Remove unit from stack, to avoid cascaded errors on | |
729 | -- subsequent missing files. | |
730 | ||
731 | Load_Stack.Decrement_Last; | |
732 | Units.Decrement_Last; | |
733 | ||
734 | -- If unit not required, remove load stack entry and the junk | |
735 | -- file table entry, and return No_Unit to indicate not found, | |
736 | ||
737 | else | |
738 | Load_Stack.Decrement_Last; | |
739 | Units.Decrement_Last; | |
740 | end if; | |
741 | ||
742 | return No_Unit; | |
743 | end if; | |
744 | end if; | |
745 | end Load_Unit; | |
746 | ||
747 | ------------------------ | |
748 | -- Make_Instance_Unit -- | |
749 | ------------------------ | |
750 | ||
751 | -- If the unit is an instance, it appears as a package declaration, but | |
752 | -- contains both declaration and body of the instance. The body becomes | |
753 | -- the main unit of the compilation, and the declaration is inserted | |
754 | -- at the end of the unit table. The main unit now has the name of a | |
755 | -- body, which is constructed from the name of the original spec, | |
756 | -- and is attached to the compilation node of the original unit. The | |
757 | -- declaration has been attached to a new compilation unit node, and | |
758 | -- code will have to be generated for it. | |
759 | ||
760 | procedure Make_Instance_Unit (N : Node_Id) is | |
761 | Sind : constant Source_File_Index := Source_Index (Main_Unit); | |
38cbfe40 RK |
762 | begin |
763 | Units.Increment_Last; | |
38cbfe40 RK |
764 | Units.Table (Units.Last) := Units.Table (Main_Unit); |
765 | Units.Table (Units.Last).Cunit := Library_Unit (N); | |
766 | Units.Table (Units.Last).Generate_Code := True; | |
38cbfe40 RK |
767 | Units.Table (Main_Unit).Cunit := N; |
768 | Units.Table (Main_Unit).Unit_Name := | |
769 | Get_Body_Name (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N)))); | |
770 | Units.Table (Main_Unit).Version := Source_Checksum (Sind); | |
771 | end Make_Instance_Unit; | |
772 | ||
773 | ------------------------ | |
774 | -- Spec_Is_Irrelevant -- | |
775 | ------------------------ | |
776 | ||
777 | function Spec_Is_Irrelevant | |
778 | (Spec_Unit : Unit_Number_Type; | |
2e071734 | 779 | Body_Unit : Unit_Number_Type) return Boolean |
38cbfe40 RK |
780 | is |
781 | Sunit : constant Node_Id := Cunit (Spec_Unit); | |
782 | Bunit : constant Node_Id := Cunit (Body_Unit); | |
2e071734 | 783 | |
38cbfe40 RK |
784 | begin |
785 | -- The spec is irrelevant if the body is a subprogram body, and the | |
786 | -- spec is other than a subprogram spec or generic subprogram spec. | |
787 | -- Note that the names must be the same, we don't need to check that, | |
788 | -- because we already know that from the fact that the file names are | |
789 | -- the same. | |
790 | ||
791 | return | |
792 | Nkind (Unit (Bunit)) = N_Subprogram_Body | |
793 | and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration | |
794 | and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration; | |
38cbfe40 RK |
795 | end Spec_Is_Irrelevant; |
796 | ||
797 | -------------------- | |
798 | -- Version_Update -- | |
799 | -------------------- | |
800 | ||
801 | procedure Version_Update (U : Node_Id; From : Node_Id) is | |
802 | Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (U); | |
803 | Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From); | |
38cbfe40 | 804 | begin |
fbf5a39b AC |
805 | if Source_Index (Fnum) /= No_Source_File then |
806 | Units.Table (Unum).Version := | |
807 | Units.Table (Unum).Version | |
808 | xor | |
809 | Source_Checksum (Source_Index (Fnum)); | |
810 | end if; | |
38cbfe40 RK |
811 | end Version_Update; |
812 | ||
813 | ---------------------------- | |
814 | -- Write_Dependency_Chain -- | |
815 | ---------------------------- | |
816 | ||
817 | procedure Write_Dependency_Chain is | |
818 | begin | |
819 | -- The dependency chain is only written if it is at least two entries | |
820 | -- deep, otherwise it is trivial (the main unit depending on a unit | |
821 | -- that it obviously directly depends on). | |
822 | ||
823 | if Load_Stack.Last - 1 > Load_Stack.First then | |
824 | for U in Load_Stack.First .. Load_Stack.Last - 1 loop | |
2f1b20a9 ES |
825 | Error_Msg_Unit_1 := |
826 | Unit_Name (Load_Stack.Table (U).Unit_Number); | |
827 | Error_Msg_Unit_2 := | |
828 | Unit_Name (Load_Stack.Table (U + 1).Unit_Number); | |
38cbfe40 RK |
829 | Error_Msg ("$ depends on $!", Load_Msg_Sloc); |
830 | end loop; | |
831 | end if; | |
832 | end Write_Dependency_Chain; | |
833 | ||
834 | end Lib.Load; |