From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/par-load.adb | 475 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 475 insertions(+) create mode 100644 gcc/ada/par-load.adb (limited to 'gcc/ada/par-load.adb') diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb new file mode 100644 index 000000000..e30ffc02a --- /dev/null +++ b/gcc/ada/par-load.adb @@ -0,0 +1,475 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . L O A D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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 -- CODEFIX + ("$$ 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 -- CODEFIX + ("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, + PMES => (Cur_Unum = Main_Unit)); + + -- If we successfully load the unit, then set the spec/body pointers. + -- 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)); + Set_Library_Unit (Cunit (Unum), Curunit); + + -- 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 + -- and this is also where we generate the SCO's for this spec. + + if Cur_Unum = Main_Unit then + Main_Unit_Entity := Cunit_Entity (Unum); + + if Generate_SCO then + SCO_Record (Unum); + end if; + 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 => False, + 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; -- cgit v1.2.3