?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Fix date
[official-gcc.git] / gcc / ada / lib-load.adb
blobf509721c3986b859a76ec621ffffdff4e02603fe
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-2017, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Debug; use Debug;
28 with Einfo; use Einfo;
29 with Errout; use Errout;
30 with Fname; use Fname;
31 with Fname.UF; use Fname.UF;
32 with Nlists; use Nlists;
33 with Nmake; use Nmake;
34 with Opt; use Opt;
35 with Osint; use Osint;
36 with Osint.C; use Osint.C;
37 with Output; use Output;
38 with Par;
39 with Restrict; use Restrict;
40 with Scn; use Scn;
41 with Sinfo; use Sinfo;
42 with Sinput; use Sinput;
43 with Sinput.L; use Sinput.L;
44 with Stand; use Stand;
45 with Tbuild; use Tbuild;
46 with Uname; use Uname;
47
48 package body Lib.Load is
49
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
53
54 function From_Limited_With_Chain return Boolean;
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
59 function Spec_Is_Irrelevant
60 (Spec_Unit : Unit_Number_Type;
61 Body_Unit : Unit_Number_Type) return Boolean;
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
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
135 -------------------------------
136 -- Create_Dummy_Package_Unit --
137 -------------------------------
138
139 function Create_Dummy_Package_Unit
140 (With_Node : Node_Id;
141 Spec_Name : Unit_Name_Type) return Unit_Number_Type
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 Fname : constant File_Name_Type :=
149 Get_File_Name (Spec_Name, Subunit => False);
150 Pre_Name : constant Boolean :=
151 Is_Predefined_File_Name (Fname, Renamings_Included => False);
152 Ren_Name : constant Boolean :=
153 Is_Predefined_Renaming_File_Name (Fname);
154 GNAT_Name : constant Boolean :=
155 Is_GNAT_File_Name (Fname);
156 Save_CS : constant Boolean := Get_Comes_From_Source_Default;
157
158 begin
159 -- The created dummy package unit does not come from source
160
161 Set_Comes_From_Source_Default (False);
162
163 -- Normal package
164
165 if Nkind (Name (With_Node)) = N_Identifier then
166 Cunit_Entity :=
167 Make_Defining_Identifier (No_Location,
168 Chars => Chars (Name (With_Node)));
169 Du_Name := Cunit_Entity;
170 End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location);
171
172 -- Child package
173
174 else
175 Cunit_Entity :=
176 Make_Defining_Identifier (No_Location,
177 Chars => Chars (Selector_Name (Name (With_Node))));
178 Du_Name :=
179 Make_Defining_Program_Unit_Name (No_Location,
180 Name => Copy_Separate_Tree (Prefix (Name (With_Node))),
181 Defining_Identifier => Cunit_Entity);
182
183 Set_Is_Child_Unit (Cunit_Entity);
184
185 End_Lab :=
186 Make_Designator (No_Location,
187 Name => Copy_Separate_Tree (Prefix (Name (With_Node))),
188 Identifier => New_Occurrence_Of (Cunit_Entity, No_Location));
189 end if;
190
191 Set_Scope (Cunit_Entity, Standard_Standard);
192
193 Cunit :=
194 Make_Compilation_Unit (No_Location,
195 Context_Items => Empty_List,
196 Unit =>
197 Make_Package_Declaration (No_Location,
198 Specification =>
199 Make_Package_Specification (No_Location,
200 Defining_Unit_Name => Du_Name,
201 Visible_Declarations => Empty_List,
202 End_Label => End_Lab)),
203 Aux_Decls_Node =>
204 Make_Compilation_Unit_Aux (No_Location));
205
206 -- Mark the dummy package as analyzed to prevent analysis of this
207 -- (non-existent) unit in -gnatQ mode because at the moment the
208 -- structure and attributes of this dummy package does not allow
209 -- a normal analysis of this unit
210
211 Set_Analyzed (Cunit);
212
213 Units.Increment_Last;
214 Unum := Units.Last;
215
216 Units.Table (Unum) :=
217 (Cunit => Cunit,
218 Cunit_Entity => Cunit_Entity,
219 Dependency_Num => 0,
220 Dynamic_Elab => False,
221 Error_Location => Sloc (With_Node),
222 Expected_Unit => Spec_Name,
223 Fatal_Error => Error_Detected,
224 Generate_Code => False,
225 Has_RACW => False,
226 Filler => False,
227 Ident_String => Empty,
228
229 Is_Predefined_Renaming => Ren_Name,
230 Is_Predefined_Unit => Pre_Name or Ren_Name,
231 Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name,
232 Filler2 => False,
233
234 Loading => False,
235 Main_Priority => Default_Main_Priority,
236 Main_CPU => Default_Main_CPU,
237 Munit_Index => 0,
238 No_Elab_Code_All => False,
239 Serial_Number => 0,
240 Source_Index => No_Source_File,
241 Unit_File_Name => Fname,
242 Unit_Name => Spec_Name,
243 Version => 0,
244 OA_Setting => 'O');
245
246 Set_Comes_From_Source_Default (Save_CS);
247 Set_Error_Posted (Cunit_Entity);
248 Set_Error_Posted (Cunit);
249 return Unum;
250 end Create_Dummy_Package_Unit;
251
252 -----------------------------
253 -- From_Limited_With_Chain --
254 -----------------------------
255
256 function From_Limited_With_Chain return Boolean is
257 Curr_Num : constant Unit_Number_Type :=
258 Load_Stack.Table (Load_Stack.Last).Unit_Number;
259
260 begin
261 -- True if the current load operation is through a limited_with clause
262 -- and we are not within a loop of regular with_clauses.
263
264 for U in reverse Load_Stack.First .. Load_Stack.Last - 1 loop
265 if Load_Stack.Table (U).Unit_Number = Curr_Num then
266 return False;
267
268 elsif Present (Load_Stack.Table (U).With_Node)
269 and then Limited_Present (Load_Stack.Table (U).With_Node)
270 then
271 return True;
272 end if;
273 end loop;
274
275 return False;
276 end From_Limited_With_Chain;
277
278 ----------------
279 -- Initialize --
280 ----------------
281
282 procedure Initialize is
283 begin
284 Units.Init;
285 Load_Stack.Init;
286 end Initialize;
287
288 ------------------------
289 -- Initialize_Version --
290 ------------------------
291
292 procedure Initialize_Version (U : Unit_Number_Type) is
293 begin
294 Units.Table (U).Version := Source_Checksum (Source_Index (U));
295 end Initialize_Version;
296
297 ----------------------
298 -- Load_Main_Source --
299 ----------------------
300
301 procedure Load_Main_Source is
302 Fname : constant File_Name_Type := Next_Main_Source;
303 Pre_Name : constant Boolean :=
304 Is_Predefined_File_Name (Fname, Renamings_Included => False);
305 Ren_Name : constant Boolean :=
306 Is_Predefined_Renaming_File_Name (Fname);
307 GNAT_Name : constant Boolean :=
308 Is_GNAT_File_Name (Fname);
309 Version : Word := 0;
310
311 begin
312 Load_Stack.Increment_Last;
313 Load_Stack.Table (Load_Stack.Last) := (Main_Unit, Empty);
314
315 -- Initialize unit table entry for Main_Unit. Note that we don't know
316 -- the unit name yet, that gets filled in when the parser parses the
317 -- main unit, at which time a check is made that it matches the main
318 -- file name, and then the Unit_Name field is set. The Cunit and
319 -- Cunit_Entity fields also get filled in later by the parser.
320
321 Units.Increment_Last;
322
323 Units.Table (Main_Unit).Unit_File_Name := Fname;
324
325 if Fname /= No_File then
326 Main_Source_File := Load_Source_File (Fname);
327 Current_Error_Source_File := Main_Source_File;
328
329 if Main_Source_File /= No_Source_File then
330 Version := Source_Checksum (Main_Source_File);
331 else
332 -- To avoid emitting a source location (since there is no file),
333 -- we write a custom error message instead of using the machinery
334 -- in errout.adb.
335
336 Set_Standard_Error;
337 Write_Str ("file """ & Get_Name_String (Fname) & """ not found");
338 Write_Eol;
339 Set_Standard_Output;
340 end if;
341
342 Units.Table (Main_Unit) :=
343 (Cunit => Empty,
344 Cunit_Entity => Empty,
345 Dependency_Num => 0,
346 Dynamic_Elab => False,
347 Error_Location => No_Location,
348 Expected_Unit => No_Unit_Name,
349 Fatal_Error => None,
350 Generate_Code => False,
351 Has_RACW => False,
352 Filler => False,
353 Ident_String => Empty,
354
355 Is_Predefined_Renaming => Ren_Name,
356 Is_Predefined_Unit => Pre_Name or Ren_Name,
357 Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name,
358 Filler2 => False,
359
360 Loading => True,
361 Main_Priority => Default_Main_Priority,
362 Main_CPU => Default_Main_CPU,
363 Munit_Index => 0,
364 No_Elab_Code_All => False,
365 Serial_Number => 0,
366 Source_Index => Main_Source_File,
367 Unit_File_Name => Fname,
368 Unit_Name => No_Unit_Name,
369 Version => Version,
370 OA_Setting => 'O');
371 end if;
372 end Load_Main_Source;
373
374 ---------------
375 -- Load_Unit --
376 ---------------
377
378 function Load_Unit
379 (Load_Name : Unit_Name_Type;
380 Required : Boolean;
381 Error_Node : Node_Id;
382 Subunit : Boolean;
383 Corr_Body : Unit_Number_Type := No_Unit;
384 Renamings : Boolean := False;
385 With_Node : Node_Id := Empty;
386 PMES : Boolean := False) return Unit_Number_Type
387 is
388 Calling_Unit : Unit_Number_Type;
389 Uname_Actual : Unit_Name_Type;
390 Unum : Unit_Number_Type;
391 Unump : Unit_Number_Type;
392 Fname : File_Name_Type;
393 Pre_Name : Boolean;
394 Ren_Name : Boolean;
395 GNAT_Name : Boolean;
396 Src_Ind : Source_File_Index;
397 Save_PMES : constant Boolean := Parsing_Main_Extended_Source;
398
399 Save_Cunit_Restrictions : constant Save_Cunit_Boolean_Restrictions :=
400 Cunit_Boolean_Restrictions_Save;
401 -- Save current restrictions for restore at end
402
403 begin
404 Parsing_Main_Extended_Source := PMES;
405
406 -- Initialize restrictions to config restrictions for unit to load if
407 -- it is part of the main extended source, otherwise reset them.
408
409 -- Note: it's a bit odd but PMES is False for subunits, which is why
410 -- we have the OR here. Should be investigated some time???
411
412 if PMES or Subunit then
413 Restore_Config_Cunit_Boolean_Restrictions;
414 else
415 Reset_Cunit_Boolean_Restrictions;
416 end if;
417
418 -- If renamings are allowed and we have a child unit name, then we
419 -- must first load the parent to deal with finding the real name.
420 -- Retain the with_clause that names the child, so that if it is
421 -- limited, the parent is loaded under the same condition.
422
423 if Renamings and then Is_Child_Name (Load_Name) then
424 Unump :=
425 Load_Unit
426 (Load_Name => Get_Parent_Spec_Name (Load_Name),
427 Required => Required,
428 Subunit => False,
429 Renamings => True,
430 Error_Node => Error_Node,
431 With_Node => With_Node);
432
433 if Unump = No_Unit then
434 Parsing_Main_Extended_Source := Save_PMES;
435 return No_Unit;
436 end if;
437
438 -- If parent is a renaming, then we use the renamed package as
439 -- the actual parent for the subsequent load operation.
440
441 if Nkind (Unit (Cunit (Unump))) = N_Package_Renaming_Declaration then
442 Uname_Actual :=
443 New_Child
444 (Load_Name, Get_Unit_Name (Name (Unit (Cunit (Unump)))));
445
446 -- If the load is for a with_clause, for visibility purposes both
447 -- the renamed entity and renaming one must be available in the
448 -- current unit: the renamed one in order to retrieve the child
449 -- unit, and the original one because it may be used as a prefix
450 -- in the body of the current unit. We add an explicit with_clause
451 -- for the original parent so that the renaming declaration is
452 -- properly loaded and analyzed.
453
454 if Present (With_Node) then
455 Insert_After (With_Node,
456 Make_With_Clause (Sloc (With_Node),
457 Name => Copy_Separate_Tree (Prefix (Name (With_Node)))));
458 end if;
459
460 -- Save the renaming entity, to establish its visibility when
461 -- installing the context. The implicit with is on this entity,
462 -- not on the package it renames. This is somewhat redundant given
463 -- the with_clause just created, but it simplifies subsequent
464 -- expansion of the current with_clause. Optimizable ???
465
466 if Nkind (Error_Node) = N_With_Clause
467 and then Nkind (Name (Error_Node)) = N_Selected_Component
468 then
469 declare
470 Par : Node_Id := Name (Error_Node);
471
472 begin
473 while Nkind (Par) = N_Selected_Component
474 and then Chars (Selector_Name (Par)) /=
475 Chars (Cunit_Entity (Unump))
476 loop
477 Par := Prefix (Par);
478 end loop;
479
480 -- Case of some intermediate parent is a renaming
481
482 if Nkind (Par) = N_Selected_Component then
483 Set_Entity (Selector_Name (Par), Cunit_Entity (Unump));
484
485 -- Case where the ultimate parent is a renaming
486
487 else
488 Set_Entity (Par, Cunit_Entity (Unump));
489 end if;
490 end;
491 end if;
492
493 -- If the parent is not a renaming, then get its name (this may
494 -- be different from the parent spec name obtained above because
495 -- of renamings higher up in the hierarchy).
496
497 else
498 Uname_Actual := New_Child (Load_Name, Unit_Name (Unump));
499 end if;
500
501 -- Here if unit to be loaded is not a child unit
502
503 else
504 Uname_Actual := Load_Name;
505 end if;
506
507 Fname := Get_File_Name (Uname_Actual, Subunit);
508 Pre_Name :=
509 Is_Predefined_File_Name (Fname, Renamings_Included => False);
510 Ren_Name := Is_Predefined_Renaming_File_Name (Fname);
511 GNAT_Name := Is_GNAT_File_Name (Fname);
512
513 if Debug_Flag_L then
514 Write_Eol;
515 Write_Str ("*** Load request for unit: ");
516 Write_Unit_Name (Load_Name);
517
518 if Required then
519 Write_Str (" (Required = True)");
520 else
521 Write_Str (" (Required = False)");
522 end if;
523
524 Write_Eol;
525
526 if Uname_Actual /= Load_Name then
527 Write_Str ("*** Actual unit loaded: ");
528 Write_Unit_Name (Uname_Actual);
529 end if;
530 end if;
531
532 -- Capture error location if it is for the main unit. The idea is to
533 -- post errors on the main unit location, not the most recent unit.
534 -- Note: Unit_Name (Main_Unit) is not set if we are parsing gnat.adc.
535
536 if Present (Error_Node)
537 and then Unit_Name (Main_Unit) /= No_Unit_Name
538 then
539 -- It seems like In_Extended_Main_Source_Unit (Error_Node) would
540 -- do the trick here, but that's wrong, it is much too early to
541 -- call this routine. We are still in the parser, and the required
542 -- semantic information is not established yet. So we base the
543 -- judgment on unit names.
544
545 Get_External_Unit_Name_String (Unit_Name (Main_Unit));
546
547 declare
548 Main_Unit_Name : constant String := Name_Buffer (1 .. Name_Len);
549
550 begin
551 Get_External_Unit_Name_String
552 (Unit_Name (Get_Source_Unit (Error_Node)));
553
554 -- If the two names are identical, then for sure we are part
555 -- of the extended main unit
556
557 if Main_Unit_Name = Name_Buffer (1 .. Name_Len) then
558 Load_Msg_Sloc := Sloc (Error_Node);
559
560 -- If the load is called from a with_type clause, the error
561 -- node is correct.
562
563 -- Otherwise, check for the subunit case, and if so, consider
564 -- we have a match if one name is a prefix of the other name.
565
566 else
567 if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
568 or else
569 Nkind (Unit (Cunit (Get_Source_Unit (Error_Node)))) =
570 N_Subunit
571 then
572 Name_Len := Integer'Min (Name_Len, Main_Unit_Name'Length);
573
574 if Name_Buffer (1 .. Name_Len)
575 =
576 Main_Unit_Name (1 .. Name_Len)
577 then
578 Load_Msg_Sloc := Sloc (Error_Node);
579 end if;
580 end if;
581 end if;
582 end;
583 end if;
584
585 -- If we are generating error messages, then capture calling unit
586
587 if Present (Error_Node) then
588 Calling_Unit := Get_Source_Unit (Error_Node);
589 else
590 Calling_Unit := No_Unit;
591 end if;
592
593 -- See if we already have an entry for this unit
594
595 Unum := Main_Unit;
596 while Unum <= Units.Last loop
597 exit when Uname_Actual = Units.Table (Unum).Unit_Name;
598 Unum := Unum + 1;
599 end loop;
600
601 -- Whether or not the entry was found, Unum is now the right value,
602 -- since it is one more than Units.Last (i.e. the index of the new
603 -- entry we will create) in the not found case.
604
605 -- A special check is necessary in the unit not found case. If the unit
606 -- is not found, but the file in which it lives has already been loaded,
607 -- then we have the problem that the file does not contain the unit that
608 -- is needed. We simply treat this as a file not found condition.
609
610 -- We skip this test in multiple unit per file mode since in this
611 -- case we can have multiple units from the same source file.
612
613 if Unum > Units.Last and then Get_Unit_Index (Uname_Actual) = 0 then
614 for J in Units.First .. Units.Last loop
615 if Fname = Units.Table (J).Unit_File_Name then
616 if Debug_Flag_L then
617 Write_Str (" file does not contain unit, Unit_Number = ");
618 Write_Int (Int (Unum));
619 Write_Eol;
620 Write_Eol;
621 end if;
622
623 if Present (Error_Node) then
624 Get_Name_String (Fname);
625
626 if Is_Predefined_File_Name (Fname) then
627 Error_Msg_Unit_1 := Uname_Actual;
628 Error_Msg
629 ("$$ is not a language defined unit", Load_Msg_Sloc);
630 else
631 Error_Msg_File_1 := Fname;
632 Error_Msg_Unit_1 := Uname_Actual;
633 Error_Msg ("File{ does not contain unit$", Load_Msg_Sloc);
634 end if;
635
636 Write_Dependency_Chain;
637 Unum := No_Unit;
638 goto Done;
639
640 else
641 Unum := No_Unit;
642 goto Done;
643 end if;
644 end if;
645 end loop;
646 end if;
647
648 -- If we are proceeding with load, then make load stack entry,
649 -- and indicate the kind of with_clause responsible for the load.
650
651 Load_Stack.Increment_Last;
652 Load_Stack.Table (Load_Stack.Last) := (Unum, With_Node);
653
654 -- Case of entry already in table
655
656 if Unum <= Units.Last then
657
658 -- Here is where we check for a circular dependency, which is
659 -- an attempt to load a unit which is currently in the process
660 -- of being loaded. We do *not* care about a circular chain that
661 -- leads back to a body, because this kind of circular dependence
662 -- legitimately occurs (e.g. two package bodies that contain
663 -- inlined subprogram referenced by the other).
664
665 -- Ada 2005 (AI-50217): We also ignore limited_with clauses, because
666 -- their purpose is precisely to create legal circular structures.
667
668 if Loading (Unum)
669 and then (Is_Spec_Name (Units.Table (Unum).Unit_Name)
670 or else Acts_As_Spec (Units.Table (Unum).Cunit))
671 and then (Nkind (Error_Node) /= N_With_Clause
672 or else not Limited_Present (Error_Node))
673 and then not From_Limited_With_Chain
674 then
675 if Debug_Flag_L then
676 Write_Str (" circular dependency encountered");
677 Write_Eol;
678 end if;
679
680 if Present (Error_Node) then
681 Error_Msg ("circular unit dependency", Load_Msg_Sloc);
682 Write_Dependency_Chain;
683 else
684 Load_Stack.Decrement_Last;
685 end if;
686
687 Unum := No_Unit;
688 goto Done;
689 end if;
690
691 if Debug_Flag_L then
692 Write_Str (" unit already in file table, Unit_Number = ");
693 Write_Int (Int (Unum));
694 Write_Eol;
695 end if;
696
697 Load_Stack.Decrement_Last;
698 goto Done;
699
700 -- Unit is not already in table, so try to open the file
701
702 else
703 if Debug_Flag_L then
704 Write_Str (" attempt unit load, Unit_Number = ");
705 Write_Int (Int (Unum));
706 Write_Eol;
707 end if;
708
709 Src_Ind := Load_Source_File (Fname);
710
711 -- Make a partial entry in the file table, used even in the file not
712 -- found case to print the dependency chain including the last entry
713
714 Units.Increment_Last;
715 Units.Table (Unum).Unit_Name := Uname_Actual;
716
717 -- File was found
718
719 if Src_Ind /= No_Source_File then
720 Units.Table (Unum) :=
721 (Cunit => Empty,
722 Cunit_Entity => Empty,
723 Dependency_Num => 0,
724 Dynamic_Elab => False,
725 Error_Location => Sloc (Error_Node),
726 Expected_Unit => Uname_Actual,
727 Fatal_Error => None,
728 Generate_Code => False,
729 Has_RACW => False,
730 Filler => False,
731 Ident_String => Empty,
732
733 Is_Predefined_Renaming => Ren_Name,
734 Is_Predefined_Unit => Pre_Name or Ren_Name,
735 Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name,
736 Filler2 => False,
737
738 Loading => True,
739 Main_Priority => Default_Main_Priority,
740 Main_CPU => Default_Main_CPU,
741 Munit_Index => 0,
742 No_Elab_Code_All => False,
743 Serial_Number => 0,
744 Source_Index => Src_Ind,
745 Unit_File_Name => Fname,
746 Unit_Name => Uname_Actual,
747 Version => Source_Checksum (Src_Ind),
748 OA_Setting => 'O');
749
750 -- Parse the new unit
751
752 declare
753 Save_Index : constant Nat := Multiple_Unit_Index;
754 Save_PMES : constant Boolean := Parsing_Main_Extended_Source;
755
756 begin
757 Multiple_Unit_Index := Get_Unit_Index (Uname_Actual);
758 Units.Table (Unum).Munit_Index := Multiple_Unit_Index;
759 Initialize_Scanner (Unum, Source_Index (Unum));
760
761 if Calling_Unit = Main_Unit and then Subunit then
762 Parsing_Main_Extended_Source := True;
763 end if;
764
765 Discard_List (Par (Configuration_Pragmas => False));
766
767 Parsing_Main_Extended_Source := Save_PMES;
768
769 Multiple_Unit_Index := Save_Index;
770 Set_Loading (Unum, False);
771 end;
772
773 -- If spec is irrelevant, then post errors and quit
774
775 if Corr_Body /= No_Unit
776 and then Spec_Is_Irrelevant (Unum, Corr_Body)
777 then
778 Error_Msg_File_1 := Unit_File_Name (Corr_Body);
779 Error_Msg
780 ("cannot compile subprogram in file {!", Load_Msg_Sloc);
781 Error_Msg_File_1 := Unit_File_Name (Unum);
782 Error_Msg
783 ("\incorrect spec in file { must be removed first!",
784 Load_Msg_Sloc);
785 Unum := No_Unit;
786 goto Done;
787 end if;
788
789 -- If loaded unit had an error, then caller inherits setting
790
791 if Present (Error_Node) then
792 case Units.Table (Unum).Fatal_Error is
793
794 -- Nothing to do if with'ed unit had no error
795
796 when None =>
797 null;
798
799 -- If with'ed unit had a detected fatal error, propagate it
800
801 when Error_Detected =>
802 Units.Table (Calling_Unit).Fatal_Error := Error_Detected;
803
804 -- If with'ed unit had an ignored error, then propagate it
805 -- but do not overide an existring setting.
806
807 when Error_Ignored =>
808 if Units.Table (Calling_Unit).Fatal_Error = None then
809 Units.Table (Calling_Unit).Fatal_Error :=
810 Error_Ignored;
811 end if;
812 end case;
813 end if;
814
815 -- Remove load stack entry and return the entry in the file table
816
817 Load_Stack.Decrement_Last;
818
819 -- All done, return unit number
820
821 goto Done;
822
823 -- Case of file not found
824
825 else
826 if Debug_Flag_L then
827 Write_Str (" file was not found, load failed");
828 Write_Eol;
829 end if;
830
831 -- Generate message if unit required
832
833 if Required then
834 Get_Name_String (Fname);
835
836 if Is_Predefined_File_Name (Fname) then
837
838 -- This is a predefined library unit which is not present
839 -- in the run time. If a predefined unit is not available
840 -- it may very likely be the case that there is also pragma
841 -- Restriction forbidding its usage. This is typically the
842 -- case when building a configurable run time, where the
843 -- usage of certain run-time units is restricted by means
844 -- of both the corresponding pragma Restriction (such as
845 -- No_Calendar), and by not including the unit. Hence, we
846 -- check whether this predefined unit is forbidden, so that
847 -- the message about the restriction violation is generated,
848 -- if needed.
849
850 if Present (Error_Node) then
851 Check_Restricted_Unit (Load_Name, Error_Node);
852 end if;
853
854 Error_Msg_Unit_1 := Uname_Actual;
855 Error_Msg -- CODEFIX
856 ("$$ is not a predefined library unit", Load_Msg_Sloc);
857
858 else
859 Error_Msg_File_1 := Fname;
860 Error_Msg ("file{ not found", Load_Msg_Sloc);
861 end if;
862
863 Write_Dependency_Chain;
864
865 -- Remove unit from stack, to avoid cascaded errors on
866 -- subsequent missing files.
867
868 Load_Stack.Decrement_Last;
869 Units.Decrement_Last;
870
871 -- If unit not required, remove load stack entry and the junk
872 -- file table entry, and return No_Unit to indicate not found,
873
874 else
875 Load_Stack.Decrement_Last;
876 Units.Decrement_Last;
877 end if;
878
879 Unum := No_Unit;
880 goto Done;
881 end if;
882 end if;
883
884 -- Here to exit, with result in Unum
885
886 <<Done>>
887 Parsing_Main_Extended_Source := Save_PMES;
888 Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions);
889 return Unum;
890 end Load_Unit;
891
892 --------------------------
893 -- Make_Child_Decl_Unit --
894 --------------------------
895
896 procedure Make_Child_Decl_Unit (N : Node_Id) is
897 Unit_Decl : constant Node_Id := Library_Unit (N);
898
899 begin
900 Units.Increment_Last;
901 Units.Table (Units.Last) := Units.Table (Get_Cunit_Unit_Number (N));
902 Units.Table (Units.Last).Unit_Name :=
903 Get_Spec_Name (Unit_Name (Get_Cunit_Unit_Number (N)));
904 Units.Table (Units.Last).Cunit := Unit_Decl;
905 Units.Table (Units.Last).Cunit_Entity :=
906 Defining_Identifier
907 (Defining_Unit_Name (Specification (Unit (Unit_Decl))));
908
909 -- The library unit created for of a child subprogram unit plays no
910 -- role in code generation and binding, so label it accordingly.
911
912 Units.Table (Units.Last).Generate_Code := False;
913 Set_Has_No_Elaboration_Code (Unit_Decl);
914 end Make_Child_Decl_Unit;
915
916 ------------------------
917 -- Make_Instance_Unit --
918 ------------------------
919
920 -- If the unit is an instance, it appears as a package declaration, but
921 -- contains both declaration and body of the instance. The body becomes
922 -- the main unit of the compilation, and the declaration is inserted
923 -- at the end of the unit table. The main unit now has the name of a
924 -- body, which is constructed from the name of the original spec,
925 -- and is attached to the compilation node of the original unit. The
926 -- declaration has been attached to a new compilation unit node, and
927 -- code will have to be generated for it.
928
929 procedure Make_Instance_Unit (N : Node_Id; In_Main : Boolean) is
930 Sind : constant Source_File_Index := Source_Index (Main_Unit);
931
932 begin
933 Units.Increment_Last;
934
935 if In_Main then
936 Units.Table (Units.Last) := Units.Table (Main_Unit);
937 Units.Table (Units.Last).Cunit := Library_Unit (N);
938 Units.Table (Units.Last).Generate_Code := True;
939 Units.Table (Main_Unit).Cunit := N;
940 Units.Table (Main_Unit).Unit_Name :=
941 Get_Body_Name
942 (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N))));
943 Units.Table (Main_Unit).Version := Source_Checksum (Sind);
944
945 else
946 -- Duplicate information from instance unit, for the body. The unit
947 -- node N has been rewritten as a body, but it was placed in the
948 -- units table when first loaded as a declaration.
949
950 Units.Table (Units.Last) := Units.Table (Get_Cunit_Unit_Number (N));
951 Units.Table (Units.Last).Cunit := Library_Unit (N);
952 end if;
953 end Make_Instance_Unit;
954
955 ------------------------
956 -- Spec_Is_Irrelevant --
957 ------------------------
958
959 function Spec_Is_Irrelevant
960 (Spec_Unit : Unit_Number_Type;
961 Body_Unit : Unit_Number_Type) return Boolean
962 is
963 Sunit : constant Node_Id := Cunit (Spec_Unit);
964 Bunit : constant Node_Id := Cunit (Body_Unit);
965
966 begin
967 -- The spec is irrelevant if the body is a subprogram body, and the spec
968 -- is other than a subprogram spec or generic subprogram spec. Note that
969 -- the names must be the same, we don't need to check that, because we
970 -- already know that from the fact that the file names are the same.
971
972 return
973 Nkind (Unit (Bunit)) = N_Subprogram_Body
974 and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration
975 and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration;
976 end Spec_Is_Irrelevant;
977
978 --------------------
979 -- Version_Update --
980 --------------------
981
982 procedure Version_Update (U : Node_Id; From : Node_Id) is
983 Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (U);
984 Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From);
985 begin
986 if Source_Index (Fnum) /= No_Source_File then
987 Units.Table (Unum).Version :=
988 Units.Table (Unum).Version
989 xor
990 Source_Checksum (Source_Index (Fnum));
991 end if;
992 end Version_Update;
993
994 ----------------------------
995 -- Write_Dependency_Chain --
996 ----------------------------
997
998 procedure Write_Dependency_Chain is
999 begin
1000 -- The dependency chain is only written if it is at least two entries
1001 -- deep, otherwise it is trivial (the main unit depending on a unit
1002 -- that it obviously directly depends on).
1003
1004 if Load_Stack.Last - 1 > Load_Stack.First then
1005 for U in Load_Stack.First .. Load_Stack.Last - 1 loop
1006 Error_Msg_Unit_1 :=
1007 Unit_Name (Load_Stack.Table (U).Unit_Number);
1008 Error_Msg_Unit_2 :=
1009 Unit_Name (Load_Stack.Table (U + 1).Unit_Number);
1010 Error_Msg ("$ depends on $!", Load_Msg_Sloc);
1011 end loop;
1012 end if;
1013 end Write_Dependency_Chain;
1014
1015 end Lib.Load;
Mirror of the offical gcc git repository hosted at gcc.gnu.org