PR middle-end/20263
[official-gcc.git] / gcc / ada / lib-load.adb
blob59879f0a431ad0fc9a300b2e0be9f11b21f0621d
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- L I B . L O A D --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
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 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Fname; use Fname;
32 with Fname.UF; use Fname.UF;
33 with Namet; use Namet;
34 with Nlists; use Nlists;
35 with Nmake; use Nmake;
36 with Opt; use Opt;
37 with Osint; use Osint;
38 with Osint.C; use Osint.C;
39 with Output; use Output;
40 with Par;
41 with Scn; use Scn;
42 with Sinfo; use Sinfo;
43 with Sinput; use Sinput;
44 with Sinput.L; use Sinput.L;
45 with Stand; use Stand;
46 with Tbuild; use Tbuild;
47 with Uname; use Uname;
49 package body Lib.Load is
51 -----------------------
52 -- Local Subprograms --
53 -----------------------
55 function Spec_Is_Irrelevant
56 (Spec_Unit : Unit_Number_Type;
57 Body_Unit : Unit_Number_Type) return Boolean;
58 -- The Spec_Unit and Body_Unit parameters are the unit numbers of the
59 -- spec file that corresponds to the main unit which is a body. This
60 -- function determines if the spec file is irrelevant and will be
61 -- overridden by the body as described in RM 10.1.4(4). See description
62 -- in "Special Handling of Subprogram Bodies" for further details.
64 procedure Write_Dependency_Chain;
65 -- This procedure is used to generate error message info lines that
66 -- trace the current dependency chain when a load error occurs.
68 -------------------------------
69 -- Create_Dummy_Package_Unit --
70 -------------------------------
72 function Create_Dummy_Package_Unit
73 (With_Node : Node_Id;
74 Spec_Name : Unit_Name_Type) return Unit_Number_Type
76 Unum : Unit_Number_Type;
77 Cunit_Entity : Entity_Id;
78 Cunit : Node_Id;
79 Du_Name : Node_Or_Entity_Id;
80 End_Lab : Node_Id;
81 Save_CS : constant Boolean := Get_Comes_From_Source_Default;
83 begin
84 -- The created dummy package unit does not come from source
86 Set_Comes_From_Source_Default (False);
88 -- Normal package
90 if Nkind (Name (With_Node)) = N_Identifier then
91 Cunit_Entity :=
92 Make_Defining_Identifier (No_Location,
93 Chars => Chars (Name (With_Node)));
94 Du_Name := Cunit_Entity;
95 End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location);
97 -- Child package
99 else
100 Cunit_Entity :=
101 Make_Defining_Identifier (No_Location,
102 Chars => Chars (Selector_Name (Name (With_Node))));
103 Du_Name :=
104 Make_Defining_Program_Unit_Name (No_Location,
105 Name => New_Copy_Tree (Prefix (Name (With_Node))),
106 Defining_Identifier => Cunit_Entity);
108 Set_Is_Child_Unit (Cunit_Entity);
110 End_Lab :=
111 Make_Designator (No_Location,
112 Name => New_Copy_Tree (Prefix (Name (With_Node))),
113 Identifier => New_Occurrence_Of (Cunit_Entity, No_Location));
114 end if;
116 Set_Scope (Cunit_Entity, Standard_Standard);
118 Cunit :=
119 Make_Compilation_Unit (No_Location,
120 Context_Items => Empty_List,
121 Unit =>
122 Make_Package_Declaration (No_Location,
123 Specification =>
124 Make_Package_Specification (No_Location,
125 Defining_Unit_Name => Du_Name,
126 Visible_Declarations => Empty_List,
127 End_Label => End_Lab)),
128 Aux_Decls_Node =>
129 Make_Compilation_Unit_Aux (No_Location));
131 -- Mark the dummy package as analyzed to prevent analysis of this
132 -- (non-existent) unit in -gnatQ mode because at the moment the
133 -- structure and attributes of this dummy package does not allow
134 -- a normal analysis of this unit
136 Set_Analyzed (Cunit);
138 Units.Increment_Last;
139 Unum := Units.Last;
141 Units.Table (Unum) := (
142 Cunit => Cunit,
143 Cunit_Entity => Cunit_Entity,
144 Dependency_Num => 0,
145 Dynamic_Elab => False,
146 Error_Location => Sloc (With_Node),
147 Expected_Unit => Spec_Name,
148 Fatal_Error => True,
149 Generate_Code => False,
150 Has_RACW => False,
151 Ident_String => Empty,
152 Loading => False,
153 Main_Priority => Default_Main_Priority,
154 Munit_Index => 0,
155 Serial_Number => 0,
156 Source_Index => No_Source_File,
157 Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False),
158 Unit_Name => Spec_Name,
159 Version => 0);
161 Set_Comes_From_Source_Default (Save_CS);
162 Set_Error_Posted (Cunit_Entity);
163 Set_Error_Posted (Cunit);
164 return Unum;
165 end Create_Dummy_Package_Unit;
167 ----------------
168 -- Initialize --
169 ----------------
171 procedure Initialize is
172 begin
173 Units.Init;
174 Load_Stack.Init;
175 end Initialize;
177 ------------------------
178 -- Initialize_Version --
179 ------------------------
181 procedure Initialize_Version (U : Unit_Number_Type) is
182 begin
183 Units.Table (U).Version := Source_Checksum (Source_Index (U));
184 end Initialize_Version;
186 ----------------------
187 -- Load_Main_Source --
188 ----------------------
190 procedure Load_Main_Source is
191 Fname : File_Name_Type;
193 begin
194 Load_Stack.Increment_Last;
195 Load_Stack.Table (Load_Stack.Last) := Main_Unit;
197 -- Initialize unit table entry for Main_Unit. Note that we don't know
198 -- the unit name yet, that gets filled in when the parser parses the
199 -- main unit, at which time a check is made that it matches the main
200 -- file name, and then the Unit_Name field is set. The Cunit and
201 -- Cunit_Entity fields also get filled in later by the parser.
203 Units.Increment_Last;
204 Fname := Next_Main_Source;
206 Units.Table (Main_Unit).Unit_File_Name := Fname;
208 if Fname /= No_File then
209 Main_Source_File := Load_Source_File (Fname);
210 Current_Error_Source_File := Main_Source_File;
212 Units.Table (Main_Unit) := (
213 Cunit => Empty,
214 Cunit_Entity => Empty,
215 Dependency_Num => 0,
216 Dynamic_Elab => False,
217 Error_Location => No_Location,
218 Expected_Unit => No_Name,
219 Fatal_Error => False,
220 Generate_Code => False,
221 Has_RACW => False,
222 Ident_String => Empty,
223 Loading => True,
224 Main_Priority => Default_Main_Priority,
225 Munit_Index => 0,
226 Serial_Number => 0,
227 Source_Index => Main_Source_File,
228 Unit_File_Name => Fname,
229 Unit_Name => No_Name,
230 Version => Source_Checksum (Main_Source_File));
231 end if;
232 end Load_Main_Source;
234 ---------------
235 -- Load_Unit --
236 ---------------
238 function Load_Unit
239 (Load_Name : Unit_Name_Type;
240 Required : Boolean;
241 Error_Node : Node_Id;
242 Subunit : Boolean;
243 Corr_Body : Unit_Number_Type := No_Unit;
244 Renamings : Boolean := False) return Unit_Number_Type
246 Calling_Unit : Unit_Number_Type;
247 Uname_Actual : Unit_Name_Type;
248 Unum : Unit_Number_Type;
249 Unump : Unit_Number_Type;
250 Fname : File_Name_Type;
251 Src_Ind : Source_File_Index;
253 -- Start of processing for Load_Unit
255 begin
256 -- If renamings are allowed and we have a child unit name, then we
257 -- must first load the parent to deal with finding the real name.
259 if Renamings and then Is_Child_Name (Load_Name) then
260 Unump :=
261 Load_Unit
262 (Load_Name => Get_Parent_Spec_Name (Load_Name),
263 Required => Required,
264 Subunit => False,
265 Renamings => True,
266 Error_Node => Error_Node);
268 if Unump = No_Unit then
269 return No_Unit;
270 end if;
272 -- If parent is a renaming, then we use the renamed package as
273 -- the actual parent for the subsequent load operation.
275 if Nkind (Parent (Cunit_Entity (Unump))) =
276 N_Package_Renaming_Declaration
277 then
278 Uname_Actual :=
279 New_Child
280 (Load_Name,
281 Get_Unit_Name (Name (Parent (Cunit_Entity (Unump)))));
283 -- Save the renaming entity, to establish its visibility when
284 -- installing the context. The implicit with is on this entity,
285 -- not on the package it renames.
287 if Nkind (Error_Node) = N_With_Clause
288 and then Nkind (Name (Error_Node)) = N_Selected_Component
289 then
290 declare
291 Par : Node_Id := Name (Error_Node);
293 begin
294 while Nkind (Par) = N_Selected_Component
295 and then Chars (Selector_Name (Par)) /=
296 Chars (Cunit_Entity (Unump))
297 loop
298 Par := Prefix (Par);
299 end loop;
301 -- Case of some intermediate parent is a renaming
303 if Nkind (Par) = N_Selected_Component then
304 Set_Entity (Selector_Name (Par), Cunit_Entity (Unump));
306 -- Case where the ultimate parent is a renaming
308 else
309 Set_Entity (Par, Cunit_Entity (Unump));
310 end if;
311 end;
312 end if;
314 -- If the parent is not a renaming, then get its name (this may
315 -- be different from the parent spec name obtained above because
316 -- of renamings higher up in the hierarchy).
318 else
319 Uname_Actual := New_Child (Load_Name, Unit_Name (Unump));
320 end if;
322 -- Here if unit to be loaded is not a child unit
324 else
325 Uname_Actual := Load_Name;
326 end if;
328 Fname := Get_File_Name (Uname_Actual, Subunit);
330 if Debug_Flag_L then
331 Write_Eol;
332 Write_Str ("*** Load request for unit: ");
333 Write_Unit_Name (Load_Name);
335 if Required then
336 Write_Str (" (Required = True)");
337 else
338 Write_Str (" (Required = False)");
339 end if;
341 Write_Eol;
343 if Uname_Actual /= Load_Name then
344 Write_Str ("*** Actual unit loaded: ");
345 Write_Unit_Name (Uname_Actual);
346 end if;
347 end if;
349 -- Capture error location if it is for the main unit. The idea is to
350 -- post errors on the main unit location, not the most recent unit.
351 -- Note: Unit_Name (Main_Unit) is not set if we are parsing gnat.adc.
353 if Present (Error_Node)
354 and then Unit_Name (Main_Unit) /= No_Name
355 then
356 -- It seems like In_Extended_Main_Source_Unit (Error_Node) would
357 -- do the trick here, but that's wrong, it is much too early to
358 -- call this routine. We are still in the parser, and the required
359 -- semantic information is not established yet. So we base the
360 -- judgment on unit names.
362 Get_External_Unit_Name_String (Unit_Name (Main_Unit));
364 declare
365 Main_Unit_Name : constant String := Name_Buffer (1 .. Name_Len);
367 begin
368 Get_External_Unit_Name_String
369 (Unit_Name (Get_Source_Unit (Error_Node)));
371 -- If the two names are identical, then for sure we are part
372 -- of the extended main unit
374 if Main_Unit_Name = Name_Buffer (1 .. Name_Len) then
375 Load_Msg_Sloc := Sloc (Error_Node);
377 -- If the load is called from a with_type clause, the error
378 -- node is correct.
380 elsif Nkind (Parent (Error_Node)) = N_With_Type_Clause then
381 Load_Msg_Sloc := Sloc (Error_Node);
383 -- Otherwise, check for the subunit case, and if so, consider
384 -- we have a match if one name is a prefix of the other name.
386 else
387 if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
388 or else
389 Nkind (Unit (Cunit (Get_Source_Unit (Error_Node)))) =
390 N_Subunit
391 then
392 Name_Len := Integer'Min (Name_Len, Main_Unit_Name'Length);
394 if Name_Buffer (1 .. Name_Len)
396 Main_Unit_Name (1 .. Name_Len)
397 then
398 Load_Msg_Sloc := Sloc (Error_Node);
399 end if;
400 end if;
401 end if;
402 end;
403 end if;
405 -- If we are generating error messages, then capture calling unit
407 if Present (Error_Node) then
408 Calling_Unit := Get_Source_Unit (Error_Node);
409 else
410 Calling_Unit := No_Unit;
411 end if;
413 -- See if we already have an entry for this unit
415 Unum := Main_Unit;
417 while Unum <= Units.Last loop
418 exit when Uname_Actual = Units.Table (Unum).Unit_Name;
419 Unum := Unum + 1;
420 end loop;
422 -- Whether or not the entry was found, Unum is now the right value,
423 -- since it is one more than Units.Last (i.e. the index of the new
424 -- entry we will create) in the not found case.
426 -- A special check is necessary in the unit not found case. If the unit
427 -- is not found, but the file in which it lives has already been loaded,
428 -- then we have the problem that the file does not contain the unit that
429 -- is needed. We simply treat this as a file not found condition.
431 -- We skip this test in multiple unit per file mode since in this
432 -- case we can have multiple units from the same source file.
434 if Unum > Units.Last and then Multiple_Unit_Index = 0 then
435 for J in Units.First .. Units.Last loop
436 if Fname = Units.Table (J).Unit_File_Name then
437 if Debug_Flag_L then
438 Write_Str (" file does not contain unit, Unit_Number = ");
439 Write_Int (Int (Unum));
440 Write_Eol;
441 Write_Eol;
442 end if;
444 if Present (Error_Node) then
445 if Is_Predefined_File_Name (Fname) then
446 Error_Msg_Name_1 := Uname_Actual;
447 Error_Msg
448 ("% is not a language defined unit", Load_Msg_Sloc);
449 else
450 Error_Msg_Name_1 := Fname;
451 Error_Msg_Unit_1 := Uname_Actual;
452 Error_Msg
453 ("File{ does not contain unit$", Load_Msg_Sloc);
454 end if;
456 Write_Dependency_Chain;
457 return No_Unit;
459 else
460 return No_Unit;
461 end if;
462 end if;
463 end loop;
464 end if;
466 -- If we are proceeding with load, then make load stack entry
468 Load_Stack.Increment_Last;
469 Load_Stack.Table (Load_Stack.Last) := Unum;
471 -- Case of entry already in table
473 if Unum <= Units.Last then
475 -- Here is where we check for a circular dependency, which is
476 -- an attempt to load a unit which is currently in the process
477 -- of being loaded. We do *not* care about a circular chain that
478 -- leads back to a body, because this kind of circular dependence
479 -- legitimately occurs (e.g. two package bodies that contain
480 -- inlined subprogram referenced by the other).
482 -- Ada 2005 (AI-50217): We also ignore limited_with clauses, because
483 -- their purpose is precisely to create legal circular structures.
485 if Loading (Unum)
486 and then (Is_Spec_Name (Units.Table (Unum).Unit_Name)
487 or else Acts_As_Spec (Units.Table (Unum).Cunit))
488 and then (Nkind (Error_Node) /= N_With_Clause
489 or else not Limited_Present (Error_Node))
491 then
492 if Debug_Flag_L then
493 Write_Str (" circular dependency encountered");
494 Write_Eol;
495 end if;
497 if Present (Error_Node) then
498 Error_Msg ("circular unit dependency", Load_Msg_Sloc);
499 Write_Dependency_Chain;
500 else
501 Load_Stack.Decrement_Last;
502 end if;
504 return No_Unit;
505 end if;
507 if Debug_Flag_L then
508 Write_Str (" unit already in file table, Unit_Number = ");
509 Write_Int (Int (Unum));
510 Write_Eol;
511 end if;
513 Load_Stack.Decrement_Last;
514 return Unum;
516 -- Unit is not already in table, so try to open the file
518 else
519 if Debug_Flag_L then
520 Write_Str (" attempt unit load, Unit_Number = ");
521 Write_Int (Int (Unum));
522 Write_Eol;
523 end if;
525 Src_Ind := Load_Source_File (Fname);
527 -- Make a partial entry in the file table, used even in the file not
528 -- found case to print the dependency chain including the last entry
530 Units.Increment_Last;
531 Units.Table (Unum).Unit_Name := Uname_Actual;
533 -- File was found
535 if Src_Ind /= No_Source_File then
536 Units.Table (Unum) := (
537 Cunit => Empty,
538 Cunit_Entity => Empty,
539 Dependency_Num => 0,
540 Dynamic_Elab => False,
541 Error_Location => Sloc (Error_Node),
542 Expected_Unit => Uname_Actual,
543 Fatal_Error => False,
544 Generate_Code => False,
545 Has_RACW => False,
546 Ident_String => Empty,
547 Loading => True,
548 Main_Priority => Default_Main_Priority,
549 Munit_Index => 0,
550 Serial_Number => 0,
551 Source_Index => Src_Ind,
552 Unit_File_Name => Fname,
553 Unit_Name => Uname_Actual,
554 Version => Source_Checksum (Src_Ind));
556 -- Parse the new unit
558 declare
559 Save_Index : constant Nat := Multiple_Unit_Index;
560 begin
561 Multiple_Unit_Index := Get_Unit_Index (Uname_Actual);
562 Units.Table (Unum).Munit_Index := Multiple_Unit_Index;
563 Initialize_Scanner (Unum, Source_Index (Unum));
564 Discard_List (Par (Configuration_Pragmas => False));
565 Multiple_Unit_Index := Save_Index;
566 Set_Loading (Unum, False);
567 end;
569 -- If spec is irrelevant, then post errors and quit
571 if Corr_Body /= No_Unit
572 and then Spec_Is_Irrelevant (Unum, Corr_Body)
573 then
574 Error_Msg_Name_1 := Unit_File_Name (Corr_Body);
575 Error_Msg
576 ("cannot compile subprogram in file {!",
577 Load_Msg_Sloc);
578 Error_Msg_Name_1 := Unit_File_Name (Unum);
579 Error_Msg
580 ("incorrect spec in file { must be removed first!",
581 Load_Msg_Sloc);
582 return No_Unit;
583 end if;
585 -- If loaded unit had a fatal error, then caller inherits it!
587 if Units.Table (Unum).Fatal_Error
588 and then Present (Error_Node)
589 then
590 Units.Table (Calling_Unit).Fatal_Error := True;
591 end if;
593 -- Remove load stack entry and return the entry in the file table
595 Load_Stack.Decrement_Last;
596 return Unum;
598 -- Case of file not found
600 else
601 if Debug_Flag_L then
602 Write_Str (" file was not found, load failed");
603 Write_Eol;
604 end if;
606 -- Generate message if unit required
608 if Required and then Present (Error_Node) then
610 if Is_Predefined_File_Name (Fname) then
611 Error_Msg_Name_1 := Uname_Actual;
612 Error_Msg
613 ("% is not a predefined library unit", Load_Msg_Sloc);
615 else
616 Error_Msg_Name_1 := Fname;
617 Error_Msg ("file{ not found", Load_Msg_Sloc);
618 end if;
620 Write_Dependency_Chain;
622 -- Remove unit from stack, to avoid cascaded errors on
623 -- subsequent missing files.
625 Load_Stack.Decrement_Last;
626 Units.Decrement_Last;
628 -- If unit not required, remove load stack entry and the junk
629 -- file table entry, and return No_Unit to indicate not found,
631 else
632 Load_Stack.Decrement_Last;
633 Units.Decrement_Last;
634 end if;
636 return No_Unit;
637 end if;
638 end if;
639 end Load_Unit;
641 ------------------------
642 -- Make_Instance_Unit --
643 ------------------------
645 -- If the unit is an instance, it appears as a package declaration, but
646 -- contains both declaration and body of the instance. The body becomes
647 -- the main unit of the compilation, and the declaration is inserted
648 -- at the end of the unit table. The main unit now has the name of a
649 -- body, which is constructed from the name of the original spec,
650 -- and is attached to the compilation node of the original unit. The
651 -- declaration has been attached to a new compilation unit node, and
652 -- code will have to be generated for it.
654 procedure Make_Instance_Unit (N : Node_Id) is
655 Sind : constant Source_File_Index := Source_Index (Main_Unit);
656 begin
657 Units.Increment_Last;
658 Units.Table (Units.Last) := Units.Table (Main_Unit);
659 Units.Table (Units.Last).Cunit := Library_Unit (N);
660 Units.Table (Units.Last).Generate_Code := True;
661 Units.Table (Main_Unit).Cunit := N;
662 Units.Table (Main_Unit).Unit_Name :=
663 Get_Body_Name (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N))));
664 Units.Table (Main_Unit).Version := Source_Checksum (Sind);
665 end Make_Instance_Unit;
667 ------------------------
668 -- Spec_Is_Irrelevant --
669 ------------------------
671 function Spec_Is_Irrelevant
672 (Spec_Unit : Unit_Number_Type;
673 Body_Unit : Unit_Number_Type) return Boolean
675 Sunit : constant Node_Id := Cunit (Spec_Unit);
676 Bunit : constant Node_Id := Cunit (Body_Unit);
678 begin
679 -- The spec is irrelevant if the body is a subprogram body, and the
680 -- spec is other than a subprogram spec or generic subprogram spec.
681 -- Note that the names must be the same, we don't need to check that,
682 -- because we already know that from the fact that the file names are
683 -- the same.
685 return
686 Nkind (Unit (Bunit)) = N_Subprogram_Body
687 and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration
688 and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration;
689 end Spec_Is_Irrelevant;
691 --------------------
692 -- Version_Update --
693 --------------------
695 procedure Version_Update (U : Node_Id; From : Node_Id) is
696 Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (U);
697 Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From);
698 begin
699 if Source_Index (Fnum) /= No_Source_File then
700 Units.Table (Unum).Version :=
701 Units.Table (Unum).Version
703 Source_Checksum (Source_Index (Fnum));
704 end if;
705 end Version_Update;
707 ----------------------------
708 -- Write_Dependency_Chain --
709 ----------------------------
711 procedure Write_Dependency_Chain is
712 begin
713 -- The dependency chain is only written if it is at least two entries
714 -- deep, otherwise it is trivial (the main unit depending on a unit
715 -- that it obviously directly depends on).
717 if Load_Stack.Last - 1 > Load_Stack.First then
718 for U in Load_Stack.First .. Load_Stack.Last - 1 loop
719 Error_Msg_Unit_1 := Unit_Name (Load_Stack.Table (U));
720 Error_Msg_Unit_2 := Unit_Name (Load_Stack.Table (U + 1));
721 Error_Msg ("$ depends on $!", Load_Msg_Sloc);
722 end loop;
723 end if;
724 end Write_Dependency_Chain;
726 end Lib.Load;