From 67b8ac46a606b677b20b3834beb2d24c27c86e8c Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 4 Jan 2013 10:25:59 +0100 Subject: [multiple changes] 2013-01-04 Robert Dewar * exp_util.adb (Remove_Side_Effects): Make sure scope suppress is restored on exit. 2013-01-04 Robert Dewar * usage.adb: Document -gnateF (check overflow for predefined Float). 2013-01-04 Robert Dewar * sem_res.adb (Resolve_Type_Conversion): Remove incorrect prevention of call to Apply_Type_Conversion_Checks, which resulted in missing check flags in formal mode. 2013-01-04 Vincent Celier * makeutl.ads (Db_Switch_Args): New table used by gprbuild. * prj-conf.adb (Check_Builder_Switches): Check for switches --config= (Get_Db_Switches): New procedure to get the --db switches so that they are used when invoking gprconfig in auto-configuration. (Do_Autoconf): When invoking gprconfig, use the --db switches, if any. From-SVN: r194894 --- gcc/ada/ChangeLog | 24 +++ gcc/ada/exp_util.adb | 19 +- gcc/ada/makeutl.ads | 9 + gcc/ada/prj-conf.adb | 534 ++++++++++++++++++++++++++++----------------------- gcc/ada/sem_res.adb | 9 +- gcc/ada/usage.adb | 5 + 6 files changed, 344 insertions(+), 256 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 85ee0f7..4276837 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +2013-01-04 Robert Dewar + + * exp_util.adb (Remove_Side_Effects): Make sure scope suppress + is restored on exit. + +2013-01-04 Robert Dewar + + * usage.adb: Document -gnateF (check overflow for predefined Float). + +2013-01-04 Robert Dewar + + * sem_res.adb (Resolve_Type_Conversion): Remove incorrect + prevention of call to Apply_Type_Conversion_Checks, which resulted + in missing check flags in formal mode. + +2013-01-04 Vincent Celier + + * makeutl.ads (Db_Switch_Args): New table used by gprbuild. + * prj-conf.adb (Check_Builder_Switches): Check for switches + --config= (Get_Db_Switches): New procedure to get the --db + switches so that they are used when invoking gprconfig in + auto-configuration. + (Do_Autoconf): When invoking gprconfig, use the --db switches, if any. + 2013-01-04 Pascal Obry * prj-nmsc.adb: Minor reformatting. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index b6afb8f..883effe 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6712,8 +6712,8 @@ package body Exp_Util is or else Nkind (N) = N_Selected_Component then return Within_In_Parameter (Prefix (N)); - else + else return False; end if; end Within_In_Parameter; @@ -6743,7 +6743,10 @@ package body Exp_Util is return; end if; - -- All this must not have any checks + -- The remaining procesaing is done with all checks suppressed + + -- Note: from now on, don't use return statements, instead do a goto + -- Leave, to ensure that we properly restore Scope_Suppress.Suppress. Scope_Suppress.Suppress := (others => True); @@ -6809,8 +6812,7 @@ package body Exp_Util is and then Nkind (Expression (Exp)) = N_Explicit_Dereference then Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref); - Scope_Suppress := Svg_Suppress; - return; + goto Leave; -- If this is a type conversion, leave the type conversion and remove -- the side effects in the expression. This is important in several @@ -6820,8 +6822,7 @@ package body Exp_Util is elsif Nkind (Exp) = N_Type_Conversion then Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref); - Scope_Suppress := Svg_Suppress; - return; + goto Leave; -- If this is an unchecked conversion that Gigi can't handle, make -- a copy or a use a renaming to capture the value. @@ -6935,7 +6936,7 @@ package body Exp_Util is if Alfa_Mode and then Nkind (Parent (Exp)) = N_Object_Declaration then - return; + goto Leave; end if; -- Special processing for function calls that return a limited type. @@ -6965,7 +6966,7 @@ package body Exp_Util is Insert_Action (Exp, Decl); Set_Etype (Obj, Exp_Type); Rewrite (Exp, New_Occurrence_Of (Obj, Loc)); - return; + goto Leave; end; end if; @@ -7064,6 +7065,8 @@ package body Exp_Util is Rewrite (Exp, Res); Analyze_And_Resolve (Exp, Exp_Type); + + <> Scope_Suppress := Svg_Suppress; end Remove_Side_Effects; diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 9570fef..37e9f61 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -82,6 +82,15 @@ package Makeutl is Load_Standard_Base : Boolean := True; -- False when gprbuild is called with --db- + package Db_Switch_Args is new Table.Table + (Table_Component_Type => Name_Id, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 100, + Table_Name => "Makegpr.Db_Switch_Args"); + -- Table of all the arguments of --db switches of gprbuild + package Directories is new Table.Table (Table_Component_Type => Path_Name_Type, Table_Index_Type => Integer, diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index 4e799b6..2a00c09 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -621,6 +621,10 @@ package body Prj.Conf is -- Set to True if at least one attribute Ide'Compiler_Command is -- specified for one language of the system. + Conf_File_Name : String_Access := new String'(Config_File_Name); + -- The configuration project file name. May be modified if there are + -- switches --config= in the Builder package of the main project. + function Default_File_Name return String; -- Return the name of the default config file that should be tested @@ -629,11 +633,14 @@ package body Prj.Conf is -- raises the Invalid_Config exception with an appropriate message procedure Check_Builder_Switches; - -- Check for switch --RTS in package Builder + -- Check for switches --config and --RTS in package Builder function Get_Config_Switches return Argument_List_Access; -- Return the --config switches to use for gprconfig + function Get_Db_Switches return Argument_List_Access; + -- Return the --db switches to use for gprconfig + function Might_Have_Sources (Project : Project_Id) return Boolean; -- True if the specified project might have sources (ie the user has not -- explicitly specified it. We haven't checked the file system, nor do @@ -681,7 +688,14 @@ package body Prj.Conf is if Switch.Value /= No_Name then Get_Name_String (Switch.Value); - if Get_RTS_Switches + if Conf_File_Name'Length = 0 and then + Name_Len > 9 and then + Name_Buffer (1 .. 9) = "--config=" + then + Conf_File_Name := + new String'(Name_Buffer (10 .. Name_Len)); + + elsif Get_RTS_Switches and then Name_Len >= 7 and then Name_Buffer (1 .. 5) = "--RTS" then @@ -791,238 +805,6 @@ package body Prj.Conf is end if; end Default_File_Name; - ------------------------ - -- Might_Have_Sources -- - ------------------------ - - function Might_Have_Sources (Project : Project_Id) return Boolean is - Variable : Variable_Value; - - begin - Variable := - Value_Of - (Name_Source_Dirs, - Project.Decl.Attributes, - Shared); - - if Variable = Nil_Variable_Value - or else Variable.Default - or else Variable.Values /= Nil_String - then - Variable := - Value_Of - (Name_Source_Files, - Project.Decl.Attributes, - Shared); - return Variable = Nil_Variable_Value - or else Variable.Default - or else Variable.Values /= Nil_String; - - else - return False; - end if; - end Might_Have_Sources; - - ------------------------- - -- Get_Config_Switches -- - ------------------------- - - function Get_Config_Switches return Argument_List_Access is - - package Language_Htable is new GNAT.HTable.Simple_HTable - (Header_Num => Prj.Header_Num, - Element => Name_Id, - No_Element => No_Name, - Key => Name_Id, - Hash => Prj.Hash, - Equal => "="); - -- Hash table to keep the languages used in the project tree - - IDE : constant Package_Id := - Value_Of (Name_Ide, Project.Decl.Packages, Shared); - - procedure Add_Config_Switches_For_Project - (Project : Project_Id; - Tree : Project_Tree_Ref; - With_State : in out Integer); - -- Add all --config switches for this project. This is also called - -- for aggregate projects. - - ------------------------------------- - -- Add_Config_Switches_For_Project -- - ------------------------------------- - - procedure Add_Config_Switches_For_Project - (Project : Project_Id; - Tree : Project_Tree_Ref; - With_State : in out Integer) - is - pragma Unreferenced (With_State); - - Shared : constant Shared_Project_Tree_Data_Access := Tree.Shared; - - Variable : Variable_Value; - Check_Default : Boolean; - Lang : Name_Id; - List : String_List_Id; - Elem : String_Element; - - begin - if Might_Have_Sources (Project) then - Variable := - Value_Of (Name_Languages, Project.Decl.Attributes, Shared); - - if Variable = Nil_Variable_Value or else Variable.Default then - - -- Languages is not declared. If it is not an extending - -- project, or if it extends a project with no Languages, - -- check for Default_Language. - - Check_Default := Project.Extends = No_Project; - - if not Check_Default then - Variable := - Value_Of - (Name_Languages, - Project.Extends.Decl.Attributes, - Shared); - Check_Default := - Variable /= Nil_Variable_Value - and then Variable.Values = Nil_String; - end if; - - if Check_Default then - Variable := - Value_Of - (Name_Default_Language, - Project.Decl.Attributes, - Shared); - - if Variable /= Nil_Variable_Value - and then not Variable.Default - then - Get_Name_String (Variable.Value); - To_Lower (Name_Buffer (1 .. Name_Len)); - Lang := Name_Find; - Language_Htable.Set (Lang, Lang); - - -- If no default language is declared, default to Ada - - else - Language_Htable.Set (Name_Ada, Name_Ada); - end if; - end if; - - elsif Variable.Values /= Nil_String then - - -- Attribute Languages is declared with a non empty list: - -- put all the languages in Language_HTable. - - List := Variable.Values; - while List /= Nil_String loop - Elem := Shared.String_Elements.Table (List); - - Get_Name_String (Elem.Value); - To_Lower (Name_Buffer (1 .. Name_Len)); - Lang := Name_Find; - Language_Htable.Set (Lang, Lang); - - List := Elem.Next; - end loop; - end if; - end if; - end Add_Config_Switches_For_Project; - - procedure For_Every_Imported_Project is new For_Every_Project_Imported - (State => Integer, Action => Add_Config_Switches_For_Project); - -- Document this procedure ??? - - -- Local variables - - Name : Name_Id; - Count : Natural; - Result : Argument_List_Access; - Variable : Variable_Value; - Dummy : Integer := 0; - - -- Start of processing for Get_Config_Switches - - begin - For_Every_Imported_Project - (By => Project, - Tree => Project_Tree, - With_State => Dummy, - Include_Aggregated => True); - - Name := Language_Htable.Get_First; - Count := 0; - while Name /= No_Name loop - Count := Count + 1; - Name := Language_Htable.Get_Next; - end loop; - - Result := new String_List (1 .. Count); - - Count := 1; - Name := Language_Htable.Get_First; - while Name /= No_Name loop - - -- Check if IDE'Compiler_Command is declared for the language. - -- If it is, use its value to invoke gprconfig. - - Variable := - Value_Of - (Name, - Attribute_Or_Array_Name => Name_Compiler_Command, - In_Package => IDE, - Shared => Shared, - Force_Lower_Case_Index => True); - - declare - Config_Command : constant String := - "--config=" & Get_Name_String (Name); - - Runtime_Name : constant String := - Runtime_Name_For (Name); - - begin - if Variable = Nil_Variable_Value - or else Length_Of_Name (Variable.Value) = 0 - then - Result (Count) := - new String'(Config_Command & ",," & Runtime_Name); - - else - At_Least_One_Compiler_Command := True; - - declare - Compiler_Command : constant String := - Get_Name_String (Variable.Value); - - begin - if Is_Absolute_Path (Compiler_Command) then - Result (Count) := - new String' - (Config_Command & ",," & Runtime_Name & "," & - Containing_Directory (Compiler_Command) & "," & - Simple_Name (Compiler_Command)); - else - Result (Count) := - new String' - (Config_Command & ",," & Runtime_Name & ",," & - Compiler_Command); - end if; - end; - end if; - end; - - Count := Count + 1; - Name := Language_Htable.Get_Next; - end loop; - - return Result; - end Get_Config_Switches; - ----------------- -- Do_Autoconf -- ----------------- @@ -1083,6 +865,7 @@ package body Prj.Conf is declare Obj_Dir : constant String := Name_Buffer (1 .. Name_Len); Config_Switches : Argument_List_Access; + Db_Switches : Argument_List_Access; Args : Argument_List (1 .. 5); Arg_Last : Positive; Obj_Dir_Exists : Boolean := True; @@ -1134,6 +917,10 @@ package body Prj.Conf is Config_Switches := Get_Config_Switches; + -- Get eventual --db switches + + Db_Switches := Get_Db_Switches; + -- Invoke gprconfig Args (1) := new String'("--batch"); @@ -1141,7 +928,7 @@ package body Prj.Conf is -- If no config file was specified, set the auto.cgpr one - if Config_File_Name'Length = 0 then + if Conf_File_Name'Length = 0 then if Obj_Dir_Exists then Args (3) := new String'(Obj_Dir & Auto_Cgpr); @@ -1179,7 +966,7 @@ package body Prj.Conf is end; end if; else - Args (3) := new String'(Config_File_Name); + Args (3) := Conf_File_Name; end if; if Normalized_Hostname = "" then @@ -1253,6 +1040,11 @@ package body Prj.Conf is Write_Str (Config_Switches (J).all); end loop; + for J in Db_Switches'Range loop + Write_Char (' '); + Write_Str (Db_Switches (J).all); + end loop; + Write_Eol; elsif not Quiet_Output then @@ -1269,7 +1061,7 @@ package body Prj.Conf is end if; Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) & - Config_Switches.all, + Config_Switches.all & Db_Switches.all, Success); Free (Config_Switches); @@ -1287,6 +1079,266 @@ package body Prj.Conf is end; end Do_Autoconf; + --------------------- + -- Get_Db_Switches -- + --------------------- + + function Get_Db_Switches return Argument_List_Access is + Result : Argument_List_Access; + Nmb_Arg : Natural; + begin + Nmb_Arg := + (2 * Db_Switch_Args.Last) + Boolean'Pos (not Load_Standard_Base); + Result := new Argument_List (1 .. Nmb_Arg); + + if Nmb_Arg /= 0 then + for J in 1 .. Db_Switch_Args.Last loop + Result (2 * J - 1) := + new String'("--db"); + Result (2 * J) := + new String'(Get_Name_String (Db_Switch_Args.Table (J))); + end loop; + + if not Load_Standard_Base then + Result (Result'Last) := new String'("--db-"); + end if; + end if; + + return Result; + end Get_Db_Switches; + + ------------------------- + -- Get_Config_Switches -- + ------------------------- + + function Get_Config_Switches return Argument_List_Access is + + package Language_Htable is new GNAT.HTable.Simple_HTable + (Header_Num => Prj.Header_Num, + Element => Name_Id, + No_Element => No_Name, + Key => Name_Id, + Hash => Prj.Hash, + Equal => "="); + -- Hash table to keep the languages used in the project tree + + IDE : constant Package_Id := + Value_Of (Name_Ide, Project.Decl.Packages, Shared); + + procedure Add_Config_Switches_For_Project + (Project : Project_Id; + Tree : Project_Tree_Ref; + With_State : in out Integer); + -- Add all --config switches for this project. This is also called + -- for aggregate projects. + + ------------------------------------- + -- Add_Config_Switches_For_Project -- + ------------------------------------- + + procedure Add_Config_Switches_For_Project + (Project : Project_Id; + Tree : Project_Tree_Ref; + With_State : in out Integer) + is + pragma Unreferenced (With_State); + + Shared : constant Shared_Project_Tree_Data_Access := Tree.Shared; + + Variable : Variable_Value; + Check_Default : Boolean; + Lang : Name_Id; + List : String_List_Id; + Elem : String_Element; + + begin + if Might_Have_Sources (Project) then + Variable := + Value_Of (Name_Languages, Project.Decl.Attributes, Shared); + + if Variable = Nil_Variable_Value or else Variable.Default then + + -- Languages is not declared. If it is not an extending + -- project, or if it extends a project with no Languages, + -- check for Default_Language. + + Check_Default := Project.Extends = No_Project; + + if not Check_Default then + Variable := + Value_Of + (Name_Languages, + Project.Extends.Decl.Attributes, + Shared); + Check_Default := + Variable /= Nil_Variable_Value + and then Variable.Values = Nil_String; + end if; + + if Check_Default then + Variable := + Value_Of + (Name_Default_Language, + Project.Decl.Attributes, + Shared); + + if Variable /= Nil_Variable_Value + and then not Variable.Default + then + Get_Name_String (Variable.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Lang := Name_Find; + Language_Htable.Set (Lang, Lang); + + -- If no default language is declared, default to Ada + + else + Language_Htable.Set (Name_Ada, Name_Ada); + end if; + end if; + + elsif Variable.Values /= Nil_String then + + -- Attribute Languages is declared with a non empty list: + -- put all the languages in Language_HTable. + + List := Variable.Values; + while List /= Nil_String loop + Elem := Shared.String_Elements.Table (List); + + Get_Name_String (Elem.Value); + To_Lower (Name_Buffer (1 .. Name_Len)); + Lang := Name_Find; + Language_Htable.Set (Lang, Lang); + + List := Elem.Next; + end loop; + end if; + end if; + end Add_Config_Switches_For_Project; + + procedure For_Every_Imported_Project is new For_Every_Project_Imported + (State => Integer, Action => Add_Config_Switches_For_Project); + -- Document this procedure ??? + + -- Local variables + + Name : Name_Id; + Count : Natural; + Result : Argument_List_Access; + Variable : Variable_Value; + Dummy : Integer := 0; + + -- Start of processing for Get_Config_Switches + + begin + For_Every_Imported_Project + (By => Project, + Tree => Project_Tree, + With_State => Dummy, + Include_Aggregated => True); + + Name := Language_Htable.Get_First; + Count := 0; + while Name /= No_Name loop + Count := Count + 1; + Name := Language_Htable.Get_Next; + end loop; + + Result := new String_List (1 .. Count); + + Count := 1; + Name := Language_Htable.Get_First; + while Name /= No_Name loop + + -- Check if IDE'Compiler_Command is declared for the language. + -- If it is, use its value to invoke gprconfig. + + Variable := + Value_Of + (Name, + Attribute_Or_Array_Name => Name_Compiler_Command, + In_Package => IDE, + Shared => Shared, + Force_Lower_Case_Index => True); + + declare + Config_Command : constant String := + "--config=" & Get_Name_String (Name); + + Runtime_Name : constant String := + Runtime_Name_For (Name); + + begin + if Variable = Nil_Variable_Value + or else Length_Of_Name (Variable.Value) = 0 + then + Result (Count) := + new String'(Config_Command & ",," & Runtime_Name); + + else + At_Least_One_Compiler_Command := True; + + declare + Compiler_Command : constant String := + Get_Name_String (Variable.Value); + + begin + if Is_Absolute_Path (Compiler_Command) then + Result (Count) := + new String' + (Config_Command & ",," & Runtime_Name & "," & + Containing_Directory (Compiler_Command) & "," & + Simple_Name (Compiler_Command)); + else + Result (Count) := + new String' + (Config_Command & ",," & Runtime_Name & ",," & + Compiler_Command); + end if; + end; + end if; + end; + + Count := Count + 1; + Name := Language_Htable.Get_Next; + end loop; + + return Result; + end Get_Config_Switches; + + ------------------------ + -- Might_Have_Sources -- + ------------------------ + + function Might_Have_Sources (Project : Project_Id) return Boolean is + Variable : Variable_Value; + + begin + Variable := + Value_Of + (Name_Source_Dirs, + Project.Decl.Attributes, + Shared); + + if Variable = Nil_Variable_Value + or else Variable.Default + or else Variable.Values /= Nil_String + then + Variable := + Value_Of + (Name_Source_Files, + Project.Decl.Attributes, + Shared); + return Variable = Nil_Variable_Value + or else Variable.Default + or else Variable.Values /= Nil_String; + + else + return False; + end if; + end Might_Have_Sources; + Success : Boolean; Config_Project_Node : Project_Node_Id := Empty_Node; @@ -1298,19 +1350,19 @@ package body Prj.Conf is Check_Builder_Switches; - if Config_File_Name'Length > 0 then - Config_File_Path := Locate_Config_File (Config_File_Name); + if Conf_File_Name'Length > 0 then + Config_File_Path := Locate_Config_File (Conf_File_Name.all); else Config_File_Path := Locate_Config_File (Default_File_Name); end if; if Config_File_Path = null then if (not Allow_Automatic_Generation) - and then Config_File_Name'Length > 0 + and then Conf_File_Name'Length > 0 then Raise_Invalid_Config ("could not locate main configuration project " - & Config_File_Name); + & Conf_File_Name.all); end if; end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 5559f17..a2bc095 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9474,8 +9474,8 @@ package body Sem_Res is and then abs (Realval (Rop)) < Delta_Value (Standard_Duration) then Error_Msg_N - ("??universal real operand can only " & - "be interpreted as Duration!", Rop); + ("??universal real operand can only " + & "be interpreted as Duration!", Rop); Error_Msg_N ("\??precision will be lost in the conversion!", Rop); end if; @@ -9556,11 +9556,6 @@ package body Sem_Res is and then not Is_Generic_Type (Root_Type (Target_Typ)) and then Target_Typ /= Universal_Fixed and then Operand_Typ /= Universal_Fixed - - -- Also skip type conversion checks in formal verification mode, as - -- the formal verification backend deals directly with these checks. - - and then not Alfa_Mode then Apply_Type_Conversion_Checks (N); end if; diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index f96bfe5..436a886 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -202,6 +202,11 @@ begin Write_Switch_Char ("ef"); Write_Line ("Full source path in brief error messages"); + -- Line for -gnateF switch + + Write_Switch_Char ("eF"); + Write_Line ("Check overflow on predefined Float types"); + -- Line for -gnateG switch Write_Switch_Char ("eG"); -- cgit v1.1