1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 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;
37 with Osint; use Osint;
38 with Osint.C; use Osint.C;
39 with Output; use Output;
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
74 Spec_Name : Unit_Name_Type) return Unit_Number_Type
76 Unum : Unit_Number_Type;
77 Cunit_Entity : Entity_Id;
79 Du_Name : Node_Or_Entity_Id;
81 Save_CS : constant Boolean := Get_Comes_From_Source_Default;
84 -- The created dummy package unit does not come from source
86 Set_Comes_From_Source_Default (False);
90 if Nkind (Name (With_Node)) = N_Identifier then
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);
101 Make_Defining_Identifier (No_Location,
102 Chars => Chars (Selector_Name (Name (With_Node))));
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);
111 Make_Designator (No_Location,
112 Name => New_Copy_Tree (Prefix (Name (With_Node))),
113 Identifier => New_Occurrence_Of (Cunit_Entity, No_Location));
116 Set_Scope (Cunit_Entity, Standard_Standard);
119 Make_Compilation_Unit (No_Location,
120 Context_Items => Empty_List,
122 Make_Package_Declaration (No_Location,
124 Make_Package_Specification (No_Location,
125 Defining_Unit_Name => Du_Name,
126 Visible_Declarations => Empty_List,
127 End_Label => End_Lab)),
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;
141 Units.Table (Unum) := (
143 Cunit_Entity => Cunit_Entity,
145 Dynamic_Elab => False,
146 Error_Location => Sloc (With_Node),
147 Expected_Unit => Spec_Name,
149 Generate_Code => False,
151 Ident_String => Empty,
153 Main_Priority => Default_Main_Priority,
156 Source_Index => No_Source_File,
157 Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False),
158 Unit_Name => Spec_Name,
161 Set_Comes_From_Source_Default (Save_CS);
162 Set_Error_Posted (Cunit_Entity);
163 Set_Error_Posted (Cunit);
165 end Create_Dummy_Package_Unit;
171 procedure Initialize is
177 ------------------------
178 -- Initialize_Version --
179 ------------------------
181 procedure Initialize_Version (U : Unit_Number_Type) is
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;
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) := (
214 Cunit_Entity => Empty,
216 Dynamic_Elab => False,
217 Error_Location => No_Location,
218 Expected_Unit => No_Name,
219 Fatal_Error => False,
220 Generate_Code => False,
222 Ident_String => Empty,
224 Main_Priority => Default_Main_Priority,
227 Source_Index => Main_Source_File,
228 Unit_File_Name => Fname,
229 Unit_Name => No_Name,
230 Version => Source_Checksum (Main_Source_File));
232 end Load_Main_Source;
239 (Load_Name : Unit_Name_Type;
241 Error_Node : Node_Id;
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
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
262 (Load_Name => Get_Parent_Spec_Name (Load_Name),
263 Required => Required,
266 Error_Node => Error_Node);
268 if Unump = No_Unit then
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
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
291 Par : Node_Id := Name (Error_Node);
294 while Nkind (Par) = N_Selected_Component
295 and then Chars (Selector_Name (Par)) /=
296 Chars (Cunit_Entity (Unump))
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
309 Set_Entity (Par, Cunit_Entity (Unump));
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).
319 Uname_Actual := New_Child (Load_Name, Unit_Name (Unump));
322 -- Here if unit to be loaded is not a child unit
325 Uname_Actual := Load_Name;
328 Fname := Get_File_Name (Uname_Actual, Subunit);
332 Write_Str ("*** Load request for unit: ");
333 Write_Unit_Name (Load_Name);
336 Write_Str (" (Required = True)");
338 Write_Str (" (Required = False)");
343 if Uname_Actual /= Load_Name then
344 Write_Str ("*** Actual unit loaded: ");
345 Write_Unit_Name (Uname_Actual);
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
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));
365 Main_Unit_Name : constant String := Name_Buffer (1 .. Name_Len);
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
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.
387 if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
389 Nkind (Unit (Cunit (Get_Source_Unit (Error_Node)))) =
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)
398 Load_Msg_Sloc := Sloc (Error_Node);
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);
410 Calling_Unit := No_Unit;
413 -- See if we already have an entry for this unit
417 while Unum <= Units.Last loop
418 exit when Uname_Actual = Units.Table (Unum).Unit_Name;
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
438 Write_Str (" file does not contain unit, Unit_Number = ");
439 Write_Int (Int (Unum));
444 if Present (Error_Node) then
445 if Is_Predefined_File_Name (Fname) then
446 Error_Msg_Name_1 := Uname_Actual;
448 ("% is not a language defined unit", Load_Msg_Sloc);
450 Error_Msg_Name_1 := Fname;
451 Error_Msg_Unit_1 := Uname_Actual;
453 ("File{ does not contain unit$", Load_Msg_Sloc);
456 Write_Dependency_Chain;
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.
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))
493 Write_Str (" circular dependency encountered");
497 if Present (Error_Node) then
498 Error_Msg ("circular unit dependency", Load_Msg_Sloc);
499 Write_Dependency_Chain;
501 Load_Stack.Decrement_Last;
508 Write_Str (" unit already in file table, Unit_Number = ");
509 Write_Int (Int (Unum));
513 Load_Stack.Decrement_Last;
516 -- Unit is not already in table, so try to open the file
520 Write_Str (" attempt unit load, Unit_Number = ");
521 Write_Int (Int (Unum));
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;
535 if Src_Ind /= No_Source_File then
536 Units.Table (Unum) := (
538 Cunit_Entity => Empty,
540 Dynamic_Elab => False,
541 Error_Location => Sloc (Error_Node),
542 Expected_Unit => Uname_Actual,
543 Fatal_Error => False,
544 Generate_Code => False,
546 Ident_String => Empty,
548 Main_Priority => Default_Main_Priority,
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
559 Save_Index : constant Nat := Multiple_Unit_Index;
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);
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)
574 Error_Msg_Name_1 := Unit_File_Name (Corr_Body);
576 ("cannot compile subprogram in file {!",
578 Error_Msg_Name_1 := Unit_File_Name (Unum);
580 ("incorrect spec in file { must be removed first!",
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)
590 Units.Table (Calling_Unit).Fatal_Error := True;
593 -- Remove load stack entry and return the entry in the file table
595 Load_Stack.Decrement_Last;
598 -- Case of file not found
602 Write_Str (" file was not found, load failed");
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;
613 ("% is not a predefined library unit", Load_Msg_Sloc);
616 Error_Msg_Name_1 := Fname;
617 Error_Msg ("file{ not found", Load_Msg_Sloc);
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,
632 Load_Stack.Decrement_Last;
633 Units.Decrement_Last;
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);
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);
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
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;
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);
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));
707 ----------------------------
708 -- Write_Dependency_Chain --
709 ----------------------------
711 procedure Write_Dependency_Chain is
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);
724 end Write_Dependency_Chain;