1 |
281 |
jeremybenn |
------------------------------------------------------------------------------
|
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-2009, 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 |
|
|
Save_CS : constant Boolean := Get_Comes_From_Source_Default;
|
149 |
|
|
|
150 |
|
|
begin
|
151 |
|
|
-- The created dummy package unit does not come from source
|
152 |
|
|
|
153 |
|
|
Set_Comes_From_Source_Default (False);
|
154 |
|
|
|
155 |
|
|
-- Normal package
|
156 |
|
|
|
157 |
|
|
if Nkind (Name (With_Node)) = N_Identifier then
|
158 |
|
|
Cunit_Entity :=
|
159 |
|
|
Make_Defining_Identifier (No_Location,
|
160 |
|
|
Chars => Chars (Name (With_Node)));
|
161 |
|
|
Du_Name := Cunit_Entity;
|
162 |
|
|
End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location);
|
163 |
|
|
|
164 |
|
|
-- Child package
|
165 |
|
|
|
166 |
|
|
else
|
167 |
|
|
Cunit_Entity :=
|
168 |
|
|
Make_Defining_Identifier (No_Location,
|
169 |
|
|
Chars => Chars (Selector_Name (Name (With_Node))));
|
170 |
|
|
Du_Name :=
|
171 |
|
|
Make_Defining_Program_Unit_Name (No_Location,
|
172 |
|
|
Name => Copy_Separate_Tree (Prefix (Name (With_Node))),
|
173 |
|
|
Defining_Identifier => Cunit_Entity);
|
174 |
|
|
|
175 |
|
|
Set_Is_Child_Unit (Cunit_Entity);
|
176 |
|
|
|
177 |
|
|
End_Lab :=
|
178 |
|
|
Make_Designator (No_Location,
|
179 |
|
|
Name => Copy_Separate_Tree (Prefix (Name (With_Node))),
|
180 |
|
|
Identifier => New_Occurrence_Of (Cunit_Entity, No_Location));
|
181 |
|
|
end if;
|
182 |
|
|
|
183 |
|
|
Set_Scope (Cunit_Entity, Standard_Standard);
|
184 |
|
|
|
185 |
|
|
Cunit :=
|
186 |
|
|
Make_Compilation_Unit (No_Location,
|
187 |
|
|
Context_Items => Empty_List,
|
188 |
|
|
Unit =>
|
189 |
|
|
Make_Package_Declaration (No_Location,
|
190 |
|
|
Specification =>
|
191 |
|
|
Make_Package_Specification (No_Location,
|
192 |
|
|
Defining_Unit_Name => Du_Name,
|
193 |
|
|
Visible_Declarations => Empty_List,
|
194 |
|
|
End_Label => End_Lab)),
|
195 |
|
|
Aux_Decls_Node =>
|
196 |
|
|
Make_Compilation_Unit_Aux (No_Location));
|
197 |
|
|
|
198 |
|
|
-- Mark the dummy package as analyzed to prevent analysis of this
|
199 |
|
|
-- (non-existent) unit in -gnatQ mode because at the moment the
|
200 |
|
|
-- structure and attributes of this dummy package does not allow
|
201 |
|
|
-- a normal analysis of this unit
|
202 |
|
|
|
203 |
|
|
Set_Analyzed (Cunit);
|
204 |
|
|
|
205 |
|
|
Units.Increment_Last;
|
206 |
|
|
Unum := Units.Last;
|
207 |
|
|
|
208 |
|
|
Units.Table (Unum) := (
|
209 |
|
|
Cunit => Cunit,
|
210 |
|
|
Cunit_Entity => Cunit_Entity,
|
211 |
|
|
Dependency_Num => 0,
|
212 |
|
|
Dynamic_Elab => False,
|
213 |
|
|
Error_Location => Sloc (With_Node),
|
214 |
|
|
Expected_Unit => Spec_Name,
|
215 |
|
|
Fatal_Error => True,
|
216 |
|
|
Generate_Code => False,
|
217 |
|
|
Has_RACW => False,
|
218 |
|
|
Is_Compiler_Unit => False,
|
219 |
|
|
Ident_String => Empty,
|
220 |
|
|
Loading => False,
|
221 |
|
|
Main_Priority => Default_Main_Priority,
|
222 |
|
|
Munit_Index => 0,
|
223 |
|
|
Serial_Number => 0,
|
224 |
|
|
Source_Index => No_Source_File,
|
225 |
|
|
Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False),
|
226 |
|
|
Unit_Name => Spec_Name,
|
227 |
|
|
Version => 0,
|
228 |
|
|
OA_Setting => 'O');
|
229 |
|
|
|
230 |
|
|
Set_Comes_From_Source_Default (Save_CS);
|
231 |
|
|
Set_Error_Posted (Cunit_Entity);
|
232 |
|
|
Set_Error_Posted (Cunit);
|
233 |
|
|
return Unum;
|
234 |
|
|
end Create_Dummy_Package_Unit;
|
235 |
|
|
|
236 |
|
|
-----------------------------
|
237 |
|
|
-- From_Limited_With_Chain --
|
238 |
|
|
-----------------------------
|
239 |
|
|
|
240 |
|
|
function From_Limited_With_Chain return Boolean is
|
241 |
|
|
Curr_Num : constant Unit_Number_Type :=
|
242 |
|
|
Load_Stack.Table (Load_Stack.Last).Unit_Number;
|
243 |
|
|
|
244 |
|
|
begin
|
245 |
|
|
-- True if the current load operation is through a limited_with clause
|
246 |
|
|
-- and we are not within a loop of regular with_clauses.
|
247 |
|
|
|
248 |
|
|
for U in reverse Load_Stack.First .. Load_Stack.Last - 1 loop
|
249 |
|
|
if Load_Stack.Table (U).Unit_Number = Curr_Num then
|
250 |
|
|
return False;
|
251 |
|
|
|
252 |
|
|
elsif Present (Load_Stack.Table (U).With_Node)
|
253 |
|
|
and then Limited_Present (Load_Stack.Table (U).With_Node)
|
254 |
|
|
then
|
255 |
|
|
return True;
|
256 |
|
|
end if;
|
257 |
|
|
end loop;
|
258 |
|
|
|
259 |
|
|
return False;
|
260 |
|
|
end From_Limited_With_Chain;
|
261 |
|
|
|
262 |
|
|
----------------
|
263 |
|
|
-- Initialize --
|
264 |
|
|
----------------
|
265 |
|
|
|
266 |
|
|
procedure Initialize is
|
267 |
|
|
begin
|
268 |
|
|
Units.Init;
|
269 |
|
|
Load_Stack.Init;
|
270 |
|
|
end Initialize;
|
271 |
|
|
|
272 |
|
|
------------------------
|
273 |
|
|
-- Initialize_Version --
|
274 |
|
|
------------------------
|
275 |
|
|
|
276 |
|
|
procedure Initialize_Version (U : Unit_Number_Type) is
|
277 |
|
|
begin
|
278 |
|
|
Units.Table (U).Version := Source_Checksum (Source_Index (U));
|
279 |
|
|
end Initialize_Version;
|
280 |
|
|
|
281 |
|
|
----------------------
|
282 |
|
|
-- Load_Main_Source --
|
283 |
|
|
----------------------
|
284 |
|
|
|
285 |
|
|
procedure Load_Main_Source is
|
286 |
|
|
Fname : File_Name_Type;
|
287 |
|
|
Version : Word := 0;
|
288 |
|
|
|
289 |
|
|
begin
|
290 |
|
|
Load_Stack.Increment_Last;
|
291 |
|
|
Load_Stack.Table (Load_Stack.Last) := (Main_Unit, Empty);
|
292 |
|
|
|
293 |
|
|
-- Initialize unit table entry for Main_Unit. Note that we don't know
|
294 |
|
|
-- the unit name yet, that gets filled in when the parser parses the
|
295 |
|
|
-- main unit, at which time a check is made that it matches the main
|
296 |
|
|
-- file name, and then the Unit_Name field is set. The Cunit and
|
297 |
|
|
-- Cunit_Entity fields also get filled in later by the parser.
|
298 |
|
|
|
299 |
|
|
Units.Increment_Last;
|
300 |
|
|
Fname := Next_Main_Source;
|
301 |
|
|
|
302 |
|
|
Units.Table (Main_Unit).Unit_File_Name := Fname;
|
303 |
|
|
|
304 |
|
|
if Fname /= No_File then
|
305 |
|
|
Main_Source_File := Load_Source_File (Fname);
|
306 |
|
|
Current_Error_Source_File := Main_Source_File;
|
307 |
|
|
|
308 |
|
|
if Main_Source_File /= No_Source_File then
|
309 |
|
|
Version := Source_Checksum (Main_Source_File);
|
310 |
|
|
end if;
|
311 |
|
|
|
312 |
|
|
Units.Table (Main_Unit) := (
|
313 |
|
|
Cunit => Empty,
|
314 |
|
|
Cunit_Entity => Empty,
|
315 |
|
|
Dependency_Num => 0,
|
316 |
|
|
Dynamic_Elab => False,
|
317 |
|
|
Error_Location => No_Location,
|
318 |
|
|
Expected_Unit => No_Unit_Name,
|
319 |
|
|
Fatal_Error => False,
|
320 |
|
|
Generate_Code => False,
|
321 |
|
|
Has_RACW => False,
|
322 |
|
|
Is_Compiler_Unit => False,
|
323 |
|
|
Ident_String => Empty,
|
324 |
|
|
Loading => True,
|
325 |
|
|
Main_Priority => Default_Main_Priority,
|
326 |
|
|
Munit_Index => 0,
|
327 |
|
|
Serial_Number => 0,
|
328 |
|
|
Source_Index => Main_Source_File,
|
329 |
|
|
Unit_File_Name => Fname,
|
330 |
|
|
Unit_Name => No_Unit_Name,
|
331 |
|
|
Version => Version,
|
332 |
|
|
OA_Setting => 'O');
|
333 |
|
|
end if;
|
334 |
|
|
end Load_Main_Source;
|
335 |
|
|
|
336 |
|
|
---------------
|
337 |
|
|
-- Load_Unit --
|
338 |
|
|
---------------
|
339 |
|
|
|
340 |
|
|
function Load_Unit
|
341 |
|
|
(Load_Name : Unit_Name_Type;
|
342 |
|
|
Required : Boolean;
|
343 |
|
|
Error_Node : Node_Id;
|
344 |
|
|
Subunit : Boolean;
|
345 |
|
|
Corr_Body : Unit_Number_Type := No_Unit;
|
346 |
|
|
Renamings : Boolean := False;
|
347 |
|
|
With_Node : Node_Id := Empty) return Unit_Number_Type
|
348 |
|
|
is
|
349 |
|
|
Calling_Unit : Unit_Number_Type;
|
350 |
|
|
Uname_Actual : Unit_Name_Type;
|
351 |
|
|
Unum : Unit_Number_Type;
|
352 |
|
|
Unump : Unit_Number_Type;
|
353 |
|
|
Fname : File_Name_Type;
|
354 |
|
|
Src_Ind : Source_File_Index;
|
355 |
|
|
|
356 |
|
|
-- Start of processing for Load_Unit
|
357 |
|
|
|
358 |
|
|
begin
|
359 |
|
|
-- If renamings are allowed and we have a child unit name, then we
|
360 |
|
|
-- must first load the parent to deal with finding the real name.
|
361 |
|
|
-- Retain the with_clause that names the child, so that if it is
|
362 |
|
|
-- limited, the parent is loaded under the same condition.
|
363 |
|
|
|
364 |
|
|
if Renamings and then Is_Child_Name (Load_Name) then
|
365 |
|
|
Unump :=
|
366 |
|
|
Load_Unit
|
367 |
|
|
(Load_Name => Get_Parent_Spec_Name (Load_Name),
|
368 |
|
|
Required => Required,
|
369 |
|
|
Subunit => False,
|
370 |
|
|
Renamings => True,
|
371 |
|
|
Error_Node => Error_Node,
|
372 |
|
|
With_Node => With_Node);
|
373 |
|
|
|
374 |
|
|
if Unump = No_Unit then
|
375 |
|
|
return No_Unit;
|
376 |
|
|
end if;
|
377 |
|
|
|
378 |
|
|
-- If parent is a renaming, then we use the renamed package as
|
379 |
|
|
-- the actual parent for the subsequent load operation.
|
380 |
|
|
|
381 |
|
|
if Nkind (Unit (Cunit (Unump))) = N_Package_Renaming_Declaration then
|
382 |
|
|
Uname_Actual :=
|
383 |
|
|
New_Child
|
384 |
|
|
(Load_Name, Get_Unit_Name (Name (Unit (Cunit (Unump)))));
|
385 |
|
|
|
386 |
|
|
-- Save the renaming entity, to establish its visibility when
|
387 |
|
|
-- installing the context. The implicit with is on this entity,
|
388 |
|
|
-- not on the package it renames.
|
389 |
|
|
|
390 |
|
|
if Nkind (Error_Node) = N_With_Clause
|
391 |
|
|
and then Nkind (Name (Error_Node)) = N_Selected_Component
|
392 |
|
|
then
|
393 |
|
|
declare
|
394 |
|
|
Par : Node_Id := Name (Error_Node);
|
395 |
|
|
|
396 |
|
|
begin
|
397 |
|
|
while Nkind (Par) = N_Selected_Component
|
398 |
|
|
and then Chars (Selector_Name (Par)) /=
|
399 |
|
|
Chars (Cunit_Entity (Unump))
|
400 |
|
|
loop
|
401 |
|
|
Par := Prefix (Par);
|
402 |
|
|
end loop;
|
403 |
|
|
|
404 |
|
|
-- Case of some intermediate parent is a renaming
|
405 |
|
|
|
406 |
|
|
if Nkind (Par) = N_Selected_Component then
|
407 |
|
|
Set_Entity (Selector_Name (Par), Cunit_Entity (Unump));
|
408 |
|
|
|
409 |
|
|
-- Case where the ultimate parent is a renaming
|
410 |
|
|
|
411 |
|
|
else
|
412 |
|
|
Set_Entity (Par, Cunit_Entity (Unump));
|
413 |
|
|
end if;
|
414 |
|
|
end;
|
415 |
|
|
end if;
|
416 |
|
|
|
417 |
|
|
-- If the parent is not a renaming, then get its name (this may
|
418 |
|
|
-- be different from the parent spec name obtained above because
|
419 |
|
|
-- of renamings higher up in the hierarchy).
|
420 |
|
|
|
421 |
|
|
else
|
422 |
|
|
Uname_Actual := New_Child (Load_Name, Unit_Name (Unump));
|
423 |
|
|
end if;
|
424 |
|
|
|
425 |
|
|
-- Here if unit to be loaded is not a child unit
|
426 |
|
|
|
427 |
|
|
else
|
428 |
|
|
Uname_Actual := Load_Name;
|
429 |
|
|
end if;
|
430 |
|
|
|
431 |
|
|
Fname := Get_File_Name (Uname_Actual, Subunit);
|
432 |
|
|
|
433 |
|
|
if Debug_Flag_L then
|
434 |
|
|
Write_Eol;
|
435 |
|
|
Write_Str ("*** Load request for unit: ");
|
436 |
|
|
Write_Unit_Name (Load_Name);
|
437 |
|
|
|
438 |
|
|
if Required then
|
439 |
|
|
Write_Str (" (Required = True)");
|
440 |
|
|
else
|
441 |
|
|
Write_Str (" (Required = False)");
|
442 |
|
|
end if;
|
443 |
|
|
|
444 |
|
|
Write_Eol;
|
445 |
|
|
|
446 |
|
|
if Uname_Actual /= Load_Name then
|
447 |
|
|
Write_Str ("*** Actual unit loaded: ");
|
448 |
|
|
Write_Unit_Name (Uname_Actual);
|
449 |
|
|
end if;
|
450 |
|
|
end if;
|
451 |
|
|
|
452 |
|
|
-- Capture error location if it is for the main unit. The idea is to
|
453 |
|
|
-- post errors on the main unit location, not the most recent unit.
|
454 |
|
|
-- Note: Unit_Name (Main_Unit) is not set if we are parsing gnat.adc.
|
455 |
|
|
|
456 |
|
|
if Present (Error_Node)
|
457 |
|
|
and then Unit_Name (Main_Unit) /= No_Unit_Name
|
458 |
|
|
then
|
459 |
|
|
-- It seems like In_Extended_Main_Source_Unit (Error_Node) would
|
460 |
|
|
-- do the trick here, but that's wrong, it is much too early to
|
461 |
|
|
-- call this routine. We are still in the parser, and the required
|
462 |
|
|
-- semantic information is not established yet. So we base the
|
463 |
|
|
-- judgment on unit names.
|
464 |
|
|
|
465 |
|
|
Get_External_Unit_Name_String (Unit_Name (Main_Unit));
|
466 |
|
|
|
467 |
|
|
declare
|
468 |
|
|
Main_Unit_Name : constant String := Name_Buffer (1 .. Name_Len);
|
469 |
|
|
|
470 |
|
|
begin
|
471 |
|
|
Get_External_Unit_Name_String
|
472 |
|
|
(Unit_Name (Get_Source_Unit (Error_Node)));
|
473 |
|
|
|
474 |
|
|
-- If the two names are identical, then for sure we are part
|
475 |
|
|
-- of the extended main unit
|
476 |
|
|
|
477 |
|
|
if Main_Unit_Name = Name_Buffer (1 .. Name_Len) then
|
478 |
|
|
Load_Msg_Sloc := Sloc (Error_Node);
|
479 |
|
|
|
480 |
|
|
-- If the load is called from a with_type clause, the error
|
481 |
|
|
-- node is correct.
|
482 |
|
|
|
483 |
|
|
-- Otherwise, check for the subunit case, and if so, consider
|
484 |
|
|
-- we have a match if one name is a prefix of the other name.
|
485 |
|
|
|
486 |
|
|
else
|
487 |
|
|
if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
|
488 |
|
|
or else
|
489 |
|
|
Nkind (Unit (Cunit (Get_Source_Unit (Error_Node)))) =
|
490 |
|
|
N_Subunit
|
491 |
|
|
then
|
492 |
|
|
Name_Len := Integer'Min (Name_Len, Main_Unit_Name'Length);
|
493 |
|
|
|
494 |
|
|
if Name_Buffer (1 .. Name_Len)
|
495 |
|
|
=
|
496 |
|
|
Main_Unit_Name (1 .. Name_Len)
|
497 |
|
|
then
|
498 |
|
|
Load_Msg_Sloc := Sloc (Error_Node);
|
499 |
|
|
end if;
|
500 |
|
|
end if;
|
501 |
|
|
end if;
|
502 |
|
|
end;
|
503 |
|
|
end if;
|
504 |
|
|
|
505 |
|
|
-- If we are generating error messages, then capture calling unit
|
506 |
|
|
|
507 |
|
|
if Present (Error_Node) then
|
508 |
|
|
Calling_Unit := Get_Source_Unit (Error_Node);
|
509 |
|
|
else
|
510 |
|
|
Calling_Unit := No_Unit;
|
511 |
|
|
end if;
|
512 |
|
|
|
513 |
|
|
-- See if we already have an entry for this unit
|
514 |
|
|
|
515 |
|
|
Unum := Main_Unit;
|
516 |
|
|
|
517 |
|
|
while Unum <= Units.Last loop
|
518 |
|
|
exit when Uname_Actual = Units.Table (Unum).Unit_Name;
|
519 |
|
|
Unum := Unum + 1;
|
520 |
|
|
end loop;
|
521 |
|
|
|
522 |
|
|
-- Whether or not the entry was found, Unum is now the right value,
|
523 |
|
|
-- since it is one more than Units.Last (i.e. the index of the new
|
524 |
|
|
-- entry we will create) in the not found case.
|
525 |
|
|
|
526 |
|
|
-- A special check is necessary in the unit not found case. If the unit
|
527 |
|
|
-- is not found, but the file in which it lives has already been loaded,
|
528 |
|
|
-- then we have the problem that the file does not contain the unit that
|
529 |
|
|
-- is needed. We simply treat this as a file not found condition.
|
530 |
|
|
|
531 |
|
|
-- We skip this test in multiple unit per file mode since in this
|
532 |
|
|
-- case we can have multiple units from the same source file.
|
533 |
|
|
|
534 |
|
|
if Unum > Units.Last and then Get_Unit_Index (Uname_Actual) = 0 then
|
535 |
|
|
for J in Units.First .. Units.Last loop
|
536 |
|
|
if Fname = Units.Table (J).Unit_File_Name then
|
537 |
|
|
if Debug_Flag_L then
|
538 |
|
|
Write_Str (" file does not contain unit, Unit_Number = ");
|
539 |
|
|
Write_Int (Int (Unum));
|
540 |
|
|
Write_Eol;
|
541 |
|
|
Write_Eol;
|
542 |
|
|
end if;
|
543 |
|
|
|
544 |
|
|
if Present (Error_Node) then
|
545 |
|
|
if Is_Predefined_File_Name (Fname) then
|
546 |
|
|
Error_Msg_Unit_1 := Uname_Actual;
|
547 |
|
|
Error_Msg
|
548 |
|
|
("$$ is not a language defined unit", Load_Msg_Sloc);
|
549 |
|
|
else
|
550 |
|
|
Error_Msg_File_1 := Fname;
|
551 |
|
|
Error_Msg_Unit_1 := Uname_Actual;
|
552 |
|
|
Error_Msg ("File{ does not contain unit$", Load_Msg_Sloc);
|
553 |
|
|
end if;
|
554 |
|
|
|
555 |
|
|
Write_Dependency_Chain;
|
556 |
|
|
return No_Unit;
|
557 |
|
|
|
558 |
|
|
else
|
559 |
|
|
return No_Unit;
|
560 |
|
|
end if;
|
561 |
|
|
end if;
|
562 |
|
|
end loop;
|
563 |
|
|
end if;
|
564 |
|
|
|
565 |
|
|
-- If we are proceeding with load, then make load stack entry,
|
566 |
|
|
-- and indicate the kind of with_clause responsible for the load.
|
567 |
|
|
|
568 |
|
|
Load_Stack.Increment_Last;
|
569 |
|
|
Load_Stack.Table (Load_Stack.Last) := (Unum, With_Node);
|
570 |
|
|
|
571 |
|
|
-- Case of entry already in table
|
572 |
|
|
|
573 |
|
|
if Unum <= Units.Last then
|
574 |
|
|
|
575 |
|
|
-- Here is where we check for a circular dependency, which is
|
576 |
|
|
-- an attempt to load a unit which is currently in the process
|
577 |
|
|
-- of being loaded. We do *not* care about a circular chain that
|
578 |
|
|
-- leads back to a body, because this kind of circular dependence
|
579 |
|
|
-- legitimately occurs (e.g. two package bodies that contain
|
580 |
|
|
-- inlined subprogram referenced by the other).
|
581 |
|
|
|
582 |
|
|
-- Ada 2005 (AI-50217): We also ignore limited_with clauses, because
|
583 |
|
|
-- their purpose is precisely to create legal circular structures.
|
584 |
|
|
|
585 |
|
|
if Loading (Unum)
|
586 |
|
|
and then (Is_Spec_Name (Units.Table (Unum).Unit_Name)
|
587 |
|
|
or else Acts_As_Spec (Units.Table (Unum).Cunit))
|
588 |
|
|
and then (Nkind (Error_Node) /= N_With_Clause
|
589 |
|
|
or else not Limited_Present (Error_Node))
|
590 |
|
|
and then not From_Limited_With_Chain
|
591 |
|
|
then
|
592 |
|
|
if Debug_Flag_L then
|
593 |
|
|
Write_Str (" circular dependency encountered");
|
594 |
|
|
Write_Eol;
|
595 |
|
|
end if;
|
596 |
|
|
|
597 |
|
|
if Present (Error_Node) then
|
598 |
|
|
Error_Msg ("circular unit dependency", Load_Msg_Sloc);
|
599 |
|
|
Write_Dependency_Chain;
|
600 |
|
|
else
|
601 |
|
|
Load_Stack.Decrement_Last;
|
602 |
|
|
end if;
|
603 |
|
|
|
604 |
|
|
return No_Unit;
|
605 |
|
|
end if;
|
606 |
|
|
|
607 |
|
|
if Debug_Flag_L then
|
608 |
|
|
Write_Str (" unit already in file table, Unit_Number = ");
|
609 |
|
|
Write_Int (Int (Unum));
|
610 |
|
|
Write_Eol;
|
611 |
|
|
end if;
|
612 |
|
|
|
613 |
|
|
Load_Stack.Decrement_Last;
|
614 |
|
|
return Unum;
|
615 |
|
|
|
616 |
|
|
-- Unit is not already in table, so try to open the file
|
617 |
|
|
|
618 |
|
|
else
|
619 |
|
|
if Debug_Flag_L then
|
620 |
|
|
Write_Str (" attempt unit load, Unit_Number = ");
|
621 |
|
|
Write_Int (Int (Unum));
|
622 |
|
|
Write_Eol;
|
623 |
|
|
end if;
|
624 |
|
|
|
625 |
|
|
Src_Ind := Load_Source_File (Fname);
|
626 |
|
|
|
627 |
|
|
-- Make a partial entry in the file table, used even in the file not
|
628 |
|
|
-- found case to print the dependency chain including the last entry
|
629 |
|
|
|
630 |
|
|
Units.Increment_Last;
|
631 |
|
|
Units.Table (Unum).Unit_Name := Uname_Actual;
|
632 |
|
|
|
633 |
|
|
-- File was found
|
634 |
|
|
|
635 |
|
|
if Src_Ind /= No_Source_File then
|
636 |
|
|
Units.Table (Unum) := (
|
637 |
|
|
Cunit => Empty,
|
638 |
|
|
Cunit_Entity => Empty,
|
639 |
|
|
Dependency_Num => 0,
|
640 |
|
|
Dynamic_Elab => False,
|
641 |
|
|
Error_Location => Sloc (Error_Node),
|
642 |
|
|
Expected_Unit => Uname_Actual,
|
643 |
|
|
Fatal_Error => False,
|
644 |
|
|
Generate_Code => False,
|
645 |
|
|
Has_RACW => False,
|
646 |
|
|
Is_Compiler_Unit => False,
|
647 |
|
|
Ident_String => Empty,
|
648 |
|
|
Loading => True,
|
649 |
|
|
Main_Priority => Default_Main_Priority,
|
650 |
|
|
Munit_Index => 0,
|
651 |
|
|
Serial_Number => 0,
|
652 |
|
|
Source_Index => Src_Ind,
|
653 |
|
|
Unit_File_Name => Fname,
|
654 |
|
|
Unit_Name => Uname_Actual,
|
655 |
|
|
Version => Source_Checksum (Src_Ind),
|
656 |
|
|
OA_Setting => 'O');
|
657 |
|
|
|
658 |
|
|
-- Parse the new unit
|
659 |
|
|
|
660 |
|
|
declare
|
661 |
|
|
Save_Index : constant Nat := Multiple_Unit_Index;
|
662 |
|
|
begin
|
663 |
|
|
Multiple_Unit_Index := Get_Unit_Index (Uname_Actual);
|
664 |
|
|
Units.Table (Unum).Munit_Index := Multiple_Unit_Index;
|
665 |
|
|
Initialize_Scanner (Unum, Source_Index (Unum));
|
666 |
|
|
Discard_List (Par (Configuration_Pragmas => False));
|
667 |
|
|
Multiple_Unit_Index := Save_Index;
|
668 |
|
|
Set_Loading (Unum, False);
|
669 |
|
|
end;
|
670 |
|
|
|
671 |
|
|
-- If spec is irrelevant, then post errors and quit
|
672 |
|
|
|
673 |
|
|
if Corr_Body /= No_Unit
|
674 |
|
|
and then Spec_Is_Irrelevant (Unum, Corr_Body)
|
675 |
|
|
then
|
676 |
|
|
Error_Msg_File_1 := Unit_File_Name (Corr_Body);
|
677 |
|
|
Error_Msg
|
678 |
|
|
("cannot compile subprogram in file {!", Load_Msg_Sloc);
|
679 |
|
|
Error_Msg_File_1 := Unit_File_Name (Unum);
|
680 |
|
|
Error_Msg
|
681 |
|
|
("\incorrect spec in file { must be removed first!",
|
682 |
|
|
Load_Msg_Sloc);
|
683 |
|
|
return No_Unit;
|
684 |
|
|
end if;
|
685 |
|
|
|
686 |
|
|
-- If loaded unit had a fatal error, then caller inherits it!
|
687 |
|
|
|
688 |
|
|
if Units.Table (Unum).Fatal_Error
|
689 |
|
|
and then Present (Error_Node)
|
690 |
|
|
then
|
691 |
|
|
Units.Table (Calling_Unit).Fatal_Error := True;
|
692 |
|
|
end if;
|
693 |
|
|
|
694 |
|
|
-- Remove load stack entry and return the entry in the file table
|
695 |
|
|
|
696 |
|
|
Load_Stack.Decrement_Last;
|
697 |
|
|
|
698 |
|
|
-- All done, return unit number
|
699 |
|
|
|
700 |
|
|
return Unum;
|
701 |
|
|
|
702 |
|
|
-- Case of file not found
|
703 |
|
|
|
704 |
|
|
else
|
705 |
|
|
if Debug_Flag_L then
|
706 |
|
|
Write_Str (" file was not found, load failed");
|
707 |
|
|
Write_Eol;
|
708 |
|
|
end if;
|
709 |
|
|
|
710 |
|
|
-- Generate message if unit required
|
711 |
|
|
|
712 |
|
|
if Required and then Present (Error_Node) then
|
713 |
|
|
if Is_Predefined_File_Name (Fname) then
|
714 |
|
|
|
715 |
|
|
-- This is a predefined library unit which is not present
|
716 |
|
|
-- in the run time. If a predefined unit is not available
|
717 |
|
|
-- it may very likely be the case that there is also pragma
|
718 |
|
|
-- Restriction forbidding its usage. This is typically the
|
719 |
|
|
-- case when building a configurable run time, where the
|
720 |
|
|
-- usage of certain run-time units is restricted by means
|
721 |
|
|
-- of both the corresponding pragma Restriction (such as
|
722 |
|
|
-- No_Calendar), and by not including the unit. Hence, we
|
723 |
|
|
-- check whether this predefined unit is forbidden, so that
|
724 |
|
|
-- the message about the restriction violation is generated,
|
725 |
|
|
-- if needed.
|
726 |
|
|
|
727 |
|
|
Check_Restricted_Unit (Load_Name, Error_Node);
|
728 |
|
|
|
729 |
|
|
Error_Msg_Unit_1 := Uname_Actual;
|
730 |
|
|
Error_Msg -- CODEFIX
|
731 |
|
|
("$$ is not a predefined library unit", Load_Msg_Sloc);
|
732 |
|
|
|
733 |
|
|
else
|
734 |
|
|
Error_Msg_File_1 := Fname;
|
735 |
|
|
Error_Msg ("file{ not found", Load_Msg_Sloc);
|
736 |
|
|
end if;
|
737 |
|
|
|
738 |
|
|
Write_Dependency_Chain;
|
739 |
|
|
|
740 |
|
|
-- Remove unit from stack, to avoid cascaded errors on
|
741 |
|
|
-- subsequent missing files.
|
742 |
|
|
|
743 |
|
|
Load_Stack.Decrement_Last;
|
744 |
|
|
Units.Decrement_Last;
|
745 |
|
|
|
746 |
|
|
-- If unit not required, remove load stack entry and the junk
|
747 |
|
|
-- file table entry, and return No_Unit to indicate not found,
|
748 |
|
|
|
749 |
|
|
else
|
750 |
|
|
Load_Stack.Decrement_Last;
|
751 |
|
|
Units.Decrement_Last;
|
752 |
|
|
end if;
|
753 |
|
|
|
754 |
|
|
return No_Unit;
|
755 |
|
|
end if;
|
756 |
|
|
end if;
|
757 |
|
|
end Load_Unit;
|
758 |
|
|
|
759 |
|
|
--------------------------
|
760 |
|
|
-- Make_Child_Decl_Unit --
|
761 |
|
|
--------------------------
|
762 |
|
|
|
763 |
|
|
procedure Make_Child_Decl_Unit (N : Node_Id) is
|
764 |
|
|
Unit_Decl : constant Node_Id := Library_Unit (N);
|
765 |
|
|
|
766 |
|
|
begin
|
767 |
|
|
Units.Increment_Last;
|
768 |
|
|
Units.Table (Units.Last) := Units.Table (Get_Cunit_Unit_Number (N));
|
769 |
|
|
Units.Table (Units.Last).Unit_Name :=
|
770 |
|
|
Get_Spec_Name (Unit_Name (Get_Cunit_Unit_Number (N)));
|
771 |
|
|
Units.Table (Units.Last).Cunit := Unit_Decl;
|
772 |
|
|
Units.Table (Units.Last).Cunit_Entity :=
|
773 |
|
|
Defining_Identifier
|
774 |
|
|
(Defining_Unit_Name (Specification (Unit (Unit_Decl))));
|
775 |
|
|
|
776 |
|
|
-- The library unit created for of a child subprogram unit plays no
|
777 |
|
|
-- role in code generation and binding, so label it accordingly.
|
778 |
|
|
|
779 |
|
|
Units.Table (Units.Last).Generate_Code := False;
|
780 |
|
|
Set_Has_No_Elaboration_Code (Unit_Decl);
|
781 |
|
|
end Make_Child_Decl_Unit;
|
782 |
|
|
|
783 |
|
|
------------------------
|
784 |
|
|
-- Make_Instance_Unit --
|
785 |
|
|
------------------------
|
786 |
|
|
|
787 |
|
|
-- If the unit is an instance, it appears as a package declaration, but
|
788 |
|
|
-- contains both declaration and body of the instance. The body becomes
|
789 |
|
|
-- the main unit of the compilation, and the declaration is inserted
|
790 |
|
|
-- at the end of the unit table. The main unit now has the name of a
|
791 |
|
|
-- body, which is constructed from the name of the original spec,
|
792 |
|
|
-- and is attached to the compilation node of the original unit. The
|
793 |
|
|
-- declaration has been attached to a new compilation unit node, and
|
794 |
|
|
-- code will have to be generated for it.
|
795 |
|
|
|
796 |
|
|
procedure Make_Instance_Unit (N : Node_Id; In_Main : Boolean) is
|
797 |
|
|
Sind : constant Source_File_Index := Source_Index (Main_Unit);
|
798 |
|
|
|
799 |
|
|
begin
|
800 |
|
|
Units.Increment_Last;
|
801 |
|
|
|
802 |
|
|
if In_Main then
|
803 |
|
|
Units.Table (Units.Last) := Units.Table (Main_Unit);
|
804 |
|
|
Units.Table (Units.Last).Cunit := Library_Unit (N);
|
805 |
|
|
Units.Table (Units.Last).Generate_Code := True;
|
806 |
|
|
Units.Table (Main_Unit).Cunit := N;
|
807 |
|
|
Units.Table (Main_Unit).Unit_Name :=
|
808 |
|
|
Get_Body_Name
|
809 |
|
|
(Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N))));
|
810 |
|
|
Units.Table (Main_Unit).Version := Source_Checksum (Sind);
|
811 |
|
|
|
812 |
|
|
else
|
813 |
|
|
-- Duplicate information from instance unit, for the body. The unit
|
814 |
|
|
-- node N has been rewritten as a body, but it was placed in the
|
815 |
|
|
-- units table when first loaded as a declaration.
|
816 |
|
|
|
817 |
|
|
Units.Table (Units.Last) := Units.Table (Get_Cunit_Unit_Number (N));
|
818 |
|
|
Units.Table (Units.Last).Cunit := Library_Unit (N);
|
819 |
|
|
end if;
|
820 |
|
|
end Make_Instance_Unit;
|
821 |
|
|
|
822 |
|
|
------------------------
|
823 |
|
|
-- Spec_Is_Irrelevant --
|
824 |
|
|
------------------------
|
825 |
|
|
|
826 |
|
|
function Spec_Is_Irrelevant
|
827 |
|
|
(Spec_Unit : Unit_Number_Type;
|
828 |
|
|
Body_Unit : Unit_Number_Type) return Boolean
|
829 |
|
|
is
|
830 |
|
|
Sunit : constant Node_Id := Cunit (Spec_Unit);
|
831 |
|
|
Bunit : constant Node_Id := Cunit (Body_Unit);
|
832 |
|
|
|
833 |
|
|
begin
|
834 |
|
|
-- The spec is irrelevant if the body is a subprogram body, and the spec
|
835 |
|
|
-- is other than a subprogram spec or generic subprogram spec. Note that
|
836 |
|
|
-- the names must be the same, we don't need to check that, because we
|
837 |
|
|
-- already know that from the fact that the file names are the same.
|
838 |
|
|
|
839 |
|
|
return
|
840 |
|
|
Nkind (Unit (Bunit)) = N_Subprogram_Body
|
841 |
|
|
and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration
|
842 |
|
|
and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration;
|
843 |
|
|
end Spec_Is_Irrelevant;
|
844 |
|
|
|
845 |
|
|
--------------------
|
846 |
|
|
-- Version_Update --
|
847 |
|
|
--------------------
|
848 |
|
|
|
849 |
|
|
procedure Version_Update (U : Node_Id; From : Node_Id) is
|
850 |
|
|
Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (U);
|
851 |
|
|
Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From);
|
852 |
|
|
begin
|
853 |
|
|
if Source_Index (Fnum) /= No_Source_File then
|
854 |
|
|
Units.Table (Unum).Version :=
|
855 |
|
|
Units.Table (Unum).Version
|
856 |
|
|
xor
|
857 |
|
|
Source_Checksum (Source_Index (Fnum));
|
858 |
|
|
end if;
|
859 |
|
|
end Version_Update;
|
860 |
|
|
|
861 |
|
|
----------------------------
|
862 |
|
|
-- Write_Dependency_Chain --
|
863 |
|
|
----------------------------
|
864 |
|
|
|
865 |
|
|
procedure Write_Dependency_Chain is
|
866 |
|
|
begin
|
867 |
|
|
-- The dependency chain is only written if it is at least two entries
|
868 |
|
|
-- deep, otherwise it is trivial (the main unit depending on a unit
|
869 |
|
|
-- that it obviously directly depends on).
|
870 |
|
|
|
871 |
|
|
if Load_Stack.Last - 1 > Load_Stack.First then
|
872 |
|
|
for U in Load_Stack.First .. Load_Stack.Last - 1 loop
|
873 |
|
|
Error_Msg_Unit_1 :=
|
874 |
|
|
Unit_Name (Load_Stack.Table (U).Unit_Number);
|
875 |
|
|
Error_Msg_Unit_2 :=
|
876 |
|
|
Unit_Name (Load_Stack.Table (U + 1).Unit_Number);
|
877 |
|
|
Error_Msg ("$ depends on $!", Load_Msg_Sloc);
|
878 |
|
|
end loop;
|
879 |
|
|
end if;
|
880 |
|
|
end Write_Dependency_Chain;
|
881 |
|
|
|
882 |
|
|
end Lib.Load;
|