1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2003 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 Targparm; use Targparm;
47 with Tbuild; use Tbuild;
48 with Uname; use Uname;
50 package body Lib.Load is
52 -----------------------
53 -- Local Subprograms --
54 -----------------------
56 function Spec_Is_Irrelevant
57 (Spec_Unit : Unit_Number_Type;
58 Body_Unit : Unit_Number_Type)
60 -- The Spec_Unit and Body_Unit parameters are the unit numbers of the
61 -- spec file that corresponds to the main unit which is a body. This
62 -- function determines if the spec file is irrelevant and will be
63 -- overridden by the body as described in RM 10.1.4(4). See description
64 -- in "Special Handling of Subprogram Bodies" for further details.
66 procedure Write_Dependency_Chain;
67 -- This procedure is used to generate error message info lines that
68 -- trace the current dependency chain when a load error occurs.
70 -------------------------------
71 -- Create_Dummy_Package_Unit --
72 -------------------------------
74 function Create_Dummy_Package_Unit
76 Spec_Name : Unit_Name_Type)
77 return Unit_Number_Type
79 Unum : Unit_Number_Type;
80 Cunit_Entity : Entity_Id;
81 Scope_Entity : Entity_Id;
83 Du_Name : Node_Or_Entity_Id;
85 Save_CS : constant Boolean := Get_Comes_From_Source_Default;
88 -- The created dummy package unit does not come from source
90 Set_Comes_From_Source_Default (False);
94 if Nkind (Name (With_Node)) = N_Identifier then
96 Make_Defining_Identifier (No_Location,
97 Chars => Chars (Name (With_Node)));
98 Du_Name := Cunit_Entity;
99 End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location);
101 Scope_Entity := Standard_Standard;
105 else -- Nkind (Name (With_Node)) = N_Expanded_Name
107 Make_Defining_Identifier (No_Location,
108 Chars => Chars (Selector_Name (Name (With_Node))));
110 Make_Defining_Program_Unit_Name (No_Location,
111 Name => New_Copy_Tree (Prefix (Name (With_Node))),
112 Defining_Identifier => Cunit_Entity);
114 Set_Is_Child_Unit (Cunit_Entity);
116 if Nkind (Du_Name) = N_Defining_Program_Unit_Name then
117 Scope_Entity := Defining_Identifier (Du_Name);
119 Scope_Entity := Du_Name;
123 Make_Designator (No_Location,
124 Name => New_Copy_Tree (Prefix (Name (With_Node))),
125 Identifier => New_Occurrence_Of (Cunit_Entity, No_Location));
128 Set_Scope (Cunit_Entity, Scope_Entity);
131 Make_Compilation_Unit (No_Location,
132 Context_Items => Empty_List,
134 Make_Package_Declaration (No_Location,
136 Make_Package_Specification (No_Location,
137 Defining_Unit_Name => Du_Name,
138 Visible_Declarations => Empty_List,
139 End_Label => End_Lab)),
141 Make_Compilation_Unit_Aux (No_Location));
143 -- Mark the dummy package as analyzed to prevent analysis of this
144 -- (non-existent) unit in -gnatQ mode because at the moment the
145 -- structure and attributes of this dummy package does not allow
146 -- a normal analysis of this unit
148 Set_Analyzed (Cunit);
150 Units.Increment_Last;
153 Units.Table (Unum) := (
155 Cunit_Entity => Cunit_Entity,
157 Dependent_Unit => False,
158 Dynamic_Elab => False,
159 Error_Location => Sloc (With_Node),
160 Expected_Unit => Spec_Name,
162 Generate_Code => False,
164 Ident_String => Empty,
166 Main_Priority => Default_Main_Priority,
168 Source_Index => No_Source_File,
169 Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False),
170 Unit_Name => Spec_Name,
173 Set_Comes_From_Source_Default (Save_CS);
174 Set_Error_Posted (Cunit_Entity);
175 Set_Error_Posted (Cunit);
177 end Create_Dummy_Package_Unit;
183 procedure Initialize is
189 ------------------------
190 -- Initialize_Version --
191 ------------------------
193 procedure Initialize_Version (U : Unit_Number_Type) is
195 Units.Table (U).Version := Source_Checksum (Source_Index (U));
196 end Initialize_Version;
198 ----------------------
199 -- Load_Main_Source --
200 ----------------------
202 procedure Load_Main_Source is
203 Fname : File_Name_Type;
206 Load_Stack.Increment_Last;
207 Load_Stack.Table (Load_Stack.Last) := Main_Unit;
209 -- Initialize unit table entry for Main_Unit. Note that we don't know
210 -- the unit name yet, that gets filled in when the parser parses the
211 -- main unit, at which time a check is made that it matches the main
212 -- file name, and then the Unit_Name field is set. The Cunit and
213 -- Cunit_Entity fields also get filled in later by the parser.
215 Units.Increment_Last;
216 Fname := Next_Main_Source;
218 Units.Table (Main_Unit).Unit_File_Name := Fname;
220 if Fname /= No_File then
222 Main_Source_File := Load_Source_File (Fname);
223 Current_Error_Source_File := Main_Source_File;
225 Units.Table (Main_Unit) := (
227 Cunit_Entity => Empty,
229 Dependent_Unit => True,
230 Dynamic_Elab => False,
231 Error_Location => No_Location,
232 Expected_Unit => No_Name,
233 Fatal_Error => False,
234 Generate_Code => False,
237 Ident_String => Empty,
238 Main_Priority => Default_Main_Priority,
240 Source_Index => Main_Source_File,
241 Unit_File_Name => Fname,
242 Unit_Name => No_Name,
243 Version => Source_Checksum (Main_Source_File));
245 end Load_Main_Source;
252 (Load_Name : Unit_Name_Type;
254 Error_Node : Node_Id;
256 Corr_Body : Unit_Number_Type := No_Unit;
257 Renamings : Boolean := False)
258 return Unit_Number_Type
260 Calling_Unit : Unit_Number_Type;
261 Uname_Actual : Unit_Name_Type;
262 Unum : Unit_Number_Type;
263 Unump : Unit_Number_Type;
264 Fname : File_Name_Type;
265 Src_Ind : Source_File_Index;
267 procedure Set_Load_Unit_Dependency (U : Unit_Number_Type);
268 -- Sets the Dependent_Unit flag unless we have a predefined unit
269 -- being loaded in High_Integrity_Mode. In this case we do not want
270 -- to create a dependency, since we have loaded the unit only
271 -- to inline stuff from it. If this is not the case, an error
272 -- message will be issued in Rtsfind in any case.
274 ------------------------------
275 -- Set_Load_Unit_Dependency --
276 ------------------------------
278 procedure Set_Load_Unit_Dependency (U : Unit_Number_Type) is
280 -- Differentiate between pragma No_Run_Time mode (that can be
281 -- used with a standard installation), and HI-E mode which comes
282 -- with a special installation.
284 -- For Configurable_Run_Time_Mode set by a pragma, we do not want to
285 -- create a dependency since the binder would generate references to
286 -- these units. In the case of configurable run-time, we do want to
287 -- establish this dependency.
289 if Configurable_Run_Time_Mode
290 and then not Configurable_Run_Time_On_Target
291 and then not Debug_Flag_YY
292 and then Is_Internal_File_Name (Unit_File_Name (U))
296 Units.Table (U).Dependent_Unit := True;
298 end Set_Load_Unit_Dependency;
300 -- Start of processing for Load_Unit
303 -- If renamings are allowed and we have a child unit name, then we
304 -- must first load the parent to deal with finding the real name.
306 if Renamings and then Is_Child_Name (Load_Name) then
309 (Load_Name => Get_Parent_Spec_Name (Load_Name),
310 Required => Required,
313 Error_Node => Error_Node);
315 if Unump = No_Unit then
319 -- If parent is a renaming, then we use the renamed package as
320 -- the actual parent for the subsequent load operation.
322 if Nkind (Parent (Cunit_Entity (Unump))) =
323 N_Package_Renaming_Declaration
328 Get_Unit_Name (Name (Parent (Cunit_Entity (Unump)))));
330 -- Save the renaming entity, to establish its visibility when
331 -- installing the context. The implicit with is on this entity,
332 -- not on the package it renames.
334 if Nkind (Error_Node) = N_With_Clause
335 and then Nkind (Name (Error_Node)) = N_Selected_Component
338 Par : Node_Id := Name (Error_Node);
341 while Nkind (Par) = N_Selected_Component
342 and then Chars (Selector_Name (Par)) /=
343 Chars (Cunit_Entity (Unump))
348 if Nkind (Par) = N_Selected_Component then
349 -- some intermediate parent is a renaming.
351 Set_Entity (Selector_Name (Par), Cunit_Entity (Unump));
354 -- the ultimate parent is a renaming.
356 Set_Entity (Par, Cunit_Entity (Unump));
361 -- If the parent is not a renaming, then get its name (this may
362 -- be different from the parent spec name obtained above because
363 -- of renamings higher up in the hierarchy).
366 Uname_Actual := New_Child (Load_Name, Unit_Name (Unump));
369 -- Here if unit to be loaded is not a child unit
372 Uname_Actual := Load_Name;
375 Fname := Get_File_Name (Uname_Actual, Subunit);
379 Write_Str ("*** Load request for unit: ");
380 Write_Unit_Name (Load_Name);
383 Write_Str (" (Required = True)");
385 Write_Str (" (Required = False)");
390 if Uname_Actual /= Load_Name then
391 Write_Str ("*** Actual unit loaded: ");
392 Write_Unit_Name (Uname_Actual);
396 -- Capture error location if it is for the main unit. The idea is to
397 -- post errors on the main unit location, not the most recent unit.
398 -- Note: Unit_Name (Main_Unit) is not set if we are parsing gnat.adc.
400 if Present (Error_Node)
401 and then Unit_Name (Main_Unit) /= No_Name
403 -- It seems like In_Extended_Main_Source_Unit (Error_Node) would
404 -- do the trick here, but that's wrong, it is much too early to
405 -- call this routine. We are still in the parser, and the required
406 -- semantic information is not established yet. So we base the
407 -- judgment on unit names.
409 Get_External_Unit_Name_String (Unit_Name (Main_Unit));
412 Main_Unit_Name : constant String := Name_Buffer (1 .. Name_Len);
415 Get_External_Unit_Name_String
416 (Unit_Name (Get_Source_Unit (Error_Node)));
418 -- If the two names are identical, then for sure we are part
419 -- of the extended main unit
421 if Main_Unit_Name = Name_Buffer (1 .. Name_Len) then
422 Load_Msg_Sloc := Sloc (Error_Node);
424 -- If the load is called from a with_type clause, the error
427 elsif Nkind (Parent (Error_Node)) = N_With_Type_Clause then
428 Load_Msg_Sloc := Sloc (Error_Node);
430 -- Otherwise, check for the subunit case, and if so, consider
431 -- we have a match if one name is a prefix of the other name.
434 if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
436 Nkind (Unit (Cunit (Get_Source_Unit (Error_Node)))) =
439 Name_Len := Integer'Min (Name_Len, Main_Unit_Name'Length);
441 if Name_Buffer (1 .. Name_Len)
443 Main_Unit_Name (1 .. Name_Len)
445 Load_Msg_Sloc := Sloc (Error_Node);
452 -- If we are generating error messages, then capture calling unit
454 if Present (Error_Node) then
455 Calling_Unit := Get_Source_Unit (Error_Node);
457 Calling_Unit := No_Unit;
460 -- See if we already have an entry for this unit
464 while Unum <= Units.Last loop
465 exit when Uname_Actual = Units.Table (Unum).Unit_Name;
469 -- Whether or not the entry was found, Unum is now the right value,
470 -- since it is one more than Units.Last (i.e. the index of the new
471 -- entry we will create) in the not found case.
473 -- A special check is necessary in the unit not found case. If the unit
474 -- is not found, but the file in which it lives has already been loaded,
475 -- then we have the problem that the file does not contain the unit that
476 -- is needed. We simply treat this as a file not found condition.
478 if Unum > Units.Last then
479 for J in Units.First .. Units.Last loop
480 if Fname = Units.Table (J).Unit_File_Name then
482 Write_Str (" file does not contain unit, Unit_Number = ");
483 Write_Int (Int (Unum));
488 if Present (Error_Node) then
490 if Is_Predefined_File_Name (Fname) then
491 Error_Msg_Name_1 := Uname_Actual;
493 ("% is not a language defined unit", Load_Msg_Sloc);
495 Error_Msg_Name_1 := Fname;
496 Error_Msg_Unit_1 := Uname_Actual;
498 ("File{ does not contain unit$", Load_Msg_Sloc);
501 Write_Dependency_Chain;
511 -- If we are proceeding with load, then make load stack entry
513 Load_Stack.Increment_Last;
514 Load_Stack.Table (Load_Stack.Last) := Unum;
516 -- Case of entry already in table
518 if Unum <= Units.Last then
520 -- Here is where we check for a circular dependency, which is
521 -- an attempt to load a unit which is currently in the process
522 -- of being loaded. We do *not* care about a circular chain that
523 -- leads back to a body, because this kind of circular dependence
524 -- legitimately occurs (e.g. two package bodies that contain
525 -- inlined subprogram referenced by the other).
527 -- We also ignore limited_with clauses, because their purpose is
528 -- precisely to create legal circular structures.
531 and then (Is_Spec_Name (Units.Table (Unum).Unit_Name)
532 or else Acts_As_Spec (Units.Table (Unum).Cunit))
533 and then (Nkind (Error_Node) /= N_With_Clause
534 or else not Limited_Present (Error_Node))
538 Write_Str (" circular dependency encountered");
542 if Present (Error_Node) then
543 Error_Msg ("circular unit dependency", Load_Msg_Sloc);
544 Write_Dependency_Chain;
546 Load_Stack.Decrement_Last;
553 Write_Str (" unit already in file table, Unit_Number = ");
554 Write_Int (Int (Unum));
558 Load_Stack.Decrement_Last;
559 Set_Load_Unit_Dependency (Unum);
562 -- File is not already in table, so try to open it
566 Write_Str (" attempt unit load, Unit_Number = ");
567 Write_Int (Int (Unum));
571 Src_Ind := Load_Source_File (Fname);
573 -- Make a partial entry in the file table, used even in the file not
574 -- found case to print the dependency chain including the last entry
576 Units.Increment_Last;
577 Units.Table (Unum).Unit_Name := Uname_Actual;
581 if Src_Ind /= No_Source_File then
582 Units.Table (Unum) := (
584 Cunit_Entity => Empty,
586 Dependent_Unit => False,
587 Dynamic_Elab => False,
588 Error_Location => Sloc (Error_Node),
589 Expected_Unit => Uname_Actual,
590 Fatal_Error => False,
591 Generate_Code => False,
593 Ident_String => Empty,
595 Main_Priority => Default_Main_Priority,
597 Source_Index => Src_Ind,
598 Unit_File_Name => Fname,
599 Unit_Name => Uname_Actual,
600 Version => Source_Checksum (Src_Ind));
602 -- Parse the new unit
604 Initialize_Scanner (Unum, Source_Index (Unum));
605 Discard_List (Par (Configuration_Pragmas => False));
606 Set_Loading (Unum, False);
608 -- If spec is irrelevant, then post errors and quit
610 if Corr_Body /= No_Unit
611 and then Spec_Is_Irrelevant (Unum, Corr_Body)
613 Error_Msg_Name_1 := Unit_File_Name (Corr_Body);
615 ("cannot compile subprogram in file {!",
617 Error_Msg_Name_1 := Unit_File_Name (Unum);
619 ("incorrect spec in file { must be removed first!",
624 -- If loaded unit had a fatal error, then caller inherits it!
626 if Units.Table (Unum).Fatal_Error
627 and then Present (Error_Node)
629 Units.Table (Calling_Unit).Fatal_Error := True;
632 -- Remove load stack entry and return the entry in the file table
634 Load_Stack.Decrement_Last;
635 Set_Load_Unit_Dependency (Unum);
638 -- Case of file not found
642 Write_Str (" file was not found, load failed");
646 -- Generate message if unit required
648 if Required and then Present (Error_Node) then
650 if Is_Predefined_File_Name (Fname) then
651 Error_Msg_Name_1 := Uname_Actual;
653 ("% is not a predefined library unit", Load_Msg_Sloc);
656 Error_Msg_Name_1 := Fname;
657 Error_Msg ("file{ not found", Load_Msg_Sloc);
660 Write_Dependency_Chain;
662 -- Remove unit from stack, to avoid cascaded errors on
663 -- subsequent missing files.
665 Load_Stack.Decrement_Last;
666 Units.Decrement_Last;
668 -- If unit not required, remove load stack entry and the junk
669 -- file table entry, and return No_Unit to indicate not found,
672 Load_Stack.Decrement_Last;
673 Units.Decrement_Last;
681 ------------------------
682 -- Make_Instance_Unit --
683 ------------------------
685 -- If the unit is an instance, it appears as a package declaration, but
686 -- contains both declaration and body of the instance. The body becomes
687 -- the main unit of the compilation, and the declaration is inserted
688 -- at the end of the unit table. The main unit now has the name of a
689 -- body, which is constructed from the name of the original spec,
690 -- and is attached to the compilation node of the original unit. The
691 -- declaration has been attached to a new compilation unit node, and
692 -- code will have to be generated for it.
694 procedure Make_Instance_Unit (N : Node_Id) is
695 Sind : constant Source_File_Index := Source_Index (Main_Unit);
698 Units.Increment_Last;
700 Units.Table (Units.Last) := Units.Table (Main_Unit);
701 Units.Table (Units.Last).Cunit := Library_Unit (N);
702 Units.Table (Units.Last).Generate_Code := True;
704 Units.Table (Main_Unit).Cunit := N;
705 Units.Table (Main_Unit).Unit_Name :=
706 Get_Body_Name (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N))));
707 Units.Table (Main_Unit).Version := Source_Checksum (Sind);
708 end Make_Instance_Unit;
710 ------------------------
711 -- Spec_Is_Irrelevant --
712 ------------------------
714 function Spec_Is_Irrelevant
715 (Spec_Unit : Unit_Number_Type;
716 Body_Unit : Unit_Number_Type)
719 Sunit : constant Node_Id := Cunit (Spec_Unit);
720 Bunit : constant Node_Id := Cunit (Body_Unit);
723 -- The spec is irrelevant if the body is a subprogram body, and the
724 -- spec is other than a subprogram spec or generic subprogram spec.
725 -- Note that the names must be the same, we don't need to check that,
726 -- because we already know that from the fact that the file names are
730 Nkind (Unit (Bunit)) = N_Subprogram_Body
731 and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration
732 and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration;
734 end Spec_Is_Irrelevant;
740 procedure Version_Update (U : Node_Id; From : Node_Id) is
741 Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (U);
742 Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From);
746 if Source_Index (Fnum) /= No_Source_File then
747 Units.Table (Unum).Version :=
748 Units.Table (Unum).Version
750 Source_Checksum (Source_Index (Fnum));
754 ----------------------------
755 -- Write_Dependency_Chain --
756 ----------------------------
758 procedure Write_Dependency_Chain is
760 -- The dependency chain is only written if it is at least two entries
761 -- deep, otherwise it is trivial (the main unit depending on a unit
762 -- that it obviously directly depends on).
764 if Load_Stack.Last - 1 > Load_Stack.First then
765 for U in Load_Stack.First .. Load_Stack.Last - 1 loop
766 Error_Msg_Unit_1 := Unit_Name (Load_Stack.Table (U));
767 Error_Msg_Unit_2 := Unit_Name (Load_Stack.Table (U + 1));
768 Error_Msg ("$ depends on $!", Load_Msg_Sloc);
771 end Write_Dependency_Chain;