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