467 lines
18 KiB
Ada
467 lines
18 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- P A R . L O A D --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
|
|
-- --
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
-- for more details. You should have received a copy of the GNU General --
|
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
-- The Par.Load procedure loads all units that are definitely required before
|
|
-- it makes any sense at all to proceed with semantic analysis, including
|
|
-- with'ed units, corresponding specs for bodies, parents of child specs,
|
|
-- and parents of subunits. All these units are loaded and pointers installed
|
|
-- in the tree as described in the spec of package Lib.
|
|
|
|
with Fname.UF; use Fname.UF;
|
|
with Lib.Load; use Lib.Load;
|
|
with Namet.Sp; use Namet.Sp;
|
|
with Uname; use Uname;
|
|
with Osint; use Osint;
|
|
with Sinput.L; use Sinput.L;
|
|
with Stylesw; use Stylesw;
|
|
with Validsw; use Validsw;
|
|
|
|
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
|
|
|
|
separate (Par)
|
|
procedure Load is
|
|
|
|
File_Name : File_Name_Type;
|
|
-- Name of file for current unit, derived from unit name
|
|
|
|
Cur_Unum : constant Unit_Number_Type := Current_Source_Unit;
|
|
-- Unit number of unit that we just finished parsing. Note that we need
|
|
-- to capture this, because Source_Unit will change as we parse new
|
|
-- source files in the multiple main source file case.
|
|
|
|
Curunit : constant Node_Id := Cunit (Cur_Unum);
|
|
-- Compilation unit node for current compilation unit
|
|
|
|
Loc : Source_Ptr := Sloc (Curunit);
|
|
-- Source location for compilation unit node
|
|
|
|
Save_Style_Check : Boolean;
|
|
Save_Style_Checks : Style_Check_Options;
|
|
-- Save style check so it can be restored later
|
|
|
|
Save_Validity_Check : Boolean;
|
|
Save_Validity_Checks : Validity_Check_Options;
|
|
-- Save validity check so it can be restored later
|
|
|
|
With_Cunit : Node_Id;
|
|
-- Compilation unit node for withed unit
|
|
|
|
Context_Node : Node_Id;
|
|
-- Next node in context items list
|
|
|
|
With_Node : Node_Id;
|
|
-- N_With_Clause node
|
|
|
|
Spec_Name : Unit_Name_Type;
|
|
-- Unit name of required spec
|
|
|
|
Body_Name : Unit_Name_Type;
|
|
-- Unit name of corresponding body
|
|
|
|
Unum : Unit_Number_Type;
|
|
-- Unit number of loaded unit
|
|
|
|
Limited_With_Found : Boolean := False;
|
|
-- We load the context items in two rounds: the first round handles normal
|
|
-- withed units and the second round handles Ada 2005 limited-withed units.
|
|
-- This is required to allow the low-level circuitry that detects circular
|
|
-- dependencies of units the correct notification of errors (see comment
|
|
-- bellow). This variable is used to indicate that the second round is
|
|
-- required.
|
|
|
|
function Same_File_Name_Except_For_Case
|
|
(Expected_File_Name : File_Name_Type;
|
|
Actual_File_Name : File_Name_Type) return Boolean;
|
|
-- Given an actual file name and an expected file name (the latter being
|
|
-- derived from the unit name), determine if they are the same except for
|
|
-- possibly different casing of letters.
|
|
|
|
------------------------------------
|
|
-- Same_File_Name_Except_For_Case --
|
|
------------------------------------
|
|
|
|
function Same_File_Name_Except_For_Case
|
|
(Expected_File_Name : File_Name_Type;
|
|
Actual_File_Name : File_Name_Type) return Boolean
|
|
is
|
|
begin
|
|
Get_Name_String (Actual_File_Name);
|
|
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
|
|
|
declare
|
|
Lower_Case_Actual_File_Name : String (1 .. Name_Len);
|
|
|
|
begin
|
|
Lower_Case_Actual_File_Name := Name_Buffer (1 .. Name_Len);
|
|
Get_Name_String (Expected_File_Name);
|
|
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
|
return Lower_Case_Actual_File_Name = Name_Buffer (1 .. Name_Len);
|
|
end;
|
|
|
|
end Same_File_Name_Except_For_Case;
|
|
|
|
-- Start of processing for Load
|
|
|
|
begin
|
|
-- Don't do any loads if we already had a fatal error
|
|
|
|
if Fatal_Error (Cur_Unum) then
|
|
return;
|
|
end if;
|
|
|
|
Save_Style_Check_Options (Save_Style_Checks);
|
|
Save_Style_Check := Opt.Style_Check;
|
|
|
|
Save_Validity_Check_Options (Save_Validity_Checks);
|
|
Save_Validity_Check := Opt.Validity_Checks_On;
|
|
|
|
-- If main unit, set Main_Unit_Entity (this will get overwritten if
|
|
-- the main unit has a separate spec, that happens later on in Load)
|
|
|
|
if Cur_Unum = Main_Unit then
|
|
Main_Unit_Entity := Cunit_Entity (Main_Unit);
|
|
end if;
|
|
|
|
-- If we have no unit name, things are seriously messed up by previous
|
|
-- errors, and we should not try to continue compilation.
|
|
|
|
if Unit_Name (Cur_Unum) = No_Unit_Name then
|
|
raise Unrecoverable_Error;
|
|
end if;
|
|
|
|
-- Next step, make sure that the unit name matches the file name
|
|
-- and issue a warning message if not. We only output this for the
|
|
-- main unit, since for other units it is more serious and is
|
|
-- caught in a separate test below. We also inhibit the message in
|
|
-- multiple unit per file mode, because in this case the relation
|
|
-- between file name and unit name is broken.
|
|
|
|
File_Name :=
|
|
Get_File_Name
|
|
(Unit_Name (Cur_Unum),
|
|
Subunit => Nkind (Unit (Cunit (Cur_Unum))) = N_Subunit);
|
|
|
|
if Cur_Unum = Main_Unit
|
|
and then Multiple_Unit_Index = 0
|
|
and then File_Name /= Unit_File_Name (Cur_Unum)
|
|
and then (File_Names_Case_Sensitive
|
|
or not Same_File_Name_Except_For_Case
|
|
(File_Name, Unit_File_Name (Cur_Unum)))
|
|
then
|
|
Error_Msg_File_1 := File_Name;
|
|
Error_Msg
|
|
("?file name does not match unit name, should be{", Sloc (Curunit));
|
|
end if;
|
|
|
|
-- For units other than the main unit, the expected unit name is set and
|
|
-- must be the same as the actual unit name, or we are in big trouble, and
|
|
-- abandon the compilation since there are situations where this really
|
|
-- gets us into bad trouble (e.g. some subunit situations).
|
|
|
|
if Cur_Unum /= Main_Unit
|
|
and then Expected_Unit (Cur_Unum) /= Unit_Name (Cur_Unum)
|
|
then
|
|
Loc := Error_Location (Cur_Unum);
|
|
Error_Msg_File_1 := Unit_File_Name (Cur_Unum);
|
|
Get_Name_String (Error_Msg_File_1);
|
|
|
|
-- Check for predefined file case
|
|
|
|
if Name_Len > 1
|
|
and then Name_Buffer (2) = '-'
|
|
and then (Name_Buffer (1) = 'a'
|
|
or else
|
|
Name_Buffer (1) = 's'
|
|
or else
|
|
Name_Buffer (1) = 'i'
|
|
or else
|
|
Name_Buffer (1) = 'g')
|
|
then
|
|
declare
|
|
Expect_Name : constant Unit_Name_Type := Expected_Unit (Cur_Unum);
|
|
Actual_Name : constant Unit_Name_Type := Unit_Name (Cur_Unum);
|
|
|
|
begin
|
|
Error_Msg_Unit_1 := Expect_Name;
|
|
Error_Msg ("$$ is not a predefined library unit!", Loc);
|
|
|
|
-- In the predefined file case, we know the user did not
|
|
-- construct their own package, but we got the wrong one.
|
|
-- This means that the name supplied by the user crunched
|
|
-- to something we recognized, but then the file did not
|
|
-- contain the unit expected. Most likely this is due to
|
|
-- a misspelling, e.g.
|
|
|
|
-- with Ada.Calender;
|
|
|
|
-- This crunches to a-calend, which indeed contains the unit
|
|
-- Ada.Calendar, and we can diagnose the misspelling. This
|
|
-- is a simple heuristic, but it catches many common cases
|
|
-- of misspelling of predefined unit names without needing
|
|
-- a full list of them.
|
|
|
|
-- Before actually issuing the message, we will check that the
|
|
-- unit name is indeed a plausible misspelling of the one we got.
|
|
|
|
if Is_Bad_Spelling_Of
|
|
(Name_Id (Expect_Name), Name_Id (Actual_Name))
|
|
then
|
|
Error_Msg_Unit_1 := Actual_Name;
|
|
Error_Msg ("possible misspelling of $$!", Loc);
|
|
end if;
|
|
end;
|
|
|
|
-- Non-predefined file name case. In this case we generate a message
|
|
-- and then we quit, because we are in big trouble, and if we try
|
|
-- to continue compilation, we get into some nasty situations
|
|
-- (for example in some subunit cases).
|
|
|
|
else
|
|
Error_Msg ("file { does not contain expected unit!", Loc);
|
|
Error_Msg_Unit_1 := Expected_Unit (Cur_Unum);
|
|
Error_Msg ("\\expected unit $!", Loc);
|
|
Error_Msg_Unit_1 := Unit_Name (Cur_Unum);
|
|
Error_Msg ("\\found unit $!", Loc);
|
|
end if;
|
|
|
|
-- In both cases, remove the unit if it is the last unit (which it
|
|
-- normally (always?) will be) so that it is out of the way later.
|
|
|
|
Remove_Unit (Cur_Unum);
|
|
end if;
|
|
|
|
-- If current unit is a body, load its corresponding spec
|
|
|
|
if Nkind (Unit (Curunit)) = N_Package_Body
|
|
or else Nkind (Unit (Curunit)) = N_Subprogram_Body
|
|
then
|
|
Spec_Name := Get_Spec_Name (Unit_Name (Cur_Unum));
|
|
Unum :=
|
|
Load_Unit
|
|
(Load_Name => Spec_Name,
|
|
Required => False,
|
|
Subunit => False,
|
|
Error_Node => Curunit,
|
|
Corr_Body => Cur_Unum);
|
|
|
|
-- If we successfully load the unit, then set the spec pointer. Once
|
|
-- again note that if the loaded unit has a fatal error, Load will
|
|
-- have set our Fatal_Error flag to propagate this condition.
|
|
|
|
if Unum /= No_Unit then
|
|
Set_Library_Unit (Curunit, Cunit (Unum));
|
|
|
|
-- If this is a separate spec for the main unit, then we reset
|
|
-- Main_Unit_Entity to point to the entity for this separate spec
|
|
|
|
if Cur_Unum = Main_Unit then
|
|
Main_Unit_Entity := Cunit_Entity (Unum);
|
|
end if;
|
|
|
|
-- If we don't find the spec, then if we have a subprogram body, we
|
|
-- are still OK, we just have a case of a body acting as its own spec
|
|
|
|
elsif Nkind (Unit (Curunit)) = N_Subprogram_Body then
|
|
Set_Acts_As_Spec (Curunit, True);
|
|
Set_Library_Unit (Curunit, Curunit);
|
|
|
|
-- Otherwise we do have an error, repeat the load request for the spec
|
|
-- with Required set True to generate an appropriate error message.
|
|
|
|
else
|
|
Unum :=
|
|
Load_Unit
|
|
(Load_Name => Spec_Name,
|
|
Required => True,
|
|
Subunit => False,
|
|
Error_Node => Curunit);
|
|
return;
|
|
end if;
|
|
|
|
-- If current unit is a child unit spec, load its parent. If the child unit
|
|
-- is loaded through a limited with, the parent must be as well.
|
|
|
|
elsif Nkind (Unit (Curunit)) = N_Package_Declaration
|
|
or else Nkind (Unit (Curunit)) = N_Subprogram_Declaration
|
|
or else Nkind (Unit (Curunit)) in N_Generic_Declaration
|
|
or else Nkind (Unit (Curunit)) in N_Generic_Instantiation
|
|
or else Nkind (Unit (Curunit)) in N_Renaming_Declaration
|
|
then
|
|
-- Turn style and validity checks off for parent unit
|
|
|
|
if not GNAT_Mode then
|
|
Reset_Style_Check_Options;
|
|
Reset_Validity_Check_Options;
|
|
end if;
|
|
|
|
Spec_Name := Get_Parent_Spec_Name (Unit_Name (Cur_Unum));
|
|
|
|
if Spec_Name /= No_Unit_Name then
|
|
Unum :=
|
|
Load_Unit
|
|
(Load_Name => Spec_Name,
|
|
Required => True,
|
|
Subunit => False,
|
|
Error_Node => Curunit);
|
|
|
|
if Unum /= No_Unit then
|
|
Set_Parent_Spec (Unit (Curunit), Cunit (Unum));
|
|
end if;
|
|
end if;
|
|
|
|
-- If current unit is a subunit, then load its parent body
|
|
|
|
elsif Nkind (Unit (Curunit)) = N_Subunit then
|
|
Body_Name := Get_Parent_Body_Name (Unit_Name (Cur_Unum));
|
|
Unum :=
|
|
Load_Unit
|
|
(Load_Name => Body_Name,
|
|
Required => True,
|
|
Subunit => True,
|
|
Error_Node => Name (Unit (Curunit)));
|
|
|
|
if Unum /= No_Unit then
|
|
Set_Library_Unit (Curunit, Cunit (Unum));
|
|
end if;
|
|
end if;
|
|
|
|
-- Now we load with'ed units, with style/validity checks turned off
|
|
|
|
if not GNAT_Mode then
|
|
Reset_Style_Check_Options;
|
|
Reset_Validity_Check_Options;
|
|
end if;
|
|
|
|
-- Load the context items in two rounds: the first round handles normal
|
|
-- withed units and the second round handles Ada 2005 limited-withed units.
|
|
-- This is required to allow the low-level circuitry that detects circular
|
|
-- dependencies of units the correct notification of the following error:
|
|
|
|
-- limited with D;
|
|
-- with D; with C;
|
|
-- package C is ... package D is ...
|
|
|
|
for Round in 1 .. 2 loop
|
|
Context_Node := First (Context_Items (Curunit));
|
|
while Present (Context_Node) loop
|
|
|
|
-- During the first round we check if there is some limited-with
|
|
-- context clause; otherwise the second round will be skipped
|
|
|
|
if Nkind (Context_Node) = N_With_Clause
|
|
and then Round = 1
|
|
and then Limited_Present (Context_Node)
|
|
then
|
|
Limited_With_Found := True;
|
|
end if;
|
|
|
|
if Nkind (Context_Node) = N_With_Clause
|
|
and then ((Round = 1 and then not Limited_Present (Context_Node))
|
|
or else
|
|
(Round = 2 and then Limited_Present (Context_Node)))
|
|
then
|
|
With_Node := Context_Node;
|
|
Spec_Name := Get_Unit_Name (With_Node);
|
|
|
|
Unum :=
|
|
Load_Unit
|
|
(Load_Name => Spec_Name,
|
|
Required => False,
|
|
Subunit => False,
|
|
Error_Node => With_Node,
|
|
Renamings => True,
|
|
With_Node => Context_Node);
|
|
|
|
-- If we find the unit, then set spec pointer in the N_With_Clause
|
|
-- to point to the compilation unit for the spec. Remember that
|
|
-- the Load routine itself sets our Fatal_Error flag if the loaded
|
|
-- unit gets a fatal error, so we don't need to worry about that.
|
|
|
|
if Unum /= No_Unit then
|
|
Set_Library_Unit (With_Node, Cunit (Unum));
|
|
|
|
-- If the spec isn't found, then try finding the corresponding
|
|
-- body, since it is possible that we have a subprogram body
|
|
-- that is acting as a spec (since no spec is present).
|
|
|
|
else
|
|
Body_Name := Get_Body_Name (Spec_Name);
|
|
Unum :=
|
|
Load_Unit
|
|
(Load_Name => Body_Name,
|
|
Required => False,
|
|
Subunit => False,
|
|
Error_Node => With_Node,
|
|
Renamings => True);
|
|
|
|
-- If we got a subprogram body, then mark that we are using
|
|
-- the body as a spec in the file table, and set the spec
|
|
-- pointer in the N_With_Clause to point to the body entity.
|
|
|
|
if Unum /= No_Unit
|
|
and then Nkind (Unit (Cunit (Unum))) = N_Subprogram_Body
|
|
then
|
|
With_Cunit := Cunit (Unum);
|
|
Set_Library_Unit (With_Node, With_Cunit);
|
|
Set_Acts_As_Spec (With_Cunit, True);
|
|
Set_Library_Unit (With_Cunit, With_Cunit);
|
|
|
|
-- If we couldn't find the body, or if it wasn't a body spec
|
|
-- then we are in trouble. We make one more call to Load to
|
|
-- require the spec. We know it will fail of course, the
|
|
-- purpose is to generate the required error message (we prefer
|
|
-- that this message refer to the missing spec, not the body)
|
|
|
|
else
|
|
Unum :=
|
|
Load_Unit
|
|
(Load_Name => Spec_Name,
|
|
Required => True,
|
|
Subunit => False,
|
|
Error_Node => With_Node,
|
|
Renamings => True);
|
|
|
|
-- Here we create a dummy package unit for the missing unit
|
|
|
|
Unum := Create_Dummy_Package_Unit (With_Node, Spec_Name);
|
|
Set_Library_Unit (With_Node, Cunit (Unum));
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
Next (Context_Node);
|
|
end loop;
|
|
|
|
exit when not Limited_With_Found;
|
|
end loop;
|
|
|
|
-- Restore style/validity check mode for main unit
|
|
|
|
Set_Style_Check_Options (Save_Style_Checks);
|
|
Opt.Style_Check := Save_Style_Check;
|
|
Set_Validity_Check_Options (Save_Validity_Checks);
|
|
Opt.Validity_Checks_On := Save_Validity_Check;
|
|
end Load;
|