From ff78da98ddfae807fe4102d183c4739fa1db0eff Mon Sep 17 00:00:00 2001 From: charlet Date: Fri, 10 Sep 2010 13:53:51 +0000 Subject: [PATCH] 2010-09-10 Vincent Celier * vms_data.ads: Add new GNAT BIND qualifiers /32_MALLOC (for -H32) and /64_MALLOC (for -H64). 2010-09-10 Robert Dewar * errout.adb (Error_Msg_Internal): Test Parsing_Main_Subunit flag (Error_Msg_NW): Test Parsing_Main_Subunit flag * errout.ads (Parsing_Main_Subunit): New flag * lib-load.adb (Load_Unit): Set Parsing_Main_Subunit flag * par-ch6.adb: Minor style fix (remove redandant parentheses) * par-ch9.adb: Minor style fix (remove redundant parens) * par-load.adb: (Load): Deal with setting Parsing_Main_Subunit 2010-09-10 Vincent Celier * make.adb (Create_Binder_Mapping_File): Remove procedure. Replaced by function of the same name in Makeutl. (Gnatmake): Call function Create_Binder_Mapping_File in Makeutl, instead of removed procedure when creating a binder mapping file. * makeutl.adb (Create_Binder_Mapping_File): New function. Was a procedure in Make. * makeutl.ads (Create_Binder_Mapping_File): New function git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@164176 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 25 +++++++ gcc/ada/errout.adb | 7 +- gcc/ada/errout.ads | 14 +++- gcc/ada/lib-load.adb | 15 +++- gcc/ada/make.adb | 191 ++------------------------------------------------- gcc/ada/makeutl.adb | 178 +++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/makeutl.ads | 3 + gcc/ada/par-ch6.adb | 2 +- gcc/ada/par-ch9.adb | 4 +- gcc/ada/par-load.adb | 36 ++++++---- gcc/ada/vms_data.ads | 16 +++++ 11 files changed, 282 insertions(+), 209 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c86e6235c8a..c39e7c72181 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2010-09-10 Vincent Celier + + * vms_data.ads: Add new GNAT BIND qualifiers /32_MALLOC (for -H32) and + /64_MALLOC (for -H64). + +2010-09-10 Robert Dewar + + * errout.adb (Error_Msg_Internal): Test Parsing_Main_Subunit flag + (Error_Msg_NW): Test Parsing_Main_Subunit flag + * errout.ads (Parsing_Main_Subunit): New flag + * lib-load.adb (Load_Unit): Set Parsing_Main_Subunit flag + * par-ch6.adb: Minor style fix (remove redandant parentheses) + * par-ch9.adb: Minor style fix (remove redundant parens) + * par-load.adb: (Load): Deal with setting Parsing_Main_Subunit + +2010-09-10 Vincent Celier + + * make.adb (Create_Binder_Mapping_File): Remove procedure. Replaced by + function of the same name in Makeutl. + (Gnatmake): Call function Create_Binder_Mapping_File in Makeutl, instead + of removed procedure when creating a binder mapping file. + * makeutl.adb (Create_Binder_Mapping_File): New function. Was a + procedure in Make. + * makeutl.ads (Create_Binder_Mapping_File): New function + 2010-09-10 Jose Ruiz * exp_cg.adb (Is_Predefined_Dispatching_Operation): Add the "__" scope diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 26cfc6fbeb1..d3701cbd864 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -748,7 +748,9 @@ package body Errout is -- If the flag location is in the main extended source unit then for -- sure we want the warning since it definitely belongs - if In_Extended_Main_Source_Unit (Sptr) then + if Parsing_Main_Subunit + or else In_Extended_Main_Source_Unit (Sptr) + then null; -- If the flag location is not in the main extended source unit, then @@ -1157,7 +1159,8 @@ package body Errout is is begin if Eflag - and then In_Extended_Main_Source_Unit (N) + and then (Parsing_Main_Subunit + or else In_Extended_Main_Source_Unit (N)) and then Comes_From_Source (N) then Error_Msg_NEL (Msg, N, N, Sloc (N)); diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 4aea9d87d6d..29fa5d18bc2 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -63,9 +63,17 @@ package Errout is type Compiler_State_Type is (Parsing, Analyzing); Compiler_State : Compiler_State_Type; -- Indicates current state of compilation. This is put in the Errout spec - -- because it affects the action of the error message handling. In - -- particular, an attempt is made by Errout to suppress cascaded error - -- messages in Parsing mode, but not in the other modes. + -- because it affects the handling of error messages. In particular, an + -- attempt is made by Errout to suppress cascaded error messages in Parsing + -- mode, but not in the other modes. + + Parsing_Main_Subunit : Boolean := False; + -- Set True if we are currently parsing a subunit that is part of the main + -- extended source. We need this flag, since the In_Main_Extended_Source + -- test may produce an improper False value if called too early during the + -- parsing process. This is put in the Errout spec because it affects error + -- message handling. In particular, warnings and style messages during + -- parsing are only generated if this flag is set to True. Current_Error_Source_File : Source_File_Index renames Err_Vars.Current_Error_Source_File; diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 535dddc6e8b..977511aab77 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- 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- -- @@ -513,7 +513,6 @@ package body Lib.Load is -- 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; @@ -658,12 +657,22 @@ package body Lib.Load is -- Parse the new unit declare - Save_Index : constant Nat := Multiple_Unit_Index; + Save_Index : constant Nat := Multiple_Unit_Index; + Save_PMS : constant Boolean := Parsing_Main_Subunit; + begin Multiple_Unit_Index := Get_Unit_Index (Uname_Actual); Units.Table (Unum).Munit_Index := Multiple_Unit_Index; Initialize_Scanner (Unum, Source_Index (Unum)); + + if Calling_Unit = Main_Unit and then Subunit then + Parsing_Main_Subunit := True; + end if; + Discard_List (Par (Configuration_Pragmas => False)); + + Parsing_Main_Subunit := Save_PMS; + Multiple_Unit_Index := Save_Index; Set_Loading (Unum, False); end; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 16f1d40a34a..79a8390569f 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -4136,10 +4136,6 @@ package body Make is -- Check that the main subprograms do exist and that they all -- belong to the same project file. - procedure Create_Binder_Mapping_File - (Args : in out Argument_List; Last_Arg : in out Natural); - -- Create a binder mapping file and add the necessary switch - ----------------- -- Check_Mains -- ----------------- @@ -4282,185 +4278,6 @@ package body Make is end loop; end Check_Mains; - -------------------------------- - -- Create_Binder_Mapping_File -- - -------------------------------- - - procedure Create_Binder_Mapping_File - (Args : in out Argument_List; Last_Arg : in out Natural) - is - Mapping_FD : File_Descriptor := Invalid_FD; - -- A File Descriptor for an eventual mapping file - - ALI_Unit : Unit_Name_Type := No_Unit_Name; - -- The unit name of an ALI file - - ALI_Name : File_Name_Type := No_File; - -- The file name of the ALI file - - ALI_Project : Project_Id := No_Project; - -- The project of the ALI file - - Bytes : Integer; - OK : Boolean := True; - Unit : Unit_Index; - - Status : Boolean; - -- For call to Close - - begin - Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path); - Record_Temp_File (Project_Tree, Mapping_Path); - - if Mapping_FD /= Invalid_FD then - - -- Traverse all units - - Unit := Units_Htable.Get_First (Project_Tree.Units_HT); - - while Unit /= No_Unit_Index loop - if Unit.Name /= No_Name then - - -- If there is a body, put it in the mapping - - if Unit.File_Names (Impl) /= No_Source - and then Unit.File_Names (Impl).Project /= - No_Project - then - Get_Name_String (Unit.Name); - Add_Str_To_Name_Buffer ("%b"); - ALI_Unit := Name_Find; - ALI_Name := - Lib_File_Name - (Unit.File_Names (Impl).Display_File); - ALI_Project := Unit.File_Names (Impl).Project; - - -- Otherwise, if there is a spec, put it in the mapping - - elsif Unit.File_Names (Spec) /= No_Source - and then Unit.File_Names (Spec).Project /= No_Project - then - Get_Name_String (Unit.Name); - Add_Str_To_Name_Buffer ("%s"); - ALI_Unit := Name_Find; - ALI_Name := - Lib_File_Name - (Unit.File_Names (Spec).Display_File); - ALI_Project := Unit.File_Names (Spec).Project; - - else - ALI_Name := No_File; - end if; - - -- If we have something to put in the mapping then do it - -- now. However, if the project is extended, we don't put - -- anything in the mapping file, because we don't know where - -- the ALI file is: it might be in the extended project - -- object directory as well as in the extending project - -- object directory. - - if ALI_Name /= No_File - and then ALI_Project.Extended_By = No_Project - and then ALI_Project.Extends = No_Project - then - -- First check if the ALI file exists. If it does not, - -- do not put the unit in the mapping file. - - declare - ALI : constant String := Get_Name_String (ALI_Name); - - begin - -- For library projects, use the library directory, - -- for other projects, use the object directory. - - if ALI_Project.Library then - Get_Name_String (ALI_Project.Library_Dir.Name); - else - Get_Name_String - (ALI_Project.Object_Directory.Display_Name); - end if; - - if not - Is_Directory_Separator (Name_Buffer (Name_Len)) - then - Add_Char_To_Name_Buffer (Directory_Separator); - end if; - - Add_Str_To_Name_Buffer (ALI); - Add_Char_To_Name_Buffer (ASCII.LF); - - declare - ALI_Path_Name : constant String := - Name_Buffer (1 .. Name_Len); - - begin - if Is_Regular_File - (ALI_Path_Name (1 .. ALI_Path_Name'Last - 1)) - then - -- First line is the unit name - - Get_Name_String (ALI_Unit); - Add_Char_To_Name_Buffer (ASCII.LF); - Bytes := - Write - (Mapping_FD, - Name_Buffer (1)'Address, - Name_Len); - OK := Bytes = Name_Len; - - exit when not OK; - - -- Second line it the ALI file name - - Get_Name_String (ALI_Name); - Add_Char_To_Name_Buffer (ASCII.LF); - Bytes := - Write - (Mapping_FD, - Name_Buffer (1)'Address, - Name_Len); - OK := (Bytes = Name_Len); - - exit when not OK; - - -- Third line it the ALI path name - - Bytes := - Write - (Mapping_FD, - ALI_Path_Name (1)'Address, - ALI_Path_Name'Length); - OK := (Bytes = ALI_Path_Name'Length); - - -- If OK is False, it means we were unable to - -- write a line. No point in continuing with the - -- other units. - - exit when not OK; - end if; - end; - end; - end if; - end if; - - Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); - end loop; - - Close (Mapping_FD, Status); - - OK := OK and Status; - - -- If the creation of the mapping file was successful, we add the - -- switch to the arguments of gnatbind. - - if OK then - Last_Arg := Last_Arg + 1; - Args (Last_Arg) := - new String'("-F=" & Get_Name_String (Mapping_Path)); - end if; - end if; - end Create_Binder_Mapping_File; - -- Start of processing for Gnatmake -- This body is very long, should be broken down??? @@ -6013,7 +5830,13 @@ package body Make is -- If switch -C was specified, create a binder mapping file if Create_Mapping_File then - Create_Binder_Mapping_File (Args, Last_Arg); + Mapping_Path := Create_Binder_Mapping_File; + + if Mapping_Path /= No_Path then + Last_Arg := Last_Arg + 1; + Args (Last_Arg) := + new String'("-F=" & Get_Name_String (Mapping_Path)); + end if; end if; end if; diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index e07bebbad6b..a11f2613496 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -34,6 +34,7 @@ with Prj.Ext; with Prj.Util; with Snames; use Snames; with Table; +with Tempdir; with Ada.Command_Line; use Ada.Command_Line; @@ -295,6 +296,183 @@ package body Makeutl is return True; end Check_Source_Info_In_ALI; + -------------------------------- + -- Create_Binder_Mapping_File -- + -------------------------------- + + function Create_Binder_Mapping_File return Path_Name_Type is + Mapping_Path : Path_Name_Type := No_Path; + + Mapping_FD : File_Descriptor := Invalid_FD; + -- A File Descriptor for an eventual mapping file + + ALI_Unit : Unit_Name_Type := No_Unit_Name; + -- The unit name of an ALI file + + ALI_Name : File_Name_Type := No_File; + -- The file name of the ALI file + + ALI_Project : Project_Id := No_Project; + -- The project of the ALI file + + Bytes : Integer; + OK : Boolean := False; + Unit : Unit_Index; + + Status : Boolean; + -- For call to Close + + begin + Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path); + Record_Temp_File (Project_Tree, Mapping_Path); + + if Mapping_FD /= Invalid_FD then + OK := True; + + -- Traverse all units + + Unit := Units_Htable.Get_First (Project_Tree.Units_HT); + while Unit /= No_Unit_Index loop + if Unit.Name /= No_Name then + + -- If there is a body, put it in the mapping + + if Unit.File_Names (Impl) /= No_Source + and then Unit.File_Names (Impl).Project /= No_Project + then + Get_Name_String (Unit.Name); + Add_Str_To_Name_Buffer ("%b"); + ALI_Unit := Name_Find; + ALI_Name := + Lib_File_Name (Unit.File_Names (Impl).Display_File); + ALI_Project := Unit.File_Names (Impl).Project; + + -- Otherwise, if there is a spec, put it in the mapping + + elsif Unit.File_Names (Spec) /= No_Source + and then Unit.File_Names (Spec).Project /= No_Project + then + Get_Name_String (Unit.Name); + Add_Str_To_Name_Buffer ("%s"); + ALI_Unit := Name_Find; + ALI_Name := + Lib_File_Name (Unit.File_Names (Spec).Display_File); + ALI_Project := Unit.File_Names (Spec).Project; + + else + ALI_Name := No_File; + end if; + + -- If we have something to put in the mapping then do it now. + -- However, if the project is extended, we don't put anything + -- in the mapping file, since we don't know where the ALI file + -- is: it might be in the extended project object directory as + -- well as in the extending project object directory. + + if ALI_Name /= No_File + and then ALI_Project.Extended_By = No_Project + and then ALI_Project.Extends = No_Project + then + -- First check if the ALI file exists. If it does not, do + -- not put the unit in the mapping file. + + declare + ALI : constant String := Get_Name_String (ALI_Name); + + begin + -- For library projects, use the library ALI directory, + -- for other projects, use the object directory. + + if ALI_Project.Library then + Get_Name_String + (ALI_Project.Library_ALI_Dir.Display_Name); + else + Get_Name_String + (ALI_Project.Object_Directory.Display_Name); + end if; + + if not + Is_Directory_Separator (Name_Buffer (Name_Len)) + then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Add_Str_To_Name_Buffer (ALI); + Add_Char_To_Name_Buffer (ASCII.LF); + + declare + ALI_Path_Name : constant String := + Name_Buffer (1 .. Name_Len); + + begin + if Is_Regular_File + (ALI_Path_Name (1 .. ALI_Path_Name'Last - 1)) + then + -- First line is the unit name + + Get_Name_String (ALI_Unit); + Add_Char_To_Name_Buffer (ASCII.LF); + Bytes := + Write + (Mapping_FD, + Name_Buffer (1)'Address, + Name_Len); + OK := Bytes = Name_Len; + + exit when not OK; + + -- Second line it the ALI file name + + Get_Name_String (ALI_Name); + Add_Char_To_Name_Buffer (ASCII.LF); + Bytes := + Write + (Mapping_FD, + Name_Buffer (1)'Address, + Name_Len); + OK := (Bytes = Name_Len); + + exit when not OK; + + -- Third line it the ALI path name + + Bytes := + Write + (Mapping_FD, + ALI_Path_Name (1)'Address, + ALI_Path_Name'Length); + OK := (Bytes = ALI_Path_Name'Length); + + -- If OK is False, it means we were unable to + -- write a line. No point in continuing with the + -- other units. + + exit when not OK; + end if; + end; + end; + end if; + end if; + + Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); + end loop; + + Close (Mapping_FD, Status); + + OK := OK and Status; + end if; + + -- If the creation of the mapping file was successful, we add the switch + -- to the arguments of gnatbind. + + if OK then + return Mapping_Path; + + else + return No_Path; + end if; + end Create_Binder_Mapping_File; + ----------------- -- Create_Name -- ----------------- diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index f1557a5a334..bb1c91515cb 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -70,6 +70,9 @@ package Makeutl is Last : in out Natural); -- Add a string to a list of strings + function Create_Binder_Mapping_File return Path_Name_Type; + -- Create a binder mapping file and returns its path name + function Create_Name (Name : String) return File_Name_Type; function Create_Name (Name : String) return Name_Id; function Create_Name (Name : String) return Path_Name_Type; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index fc9a3741366..3830e05cb1a 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -211,7 +211,7 @@ package body Ch6 is Is_Overriding := True; end if; - if (Is_Overriding or else Not_Overriding) then + if Is_Overriding or else Not_Overriding then -- Note that if we are not in Ada_05 mode, error messages have -- already been given, so no need to give another message here. diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index 23b27c7774e..1388a92e143 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -639,7 +639,7 @@ package body Ch9 is Is_Overriding := True; end if; - if (Is_Overriding or else Not_Overriding) then + if Is_Overriding or else Not_Overriding then if Ada_Version < Ada_05 then Error_Msg_SP ("overriding indicator is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); @@ -823,7 +823,7 @@ package body Ch9 is Is_Overriding := True; end if; - if (Is_Overriding or else Not_Overriding) then + if Is_Overriding or else Not_Overriding then if Ada_Version < Ada_05 then Error_Msg_SP ("overriding indicator is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb index 9aa08423805..5f236e95dfc 100644 --- a/gcc/ada/par-load.adb +++ b/gcc/ada/par-load.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- 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- -- @@ -268,9 +268,9 @@ begin Error_Node => Curunit, Corr_Body => Cur_Unum); - -- 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 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)); @@ -342,17 +342,25 @@ begin -- 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))); + declare + Save_PMS : constant Boolean := Parsing_Main_Subunit; - if Unum /= No_Unit then - Set_Library_Unit (Curunit, Cunit (Unum)); - end if; + begin + Parsing_Main_Subunit := False; + 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; + + Parsing_Main_Subunit := Save_PMS; + end; end if; -- Now we load with'ed units, with style/validity checks turned off diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index ba15a27e49b..aab456c0512 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -353,6 +353,20 @@ package VMS_Data is -- -- The main program is not in Ada. + S_Bind_Alloc32 : aliased constant S := "/32_MALLOC " & + "-H32"; + -- /32_MALLOC + -- + -- Use 32-bit allocations for `__gnat_malloc' (and thus for + -- access types). + + S_Bind_Alloc64 : aliased constant S := "/64_MALLOC " & + "-H64"; + -- /64_MALLOC + -- + -- Use 64-bit allocations for `__gnat_malloc' (and thus for + -- access types). + S_Bind_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & "DEFAULT " & "-vP0 " & @@ -694,6 +708,8 @@ package VMS_Data is S_Bind_Library 'Access, S_Bind_Linker 'Access, S_Bind_Main 'Access, + S_Bind_Alloc32 'Access, + S_Bind_Alloc64 'Access, S_Bind_Mess 'Access, S_Bind_Nostinc 'Access, S_Bind_Nostlib 'Access, -- 2.11.0