PR c++/3637
[official-gcc.git] / gcc / ada / lib-load.adb
blobb1f18d5f41e7b440633cb7de0466ac48b986276d
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- L I B . L O A D --
6 -- --
7 -- B o d y --
8 -- --
9 -- $Revision: 1.86 $
10 -- --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
23 -- --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 -- --
27 ------------------------------------------------------------------------------
29 with Atree; use Atree;
30 with Debug; use Debug;
31 with Errout; use Errout;
32 with Fname; use Fname;
33 with Fname.UF; use Fname.UF;
34 with Namet; use Namet;
35 with Nlists; use Nlists;
36 with Nmake; use Nmake;
37 with Opt; use Opt;
38 with Osint; use Osint;
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 Tbuild; use Tbuild;
46 with Uname; use Uname;
48 package body Lib.Load is
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
54 function Spec_Is_Irrelevant
55 (Spec_Unit : Unit_Number_Type;
56 Body_Unit : Unit_Number_Type)
57 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)
75 return Unit_Number_Type
77 Unum : Unit_Number_Type;
78 Cunit_Entity : Entity_Id;
79 Cunit : Node_Id;
80 Du_Name : Node_Or_Entity_Id;
81 End_Lab : Node_Id;
82 Save_CS : constant Boolean := Get_Comes_From_Source_Default;
84 begin
85 -- The created dummy package unit does not come from source
87 Set_Comes_From_Source_Default (False);
89 -- Normal package
91 if Nkind (Name (With_Node)) = N_Identifier then
92 Cunit_Entity :=
93 Make_Defining_Identifier (No_Location,
94 Chars => Chars (Name (With_Node)));
95 Du_Name := Cunit_Entity;
96 End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location);
98 -- Child package
100 else -- Nkind (Name (With_Node)) = N_Expanded_Name
101 Cunit_Entity :=
102 Make_Defining_Identifier (No_Location,
103 Chars => Chars (Selector_Name (Name (With_Node))));
104 Du_Name :=
105 Make_Defining_Program_Unit_Name (No_Location,
106 Name => New_Copy_Tree (Prefix (Name (With_Node))),
107 Defining_Identifier => Cunit_Entity);
108 End_Lab :=
109 Make_Designator (No_Location,
110 Name => New_Copy_Tree (Prefix (Name (With_Node))),
111 Identifier => New_Occurrence_Of (Cunit_Entity, No_Location));
112 end if;
114 Cunit :=
115 Make_Compilation_Unit (No_Location,
116 Context_Items => Empty_List,
117 Unit =>
118 Make_Package_Declaration (No_Location,
119 Specification =>
120 Make_Package_Specification (No_Location,
121 Defining_Unit_Name => Du_Name,
122 Visible_Declarations => Empty_List,
123 End_Label => End_Lab)),
124 Aux_Decls_Node =>
125 Make_Compilation_Unit_Aux (No_Location));
127 Units.Increment_Last;
128 Unum := Units.Last;
130 Units.Table (Unum) := (
131 Cunit => Cunit,
132 Cunit_Entity => Cunit_Entity,
133 Dependency_Num => 0,
134 Dependent_Unit => False,
135 Dynamic_Elab => False,
136 Error_Location => Sloc (With_Node),
137 Expected_Unit => Spec_Name,
138 Fatal_Error => True,
139 Generate_Code => False,
140 Has_RACW => False,
141 Ident_String => Empty,
142 Loading => False,
143 Main_Priority => Default_Main_Priority,
144 Serial_Number => 0,
145 Source_Index => No_Source_File,
146 Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False),
147 Unit_Name => Spec_Name,
148 Version => 0);
150 Set_Comes_From_Source_Default (Save_CS);
151 Set_Error_Posted (Cunit_Entity);
152 Set_Error_Posted (Cunit);
153 return Unum;
154 end Create_Dummy_Package_Unit;
156 ----------------
157 -- Initialize --
158 ----------------
160 procedure Initialize is
161 Fname : File_Name_Type;
163 begin
164 Units.Init;
165 Load_Stack.Init;
166 Load_Stack.Increment_Last;
167 Load_Stack.Table (Load_Stack.Last) := Main_Unit;
169 -- Initialize unit table entry for Main_Unit. Note that we don't know
170 -- the unit name yet, that gets filled in when the parser parses the
171 -- main unit, at which time a check is made that it matches the main
172 -- file name, and then the Unit_Name field is set. The Cunit and
173 -- Cunit_Entity fields also get filled in later by the parser.
175 Units.Increment_Last;
176 Fname := Next_Main_Source;
178 Units.Table (Main_Unit).Unit_File_Name := Fname;
180 if Fname /= No_File then
182 Main_Source_File := Load_Source_File (Fname);
183 Current_Error_Source_File := Main_Source_File;
185 Units.Table (Main_Unit) := (
186 Cunit => Empty,
187 Cunit_Entity => Empty,
188 Dependency_Num => 0,
189 Dependent_Unit => True,
190 Dynamic_Elab => False,
191 Error_Location => No_Location,
192 Expected_Unit => No_Name,
193 Fatal_Error => False,
194 Generate_Code => False,
195 Has_RACW => False,
196 Loading => True,
197 Ident_String => Empty,
198 Main_Priority => Default_Main_Priority,
199 Serial_Number => 0,
200 Source_Index => Main_Source_File,
201 Unit_File_Name => Fname,
202 Unit_Name => No_Name,
203 Version => Source_Checksum (Main_Source_File));
204 end if;
205 end Initialize;
207 ------------------------
208 -- Initialize_Version --
209 ------------------------
211 procedure Initialize_Version (U : Unit_Number_Type) is
212 begin
213 Units.Table (U).Version := Source_Checksum (Source_Index (U));
214 end Initialize_Version;
216 ---------------
217 -- Load_Unit --
218 ---------------
220 function Load_Unit
221 (Load_Name : Unit_Name_Type;
222 Required : Boolean;
223 Error_Node : Node_Id;
224 Subunit : Boolean;
225 Corr_Body : Unit_Number_Type := No_Unit;
226 Renamings : Boolean := False)
227 return Unit_Number_Type
229 Calling_Unit : Unit_Number_Type;
230 Uname_Actual : Unit_Name_Type;
231 Unum : Unit_Number_Type;
232 Unump : Unit_Number_Type;
233 Fname : File_Name_Type;
234 Src_Ind : Source_File_Index;
235 Discard : List_Id;
237 procedure Set_Load_Unit_Dependency (U : Unit_Number_Type);
238 -- Sets the Dependent_Unit flag unless we have a predefined unit
239 -- being loaded in No_Run_Time mode. In this case we do not want
240 -- to create a dependency, since we have loaded the unit only
241 -- to inline stuff from it. If this is not the case, an error
242 -- message will be issued in Rtsfind in any case.
244 procedure Set_Load_Unit_Dependency (U : Unit_Number_Type) is
245 begin
246 if No_Run_Time
247 and then Is_Internal_File_Name (Unit_File_Name (U))
248 then
249 null;
250 else
251 Units.Table (U).Dependent_Unit := True;
252 end if;
253 end Set_Load_Unit_Dependency;
255 -- Start of processing for Load_Unit
257 begin
258 -- If renamings are allowed and we have a child unit name, then we
259 -- must first load the parent to deal with finding the real name.
261 if Renamings and then Is_Child_Name (Load_Name) then
262 Unump :=
263 Load_Unit
264 (Load_Name => Get_Parent_Spec_Name (Load_Name),
265 Required => Required,
266 Subunit => False,
267 Renamings => True,
268 Error_Node => Error_Node);
270 if Unump = No_Unit then
271 return No_Unit;
272 end if;
274 -- If parent is a renaming, then we use the renamed package as
275 -- the actual parent for the subsequent load operation.
277 if Nkind (Parent (Cunit_Entity (Unump))) =
278 N_Package_Renaming_Declaration
279 then
280 Uname_Actual :=
281 New_Child
282 (Load_Name,
283 Get_Unit_Name (Name (Parent (Cunit_Entity (Unump)))));
285 -- Save the renaming entity, to establish its visibility when
286 -- installing the context. The implicit with is on this entity,
287 -- not on the package it renames.
289 if Nkind (Error_Node) = N_With_Clause
290 and then Nkind (Name (Error_Node)) = N_Selected_Component
291 then
292 declare
293 Par : Node_Id := Name (Error_Node);
295 begin
296 while Nkind (Par) = N_Selected_Component
297 and then Chars (Selector_Name (Par)) /=
298 Chars (Cunit_Entity (Unump))
299 loop
300 Par := Prefix (Par);
301 end loop;
303 if Nkind (Par) = N_Selected_Component then
304 -- some intermediate parent is a renaming.
306 Set_Entity (Selector_Name (Par), Cunit_Entity (Unump));
308 else
309 -- the ultimate parent is a renaming.
311 Set_Entity (Par, Cunit_Entity (Unump));
312 end if;
313 end;
314 end if;
316 -- If the parent is not a renaming, then get its name (this may
317 -- be different from the parent spec name obtained above because
318 -- of renamings higher up in the hierarchy).
320 else
321 Uname_Actual := New_Child (Load_Name, Unit_Name (Unump));
322 end if;
324 -- Here if unit to be loaded is not a child unit
326 else
327 Uname_Actual := Load_Name;
328 end if;
330 Fname := Get_File_Name (Uname_Actual, Subunit);
332 if Debug_Flag_L then
333 Write_Eol;
334 Write_Str ("*** Load request for unit: ");
335 Write_Unit_Name (Load_Name);
337 if Required then
338 Write_Str (" (Required = True)");
339 else
340 Write_Str (" (Required = False)");
341 end if;
343 Write_Eol;
345 if Uname_Actual /= Load_Name then
346 Write_Str ("*** Actual unit loaded: ");
347 Write_Unit_Name (Uname_Actual);
348 end if;
349 end if;
351 -- Capture error location if it is for the main unit. The idea is to
352 -- post errors on the main unit location, not the most recent unit.
354 if Present (Error_Node) 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 if Unum > Units.Last then
432 for J in Units.First .. Units.Last loop
433 if Fname = Units.Table (J).Unit_File_Name then
434 if Debug_Flag_L then
435 Write_Str (" file does not contain unit, Unit_Number = ");
436 Write_Int (Int (Unum));
437 Write_Eol;
438 Write_Eol;
439 end if;
441 if Present (Error_Node) then
443 if Is_Predefined_File_Name (Fname) then
444 Error_Msg_Name_1 := Uname_Actual;
445 Error_Msg
446 ("% is not a language defined unit", Load_Msg_Sloc);
447 else
448 Error_Msg_Name_1 := Fname;
449 Error_Msg_Unit_1 := Uname_Actual;
450 Error_Msg
451 ("File{ does not contain unit$", Load_Msg_Sloc);
452 end if;
454 Write_Dependency_Chain;
455 return No_Unit;
457 else
458 return No_Unit;
459 end if;
460 end if;
461 end loop;
462 end if;
464 -- If we are proceeding with load, then make load stack entry
466 Load_Stack.Increment_Last;
467 Load_Stack.Table (Load_Stack.Last) := Unum;
469 -- Case of entry already in table
471 if Unum <= Units.Last then
473 -- Here is where we check for a circular dependency, which is
474 -- an attempt to load a unit which is currently in the process
475 -- of being loaded. We do *not* care about a circular chain that
476 -- leads back to a body, because this kind of circular dependence
477 -- legitimately occurs (e.g. two package bodies that contain
478 -- inlined subprogram referenced by the other).
480 if Loading (Unum)
481 and then (Is_Spec_Name (Units.Table (Unum).Unit_Name)
482 or else Acts_As_Spec (Units.Table (Unum).Cunit))
483 then
484 if Debug_Flag_L then
485 Write_Str (" circular dependency encountered");
486 Write_Eol;
487 end if;
489 if Present (Error_Node) then
490 Error_Msg ("circular unit dependency", Load_Msg_Sloc);
491 Write_Dependency_Chain;
492 else
493 Load_Stack.Decrement_Last;
494 end if;
496 return No_Unit;
497 end if;
499 if Debug_Flag_L then
500 Write_Str (" unit already in file table, Unit_Number = ");
501 Write_Int (Int (Unum));
502 Write_Eol;
503 end if;
505 Load_Stack.Decrement_Last;
506 Set_Load_Unit_Dependency (Unum);
507 return Unum;
509 -- File is not already in table, so try to open it
511 else
512 if Debug_Flag_L then
513 Write_Str (" attempt unit load, Unit_Number = ");
514 Write_Int (Int (Unum));
515 Write_Eol;
516 end if;
518 Src_Ind := Load_Source_File (Fname);
520 -- Make a partial entry in the file table, used even in the file not
521 -- found case to print the dependency chain including the last entry
523 Units.Increment_Last;
524 Units.Table (Unum).Unit_Name := Uname_Actual;
526 -- File was found
528 if Src_Ind /= No_Source_File then
529 Units.Table (Unum) := (
530 Cunit => Empty,
531 Cunit_Entity => Empty,
532 Dependency_Num => 0,
533 Dependent_Unit => False,
534 Dynamic_Elab => False,
535 Error_Location => Sloc (Error_Node),
536 Expected_Unit => Uname_Actual,
537 Fatal_Error => False,
538 Generate_Code => False,
539 Has_RACW => False,
540 Ident_String => Empty,
541 Loading => True,
542 Main_Priority => Default_Main_Priority,
543 Serial_Number => 0,
544 Source_Index => Src_Ind,
545 Unit_File_Name => Fname,
546 Unit_Name => Uname_Actual,
547 Version => Source_Checksum (Src_Ind));
549 -- Parse the new unit
551 Initialize_Scanner (Unum, Source_Index (Unum));
552 Discard := Par (Configuration_Pragmas => False);
553 Set_Loading (Unum, False);
555 -- If spec is irrelevant, then post errors and quit
557 if Corr_Body /= No_Unit
558 and then Spec_Is_Irrelevant (Unum, Corr_Body)
559 then
560 Error_Msg_Name_1 := Unit_File_Name (Corr_Body);
561 Error_Msg
562 ("cannot compile subprogram in file {!",
563 Load_Msg_Sloc);
564 Error_Msg_Name_1 := Unit_File_Name (Unum);
565 Error_Msg
566 ("incorrect spec in file { must be removed first!",
567 Load_Msg_Sloc);
568 return No_Unit;
569 end if;
571 -- If loaded unit had a fatal error, then caller inherits it!
573 if Units.Table (Unum).Fatal_Error
574 and then Present (Error_Node)
575 then
576 Units.Table (Calling_Unit).Fatal_Error := True;
577 end if;
579 -- Remove load stack entry and return the entry in the file table
581 Load_Stack.Decrement_Last;
582 Set_Load_Unit_Dependency (Unum);
583 return Unum;
585 -- Case of file not found
587 else
588 if Debug_Flag_L then
589 Write_Str (" file was not found, load failed");
590 Write_Eol;
591 end if;
593 -- Generate message if unit required
595 if Required and then Present (Error_Node) then
597 if Is_Predefined_File_Name (Fname) then
598 Error_Msg_Name_1 := Uname_Actual;
599 Error_Msg
600 ("% is not a predefined library unit", Load_Msg_Sloc);
602 else
603 Error_Msg_Name_1 := Fname;
604 Error_Msg ("file{ not found", Load_Msg_Sloc);
605 end if;
607 Write_Dependency_Chain;
609 -- Remove unit from stack, to avoid cascaded errors on
610 -- subsequent missing files.
612 Load_Stack.Decrement_Last;
613 Units.Decrement_Last;
615 -- If unit not required, remove load stack entry and the junk
616 -- file table entry, and return No_Unit to indicate not found,
618 else
619 Load_Stack.Decrement_Last;
620 Units.Decrement_Last;
621 end if;
623 return No_Unit;
624 end if;
625 end if;
626 end Load_Unit;
628 ------------------------
629 -- Make_Instance_Unit --
630 ------------------------
632 -- If the unit is an instance, it appears as a package declaration, but
633 -- contains both declaration and body of the instance. The body becomes
634 -- the main unit of the compilation, and the declaration is inserted
635 -- at the end of the unit table. The main unit now has the name of a
636 -- body, which is constructed from the name of the original spec,
637 -- and is attached to the compilation node of the original unit. The
638 -- declaration has been attached to a new compilation unit node, and
639 -- code will have to be generated for it.
641 procedure Make_Instance_Unit (N : Node_Id) is
642 Sind : constant Source_File_Index := Source_Index (Main_Unit);
644 begin
645 Units.Increment_Last;
647 Units.Table (Units.Last) := Units.Table (Main_Unit);
648 Units.Table (Units.Last).Cunit := Library_Unit (N);
649 Units.Table (Units.Last).Generate_Code := True;
651 Units.Table (Main_Unit).Cunit := N;
652 Units.Table (Main_Unit).Unit_Name :=
653 Get_Body_Name (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N))));
654 Units.Table (Main_Unit).Version := Source_Checksum (Sind);
655 end Make_Instance_Unit;
657 ------------------------
658 -- Spec_Is_Irrelevant --
659 ------------------------
661 function Spec_Is_Irrelevant
662 (Spec_Unit : Unit_Number_Type;
663 Body_Unit : Unit_Number_Type)
664 return Boolean
666 Sunit : constant Node_Id := Cunit (Spec_Unit);
667 Bunit : constant Node_Id := Cunit (Body_Unit);
669 begin
670 -- The spec is irrelevant if the body is a subprogram body, and the
671 -- spec is other than a subprogram spec or generic subprogram spec.
672 -- Note that the names must be the same, we don't need to check that,
673 -- because we already know that from the fact that the file names are
674 -- the same.
676 return
677 Nkind (Unit (Bunit)) = N_Subprogram_Body
678 and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration
679 and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration;
681 end Spec_Is_Irrelevant;
683 --------------------
684 -- Version_Update --
685 --------------------
687 procedure Version_Update (U : Node_Id; From : Node_Id) is
688 Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (U);
689 Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From);
691 begin
692 Units.Table (Unum).Version :=
693 Units.Table (Unum).Version
695 Source_Checksum (Source_Index (Fnum));
696 end Version_Update;
698 ----------------------------
699 -- Write_Dependency_Chain --
700 ----------------------------
702 procedure Write_Dependency_Chain is
703 begin
704 -- The dependency chain is only written if it is at least two entries
705 -- deep, otherwise it is trivial (the main unit depending on a unit
706 -- that it obviously directly depends on).
708 if Load_Stack.Last - 1 > Load_Stack.First then
709 for U in Load_Stack.First .. Load_Stack.Last - 1 loop
710 Error_Msg_Unit_1 := Unit_Name (Load_Stack.Table (U));
711 Error_Msg_Unit_2 := Unit_Name (Load_Stack.Table (U + 1));
712 Error_Msg ("$ depends on $!", Load_Msg_Sloc);
713 end loop;
714 end if;
715 end Write_Dependency_Chain;
717 end Lib.Load;