diff options
author | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 10:18:40 -0400 |
---|---|---|
committer | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 10:18:40 -0400 |
commit | 38cbfe40a046b12a3d9bc56e6cf76d86c458ef39 (patch) | |
tree | 6570bc15069492ca4f53a85c5d09a36d099fd63f /gcc/ada/lib-load.adb | |
parent | 70482933d8f6a73b660f4cfa97b5c7c9deaf152e (diff) | |
download | gcc-38cbfe40a046b12a3d9bc56e6cf76d86c458ef39.zip gcc-38cbfe40a046b12a3d9bc56e6cf76d86c458ef39.tar.gz gcc-38cbfe40a046b12a3d9bc56e6cf76d86c458ef39.tar.bz2 |
New Language: Ada
From-SVN: r45955
Diffstat (limited to 'gcc/ada/lib-load.adb')
-rw-r--r-- | gcc/ada/lib-load.adb | 717 |
1 files changed, 717 insertions, 0 deletions
diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb new file mode 100644 index 0000000..b1f18d5 --- /dev/null +++ b/gcc/ada/lib-load.adb @@ -0,0 +1,717 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . L O A D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.86 $ +-- -- +-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Errout; use Errout; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Par; +with Scn; use Scn; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Sinput.L; use Sinput.L; +with Tbuild; use Tbuild; +with Uname; use Uname; + +package body Lib.Load is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Spec_Is_Irrelevant + (Spec_Unit : Unit_Number_Type; + Body_Unit : Unit_Number_Type) + return Boolean; + -- The Spec_Unit and Body_Unit parameters are the unit numbers of the + -- spec file that corresponds to the main unit which is a body. This + -- function determines if the spec file is irrelevant and will be + -- overridden by the body as described in RM 10.1.4(4). See description + -- in "Special Handling of Subprogram Bodies" for further details. + + procedure Write_Dependency_Chain; + -- This procedure is used to generate error message info lines that + -- trace the current dependency chain when a load error occurs. + + ------------------------------- + -- Create_Dummy_Package_Unit -- + ------------------------------- + + function Create_Dummy_Package_Unit + (With_Node : Node_Id; + Spec_Name : Unit_Name_Type) + return Unit_Number_Type + is + Unum : Unit_Number_Type; + Cunit_Entity : Entity_Id; + Cunit : Node_Id; + Du_Name : Node_Or_Entity_Id; + End_Lab : Node_Id; + Save_CS : constant Boolean := Get_Comes_From_Source_Default; + + begin + -- The created dummy package unit does not come from source + + Set_Comes_From_Source_Default (False); + + -- Normal package + + if Nkind (Name (With_Node)) = N_Identifier then + Cunit_Entity := + Make_Defining_Identifier (No_Location, + Chars => Chars (Name (With_Node))); + Du_Name := Cunit_Entity; + End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location); + + -- Child package + + else -- Nkind (Name (With_Node)) = N_Expanded_Name + Cunit_Entity := + Make_Defining_Identifier (No_Location, + Chars => Chars (Selector_Name (Name (With_Node)))); + Du_Name := + Make_Defining_Program_Unit_Name (No_Location, + Name => New_Copy_Tree (Prefix (Name (With_Node))), + Defining_Identifier => Cunit_Entity); + End_Lab := + Make_Designator (No_Location, + Name => New_Copy_Tree (Prefix (Name (With_Node))), + Identifier => New_Occurrence_Of (Cunit_Entity, No_Location)); + end if; + + Cunit := + Make_Compilation_Unit (No_Location, + Context_Items => Empty_List, + Unit => + Make_Package_Declaration (No_Location, + Specification => + Make_Package_Specification (No_Location, + Defining_Unit_Name => Du_Name, + Visible_Declarations => Empty_List, + End_Label => End_Lab)), + Aux_Decls_Node => + Make_Compilation_Unit_Aux (No_Location)); + + Units.Increment_Last; + Unum := Units.Last; + + Units.Table (Unum) := ( + Cunit => Cunit, + Cunit_Entity => Cunit_Entity, + Dependency_Num => 0, + Dependent_Unit => False, + Dynamic_Elab => False, + Error_Location => Sloc (With_Node), + Expected_Unit => Spec_Name, + Fatal_Error => True, + Generate_Code => False, + Has_RACW => False, + Ident_String => Empty, + Loading => False, + Main_Priority => Default_Main_Priority, + Serial_Number => 0, + Source_Index => No_Source_File, + Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False), + Unit_Name => Spec_Name, + Version => 0); + + Set_Comes_From_Source_Default (Save_CS); + Set_Error_Posted (Cunit_Entity); + Set_Error_Posted (Cunit); + return Unum; + end Create_Dummy_Package_Unit; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + Fname : File_Name_Type; + + begin + Units.Init; + Load_Stack.Init; + Load_Stack.Increment_Last; + Load_Stack.Table (Load_Stack.Last) := Main_Unit; + + -- Initialize unit table entry for Main_Unit. Note that we don't know + -- the unit name yet, that gets filled in when the parser parses the + -- main unit, at which time a check is made that it matches the main + -- file name, and then the Unit_Name field is set. The Cunit and + -- Cunit_Entity fields also get filled in later by the parser. + + Units.Increment_Last; + Fname := Next_Main_Source; + + Units.Table (Main_Unit).Unit_File_Name := Fname; + + if Fname /= No_File then + + Main_Source_File := Load_Source_File (Fname); + Current_Error_Source_File := Main_Source_File; + + Units.Table (Main_Unit) := ( + Cunit => Empty, + Cunit_Entity => Empty, + Dependency_Num => 0, + Dependent_Unit => True, + Dynamic_Elab => False, + Error_Location => No_Location, + Expected_Unit => No_Name, + Fatal_Error => False, + Generate_Code => False, + Has_RACW => False, + Loading => True, + Ident_String => Empty, + Main_Priority => Default_Main_Priority, + Serial_Number => 0, + Source_Index => Main_Source_File, + Unit_File_Name => Fname, + Unit_Name => No_Name, + Version => Source_Checksum (Main_Source_File)); + end if; + end Initialize; + + ------------------------ + -- Initialize_Version -- + ------------------------ + + procedure Initialize_Version (U : Unit_Number_Type) is + begin + Units.Table (U).Version := Source_Checksum (Source_Index (U)); + end Initialize_Version; + + --------------- + -- Load_Unit -- + --------------- + + function Load_Unit + (Load_Name : Unit_Name_Type; + Required : Boolean; + Error_Node : Node_Id; + Subunit : Boolean; + Corr_Body : Unit_Number_Type := No_Unit; + Renamings : Boolean := False) + return Unit_Number_Type + is + Calling_Unit : Unit_Number_Type; + Uname_Actual : Unit_Name_Type; + Unum : Unit_Number_Type; + Unump : Unit_Number_Type; + Fname : File_Name_Type; + Src_Ind : Source_File_Index; + Discard : List_Id; + + procedure Set_Load_Unit_Dependency (U : Unit_Number_Type); + -- Sets the Dependent_Unit flag unless we have a predefined unit + -- being loaded in No_Run_Time mode. In this case we do not want + -- to create a dependency, since we have loaded the unit only + -- to inline stuff from it. If this is not the case, an error + -- message will be issued in Rtsfind in any case. + + procedure Set_Load_Unit_Dependency (U : Unit_Number_Type) is + begin + if No_Run_Time + and then Is_Internal_File_Name (Unit_File_Name (U)) + then + null; + else + Units.Table (U).Dependent_Unit := True; + end if; + end Set_Load_Unit_Dependency; + + -- Start of processing for Load_Unit + + begin + -- If renamings are allowed and we have a child unit name, then we + -- must first load the parent to deal with finding the real name. + + if Renamings and then Is_Child_Name (Load_Name) then + Unump := + Load_Unit + (Load_Name => Get_Parent_Spec_Name (Load_Name), + Required => Required, + Subunit => False, + Renamings => True, + Error_Node => Error_Node); + + if Unump = No_Unit then + return No_Unit; + end if; + + -- If parent is a renaming, then we use the renamed package as + -- the actual parent for the subsequent load operation. + + if Nkind (Parent (Cunit_Entity (Unump))) = + N_Package_Renaming_Declaration + then + Uname_Actual := + New_Child + (Load_Name, + Get_Unit_Name (Name (Parent (Cunit_Entity (Unump))))); + + -- Save the renaming entity, to establish its visibility when + -- installing the context. The implicit with is on this entity, + -- not on the package it renames. + + if Nkind (Error_Node) = N_With_Clause + and then Nkind (Name (Error_Node)) = N_Selected_Component + then + declare + Par : Node_Id := Name (Error_Node); + + begin + while Nkind (Par) = N_Selected_Component + and then Chars (Selector_Name (Par)) /= + Chars (Cunit_Entity (Unump)) + loop + Par := Prefix (Par); + end loop; + + if Nkind (Par) = N_Selected_Component then + -- some intermediate parent is a renaming. + + Set_Entity (Selector_Name (Par), Cunit_Entity (Unump)); + + else + -- the ultimate parent is a renaming. + + Set_Entity (Par, Cunit_Entity (Unump)); + end if; + end; + end if; + + -- If the parent is not a renaming, then get its name (this may + -- be different from the parent spec name obtained above because + -- of renamings higher up in the hierarchy). + + else + Uname_Actual := New_Child (Load_Name, Unit_Name (Unump)); + end if; + + -- Here if unit to be loaded is not a child unit + + else + Uname_Actual := Load_Name; + end if; + + Fname := Get_File_Name (Uname_Actual, Subunit); + + if Debug_Flag_L then + Write_Eol; + Write_Str ("*** Load request for unit: "); + Write_Unit_Name (Load_Name); + + if Required then + Write_Str (" (Required = True)"); + else + Write_Str (" (Required = False)"); + end if; + + Write_Eol; + + if Uname_Actual /= Load_Name then + Write_Str ("*** Actual unit loaded: "); + Write_Unit_Name (Uname_Actual); + end if; + end if; + + -- Capture error location if it is for the main unit. The idea is to + -- post errors on the main unit location, not the most recent unit. + + if Present (Error_Node) then + + -- It seems like In_Extended_Main_Source_Unit (Error_Node) would + -- do the trick here, but that's wrong, it is much too early to + -- call this routine. We are still in the parser, and the required + -- semantic information is not established yet. So we base the + -- judgment on unit names. + + Get_External_Unit_Name_String (Unit_Name (Main_Unit)); + + declare + Main_Unit_Name : constant String := Name_Buffer (1 .. Name_Len); + + begin + Get_External_Unit_Name_String + (Unit_Name (Get_Source_Unit (Error_Node))); + + -- If the two names are identical, then for sure we are part + -- of the extended main unit + + if Main_Unit_Name = Name_Buffer (1 .. Name_Len) then + Load_Msg_Sloc := Sloc (Error_Node); + + -- If the load is called from a with_type clause, the error + -- node is correct. + + elsif Nkind (Parent (Error_Node)) = N_With_Type_Clause then + Load_Msg_Sloc := Sloc (Error_Node); + + -- Otherwise, check for the subunit case, and if so, consider + -- we have a match if one name is a prefix of the other name. + + else + if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit + or else + Nkind (Unit (Cunit (Get_Source_Unit (Error_Node)))) = + N_Subunit + then + Name_Len := Integer'Min (Name_Len, Main_Unit_Name'Length); + + if Name_Buffer (1 .. Name_Len) + = + Main_Unit_Name (1 .. Name_Len) + then + Load_Msg_Sloc := Sloc (Error_Node); + end if; + end if; + end if; + end; + end if; + + -- If we are generating error messages, then capture calling unit + + if Present (Error_Node) then + Calling_Unit := Get_Source_Unit (Error_Node); + else + Calling_Unit := No_Unit; + end if; + + -- See if we already have an entry for this unit + + Unum := Main_Unit; + + while Unum <= Units.Last loop + exit when Uname_Actual = Units.Table (Unum).Unit_Name; + Unum := Unum + 1; + end loop; + + -- Whether or not the entry was found, Unum is now the right value, + -- since it is one more than Units.Last (i.e. the index of the new + -- entry we will create) in the not found case. + + -- A special check is necessary in the unit not found case. If the unit + -- is not found, but the file in which it lives has already been loaded, + -- then we have the problem that the file does not contain the unit that + -- is needed. We simply treat this as a file not found condition. + + if Unum > Units.Last then + for J in Units.First .. Units.Last loop + if Fname = Units.Table (J).Unit_File_Name then + if Debug_Flag_L then + Write_Str (" file does not contain unit, Unit_Number = "); + Write_Int (Int (Unum)); + Write_Eol; + Write_Eol; + end if; + + if Present (Error_Node) then + + if Is_Predefined_File_Name (Fname) then + Error_Msg_Name_1 := Uname_Actual; + Error_Msg + ("% is not a language defined unit", Load_Msg_Sloc); + else + Error_Msg_Name_1 := Fname; + Error_Msg_Unit_1 := Uname_Actual; + Error_Msg + ("File{ does not contain unit$", Load_Msg_Sloc); + end if; + + Write_Dependency_Chain; + return No_Unit; + + else + return No_Unit; + end if; + end if; + end loop; + end if; + + -- If we are proceeding with load, then make load stack entry + + Load_Stack.Increment_Last; + Load_Stack.Table (Load_Stack.Last) := Unum; + + -- Case of entry already in table + + if Unum <= Units.Last then + + -- Here is where we check for a circular dependency, which is + -- an attempt to load a unit which is currently in the process + -- of being loaded. We do *not* care about a circular chain that + -- leads back to a body, because this kind of circular dependence + -- legitimately occurs (e.g. two package bodies that contain + -- inlined subprogram referenced by the other). + + if Loading (Unum) + and then (Is_Spec_Name (Units.Table (Unum).Unit_Name) + or else Acts_As_Spec (Units.Table (Unum).Cunit)) + then + if Debug_Flag_L then + Write_Str (" circular dependency encountered"); + Write_Eol; + end if; + + if Present (Error_Node) then + Error_Msg ("circular unit dependency", Load_Msg_Sloc); + Write_Dependency_Chain; + else + Load_Stack.Decrement_Last; + end if; + + return No_Unit; + end if; + + if Debug_Flag_L then + Write_Str (" unit already in file table, Unit_Number = "); + Write_Int (Int (Unum)); + Write_Eol; + end if; + + Load_Stack.Decrement_Last; + Set_Load_Unit_Dependency (Unum); + return Unum; + + -- File is not already in table, so try to open it + + else + if Debug_Flag_L then + Write_Str (" attempt unit load, Unit_Number = "); + Write_Int (Int (Unum)); + Write_Eol; + end if; + + Src_Ind := Load_Source_File (Fname); + + -- Make a partial entry in the file table, used even in the file not + -- found case to print the dependency chain including the last entry + + Units.Increment_Last; + Units.Table (Unum).Unit_Name := Uname_Actual; + + -- File was found + + if Src_Ind /= No_Source_File then + Units.Table (Unum) := ( + Cunit => Empty, + Cunit_Entity => Empty, + Dependency_Num => 0, + Dependent_Unit => False, + Dynamic_Elab => False, + Error_Location => Sloc (Error_Node), + Expected_Unit => Uname_Actual, + Fatal_Error => False, + Generate_Code => False, + Has_RACW => False, + Ident_String => Empty, + Loading => True, + Main_Priority => Default_Main_Priority, + Serial_Number => 0, + Source_Index => Src_Ind, + Unit_File_Name => Fname, + Unit_Name => Uname_Actual, + Version => Source_Checksum (Src_Ind)); + + -- Parse the new unit + + Initialize_Scanner (Unum, Source_Index (Unum)); + Discard := Par (Configuration_Pragmas => False); + Set_Loading (Unum, False); + + -- If spec is irrelevant, then post errors and quit + + if Corr_Body /= No_Unit + and then Spec_Is_Irrelevant (Unum, Corr_Body) + then + Error_Msg_Name_1 := Unit_File_Name (Corr_Body); + Error_Msg + ("cannot compile subprogram in file {!", + Load_Msg_Sloc); + Error_Msg_Name_1 := Unit_File_Name (Unum); + Error_Msg + ("incorrect spec in file { must be removed first!", + Load_Msg_Sloc); + return No_Unit; + end if; + + -- If loaded unit had a fatal error, then caller inherits it! + + if Units.Table (Unum).Fatal_Error + and then Present (Error_Node) + then + Units.Table (Calling_Unit).Fatal_Error := True; + end if; + + -- Remove load stack entry and return the entry in the file table + + Load_Stack.Decrement_Last; + Set_Load_Unit_Dependency (Unum); + return Unum; + + -- Case of file not found + + else + if Debug_Flag_L then + Write_Str (" file was not found, load failed"); + Write_Eol; + end if; + + -- Generate message if unit required + + if Required and then Present (Error_Node) then + + if Is_Predefined_File_Name (Fname) then + Error_Msg_Name_1 := Uname_Actual; + Error_Msg + ("% is not a predefined library unit", Load_Msg_Sloc); + + else + Error_Msg_Name_1 := Fname; + Error_Msg ("file{ not found", Load_Msg_Sloc); + end if; + + Write_Dependency_Chain; + + -- Remove unit from stack, to avoid cascaded errors on + -- subsequent missing files. + + Load_Stack.Decrement_Last; + Units.Decrement_Last; + + -- If unit not required, remove load stack entry and the junk + -- file table entry, and return No_Unit to indicate not found, + + else + Load_Stack.Decrement_Last; + Units.Decrement_Last; + end if; + + return No_Unit; + end if; + end if; + end Load_Unit; + + ------------------------ + -- Make_Instance_Unit -- + ------------------------ + + -- If the unit is an instance, it appears as a package declaration, but + -- contains both declaration and body of the instance. The body becomes + -- the main unit of the compilation, and the declaration is inserted + -- at the end of the unit table. The main unit now has the name of a + -- body, which is constructed from the name of the original spec, + -- and is attached to the compilation node of the original unit. The + -- declaration has been attached to a new compilation unit node, and + -- code will have to be generated for it. + + procedure Make_Instance_Unit (N : Node_Id) is + Sind : constant Source_File_Index := Source_Index (Main_Unit); + + begin + Units.Increment_Last; + + Units.Table (Units.Last) := Units.Table (Main_Unit); + Units.Table (Units.Last).Cunit := Library_Unit (N); + Units.Table (Units.Last).Generate_Code := True; + + Units.Table (Main_Unit).Cunit := N; + Units.Table (Main_Unit).Unit_Name := + Get_Body_Name (Unit_Name (Get_Cunit_Unit_Number (Library_Unit (N)))); + Units.Table (Main_Unit).Version := Source_Checksum (Sind); + end Make_Instance_Unit; + + ------------------------ + -- Spec_Is_Irrelevant -- + ------------------------ + + function Spec_Is_Irrelevant + (Spec_Unit : Unit_Number_Type; + Body_Unit : Unit_Number_Type) + return Boolean + is + Sunit : constant Node_Id := Cunit (Spec_Unit); + Bunit : constant Node_Id := Cunit (Body_Unit); + + begin + -- The spec is irrelevant if the body is a subprogram body, and the + -- spec is other than a subprogram spec or generic subprogram spec. + -- Note that the names must be the same, we don't need to check that, + -- because we already know that from the fact that the file names are + -- the same. + + return + Nkind (Unit (Bunit)) = N_Subprogram_Body + and then Nkind (Unit (Sunit)) /= N_Subprogram_Declaration + and then Nkind (Unit (Sunit)) /= N_Generic_Subprogram_Declaration; + + end Spec_Is_Irrelevant; + + -------------------- + -- Version_Update -- + -------------------- + + procedure Version_Update (U : Node_Id; From : Node_Id) is + Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (U); + Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From); + + begin + Units.Table (Unum).Version := + Units.Table (Unum).Version + xor + Source_Checksum (Source_Index (Fnum)); + end Version_Update; + + ---------------------------- + -- Write_Dependency_Chain -- + ---------------------------- + + procedure Write_Dependency_Chain is + begin + -- The dependency chain is only written if it is at least two entries + -- deep, otherwise it is trivial (the main unit depending on a unit + -- that it obviously directly depends on). + + if Load_Stack.Last - 1 > Load_Stack.First then + for U in Load_Stack.First .. Load_Stack.Last - 1 loop + Error_Msg_Unit_1 := Unit_Name (Load_Stack.Table (U)); + Error_Msg_Unit_2 := Unit_Name (Load_Stack.Table (U + 1)); + Error_Msg ("$ depends on $!", Load_Msg_Sloc); + end loop; + end if; + end Write_Dependency_Chain; + +end Lib.Load; |