From de4ac03852177548570b23729e2dd086737d4404 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 6 Jan 2015 09:57:50 +0100 Subject: [PATCH] [multiple changes] 2015-01-06 Robert Dewar * s-taskin.ads, s-traces.ads: Minor reformatting. * exp_util.adb: Minor typo fix. 2015-01-06 Vincent Celier * gnatls.adb (Search_RTS): Invoke Initialize_Default_Project_Path with the runtime name. * prj-env.adb (Initialize_Default_Project_Path): When both Target_Name and Runtime_Name are not empty string, add to the project path the two directories .../lib/gnat and .../share/gpr related to the runtime. * prj-env.ads (Initialize_Default_Project_Path): New String parameter Runtime_Name, defaulted to the empty string. 2015-01-06 Hristian Kirtchev * frontend.adb: Guard against the case where a configuration pragma may be split into multiple pragmas and the original rewritten as a null statement. * sem_prag.adb (Analyze_Pragma): Insert a brand new Check_Policy pragma using Insert_Before rather than Insert_Action. This takes care of the configuration pragma case where Insert_Action would fail. 2015-01-06 Bob Duff * a-coboho.ads (Element_Access): Add "pragma No_Strict_Aliasing (Element_Access);". This is needed because we are unchecked-converting from Address to Element_Access. * a-cofove.ads, a-cofove.adb (Elems,Elemsc): Fix bounds of the result to be 1. 2015-01-06 Hristian Kirtchev * sem_res.adb (Resolve_Actuals): Remove the restriction which prohibits volatile actual parameters with enabled external propery Async_Writers to act appear in procedure calls where the corresponding formal is of mode OUT. From-SVN: r219222 --- gcc/ada/ChangeLog | 41 ++++++++++++++ gcc/ada/a-coboho.ads | 5 ++ gcc/ada/a-cofove.adb | 9 ++- gcc/ada/a-cofove.ads | 3 +- gcc/ada/exp_util.adb | 2 +- gcc/ada/frontend.adb | 17 ++++-- gcc/ada/gnatls.adb | 8 ++- gcc/ada/prj-env.adb | 129 ++++++++++++++++++++++++++----------------- gcc/ada/prj-env.ads | 18 +++--- gcc/ada/s-taskin.ads | 2 +- gcc/ada/s-traces.ads | 7 +-- gcc/ada/sem_prag.adb | 15 +++-- gcc/ada/sem_res.adb | 26 +++------ 13 files changed, 181 insertions(+), 101 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 02968d71560..562b619524b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2015-01-06 Robert Dewar + + * s-taskin.ads, s-traces.ads: Minor reformatting. + * exp_util.adb: Minor typo fix. + +2015-01-06 Vincent Celier + + * gnatls.adb (Search_RTS): Invoke Initialize_Default_Project_Path + with the runtime name. + * prj-env.adb (Initialize_Default_Project_Path): When both + Target_Name and Runtime_Name are not empty string, add to the + project path the two directories .../lib/gnat and .../share/gpr + related to the runtime. + * prj-env.ads (Initialize_Default_Project_Path): New String + parameter Runtime_Name, defaulted to the empty string. + +2015-01-06 Hristian Kirtchev + + * frontend.adb: Guard against the case where a configuration + pragma may be split into multiple pragmas and the original + rewritten as a null statement. + * sem_prag.adb (Analyze_Pragma): Insert a brand new Check_Policy + pragma using Insert_Before rather than Insert_Action. This + takes care of the configuration pragma case where Insert_Action + would fail. + +2015-01-06 Bob Duff + + * a-coboho.ads (Element_Access): Add "pragma + No_Strict_Aliasing (Element_Access);". This is needed because + we are unchecked-converting from Address to Element_Access. + * a-cofove.ads, a-cofove.adb (Elems,Elemsc): Fix bounds of the + result to be 1. + +2015-01-06 Hristian Kirtchev + + * sem_res.adb (Resolve_Actuals): Remove the + restriction which prohibits volatile actual parameters with + enabled external propery Async_Writers to act appear in procedure + calls where the corresponding formal is of mode OUT. + 2015-01-05 Jakub Jelinek * gnat_ugn.texi: Bump @copying's copyright year. diff --git a/gcc/ada/a-coboho.ads b/gcc/ada/a-coboho.ads index 244c4d41fe9..7e6933e22de 100644 --- a/gcc/ada/a-coboho.ads +++ b/gcc/ada/a-coboho.ads @@ -99,4 +99,9 @@ private -- the 'Address of an array points to the first element, thus losing the -- bounds. + pragma No_Strict_Aliasing (Element_Access); + -- Needed because we are unchecked-converting from Address to + -- Element_Access (see package body), which is a violation of the + -- normal aliasing rules enforced by gcc. + end Ada.Containers.Bounded_Holders; diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index df02dc01ee5..9cfd1328cf2 100644 --- a/gcc/ada/a-cofove.adb +++ b/gcc/ada/a-cofove.adb @@ -45,10 +45,9 @@ is procedure Free is new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr); - type Maximal_Array_Ptr is access all Elements_Array (Capacity_Range) + type Maximal_Array_Ptr is access all Elements_Array (Array_Index) with Storage_Size => 0; - type Maximal_Array_Ptr_Const is access constant - Elements_Array (Capacity_Range) + type Maximal_Array_Ptr_Const is access constant Elements_Array (Array_Index) with Storage_Size => 0; function Elems (Container : in out Vector) return Maximal_Array_Ptr; @@ -111,7 +110,7 @@ is Reserve_Capacity (Container, Capacity_Range'Max (Capacity (Container) * Growth_Factor, - Capacity_Range (New_Length))); + Capacity_Range (New_Length))); end if; if Container.Last = Index_Type'Last then @@ -381,7 +380,7 @@ is is procedure Sort is new Generic_Array_Sort - (Index_Type => Capacity_Range, + (Index_Type => Array_Index, Element_Type => Element_Type, Array_Type => Elements_Array, "<" => "<"); diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads index 0f02017a53b..9e91bc8bae0 100644 --- a/gcc/ada/a-cofove.ads +++ b/gcc/ada/a-cofove.ads @@ -246,7 +246,8 @@ private pragma Inline (Replace_Element); pragma Inline (Contains); - type Elements_Array is array (Capacity_Range range <>) of Element_Type; + subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last; + type Elements_Array is array (Array_Index range <>) of Element_Type; function "=" (L, R : Elements_Array) return Boolean is abstract; type Elements_Array_Ptr is access all Elements_Array; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 381002255c0..f1f6b5290cd 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2961,7 +2961,7 @@ package body Exp_Util is begin -- If parser detected no address clause for the identifier in question, - -- then then answer is a quick NO, without the need for a search. + -- then the answer is a quick NO, without the need for a search. if not Get_Name_Table_Boolean (Chars (Id)) then return Empty; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 5cea4dbba6a..7d24ae03ed9 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -339,10 +339,10 @@ begin and then not Fatal_Error (Main_Unit) then - -- Pragmas that require some semantic activity, such as - -- Interrupt_State, cannot be processed until the main unit - -- is installed, because they require a compilation unit on - -- which to attach with_clauses, etc. So analyze them now. + -- Pragmas that require some semantic activity, such as Interrupt_State, + -- cannot be processed until the main unit is installed, because they + -- require a compilation unit on which to attach with_clauses, etc. So + -- analyze them now. declare Prag : Node_Id; @@ -350,7 +350,14 @@ begin begin Prag := First (Config_Pragmas); while Present (Prag) loop - if Delay_Config_Pragma_Analyze (Prag) then + + -- Guard against the case where a configuration pragma may be + -- split into multiple pragmas and the original rewritten as a + -- null statement. + + if Nkind (Prag) = N_Pragma + and then Delay_Config_Pragma_Analyze (Prag) + then Analyze_Pragma (Prag); end if; diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index 80875b52ffe..6ef23a24253 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -1225,6 +1225,10 @@ procedure Gnatls is if Src_Path /= null and then Lib_Path /= null then Add_Search_Dirs (Src_Path, Include); Add_Search_Dirs (Lib_Path, Objects); + Initialize_Default_Project_Path + (Prj_Path, + Target_Name => Sdefault.Target_Name.all, + Runtime_Name => Name); return; end if; @@ -1237,7 +1241,9 @@ procedure Gnatls is -- Try to find the RTS on the project path. First setup the project path Initialize_Default_Project_Path - (Prj_Path, Target_Name => Sdefault.Target_Name.all); + (Prj_Path, + Target_Name => Sdefault.Target_Name.all, + Runtime_Name => Name); Rts_Full_Path := Get_Runtime_Path (Prj_Path, Name); diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 7dbb4ce7c8c..dd60df9b308 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -1873,8 +1873,9 @@ package body Prj.Env is ------------------------------------- procedure Initialize_Default_Project_Path - (Self : in out Project_Search_Path; - Target_Name : String) + (Self : in out Project_Search_Path; + Target_Name : String; + Runtime_Name : String := "") is Add_Default_Dir : Boolean := Target_Name /= "-"; First : Positive; @@ -1894,6 +1895,24 @@ package body Prj.Env is -- The path name(s) of directories where project files may reside. -- May be empty. + Prefix : String_Ptr; + Runtime : String_Ptr; + + procedure Add_Target; + + procedure Add_Target is + begin + Add_Str_To_Name_Buffer + (Path_Separator & Prefix.all & Target_Name); + + -- Note: Target_Name has a trailing / when it comes from + -- Sdefault. + + if Name_Buffer (Name_Len) /= '/' then + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + end Add_Target; + begin if Is_Initialized (Self) then return; @@ -2051,73 +2070,81 @@ package body Prj.Env is -- Set the initial value of Current_Project_Path if Add_Default_Dir then - declare - Prefix : String_Ptr; - - begin - if Sdefault.Search_Dir_Prefix = null then - - -- gprbuild case + if Sdefault.Search_Dir_Prefix = null then - Prefix := new String'(Executable_Prefix_Path); - - else - Prefix := new String'(Sdefault.Search_Dir_Prefix.all - & ".." & Dir_Separator - & ".." & Dir_Separator - & ".." & Dir_Separator - & ".." & Dir_Separator); - end if; + -- gprbuild case - if Prefix.all /= "" then - if Target_Name /= "" then + Prefix := new String'(Executable_Prefix_Path); - -- $prefix/$target/lib/gnat - - Add_Str_To_Name_Buffer - (Path_Separator & Prefix.all & Target_Name); - - -- Note: Target_Name has a trailing / when it comes from - -- Sdefault. - - if Name_Buffer (Name_Len) /= '/' then - Add_Char_To_Name_Buffer (Directory_Separator); - end if; + else + Prefix := new String'(Sdefault.Search_Dir_Prefix.all + & ".." & Dir_Separator + & ".." & Dir_Separator + & ".." & Dir_Separator + & ".." & Dir_Separator); + end if; - Add_Str_To_Name_Buffer - ("lib" & Directory_Separator & "gnat"); + if Prefix.all /= "" then + if Target_Name /= "" then - -- $prefix/$target/share/gpr + if Runtime_Name /= "" then + if Base_Name (Runtime_Name) = Runtime_Name then - Add_Str_To_Name_Buffer - (Path_Separator & Prefix.all & Target_Name); + -- $prefix/$target/$runtime/lib/gnat + Add_Target; + Add_Str_To_Name_Buffer + (Runtime_Name & Directory_Separator & + "lib" & Directory_Separator & "gnat"); - -- Note: Target_Name has a trailing / when it comes from - -- Sdefault. + -- $prefix/$target/$runtime/share/gpr + Add_Target; + Add_Str_To_Name_Buffer + (Runtime_Name & Directory_Separator & + "share" & Directory_Separator & "gpr"); - if Name_Buffer (Name_Len) /= '/' then - Add_Char_To_Name_Buffer (Directory_Separator); + else + Runtime := + new String'(Normalize_Pathname (Runtime_Name)); + + -- $runtime_dir/lib/gnat + Add_Str_To_Name_Buffer + (Path_Separator & Runtime.all & Directory_Separator & + "lib" & Directory_Separator & "gnat"); + + -- $runtime_dir/share/gpr + Add_Str_To_Name_Buffer + (Path_Separator & Runtime.all & Directory_Separator & + "share" & Directory_Separator & "gpr"); end if; - - Add_Str_To_Name_Buffer - ("share" & Directory_Separator & "gpr"); end if; - -- $prefix/share/gpr + -- $prefix/$target/lib/gnat + Add_Target; Add_Str_To_Name_Buffer - (Path_Separator & Prefix.all & "share" - & Directory_Separator & "gpr"); + ("lib" & Directory_Separator & "gnat"); - -- $prefix/lib/gnat + -- $prefix/$target/share/gpr + Add_Target; Add_Str_To_Name_Buffer - (Path_Separator & Prefix.all & "lib" - & Directory_Separator & "gnat"); + ("share" & Directory_Separator & "gpr"); end if; - Free (Prefix); - end; + -- $prefix/share/gpr + + Add_Str_To_Name_Buffer + (Path_Separator & Prefix.all & "share" + & Directory_Separator & "gpr"); + + -- $prefix/lib/gnat + + Add_Str_To_Name_Buffer + (Path_Separator & Prefix.all & "lib" + & Directory_Separator & "gnat"); + end if; + + Free (Prefix); end if; Self.Path := new String'(Name_Buffer (1 .. Name_Len)); diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index f070a75fce3..a7617afab90 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -171,14 +171,16 @@ package Prj.Env is No_Project_Search_Path : constant Project_Search_Path; procedure Initialize_Default_Project_Path - (Self : in out Project_Search_Path; - Target_Name : String); - -- Initialize Self. It will then contain the default project path on the - -- given target (including directories specified by the environment - -- variables GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH and ADA_PROJECT_PATH). - -- If one of the directory or Target_Name is "-", then the path contains - -- only those directories specified by the environment variables (except - -- "-"). This does nothing if Self has already been initialized. + (Self : in out Project_Search_Path; + Target_Name : String; + Runtime_Name : String := ""); + -- Initialize Self. It will then contain the default project path on + -- the given target and runtime (including directories specified by the + -- environment variables GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH and + -- ADA_PROJECT_PATH). If one of the directory or Target_Name is "-", then + -- the path contains only those directories specified by the environment + -- variables (except "-"). This does nothing if Self has already been + -- initialized. procedure Copy (From : Project_Search_Path; To : out Project_Search_Path); -- Copy From into To diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index b12af37ea7e..f48d98d0634 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -670,7 +670,7 @@ package System.Tasking is -- System-specific attributes of the task as specified by the -- Task_Info pragma. - Analyzer : System.Stack_Usage.Stack_Analyzer; + Analyzer : System.Stack_Usage.Stack_Analyzer; -- For storing information used to measure the stack usage Global_Task_Lock_Nesting : Natural; diff --git a/gcc/ada/s-traces.ads b/gcc/ada/s-traces.ads index 74819823f6e..89c7cc42dd3 100644 --- a/gcc/ada/s-traces.ads +++ b/gcc/ada/s-traces.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -33,8 +33,7 @@ -- Warning : NO dependencies to tasking should be created here --- This package, and all its children are used to implement debug --- information +-- This package and all its children are used to implement debug information -- A new primitive, Send_Trace_Info (Id : Trace_T; 'data') is introduced. -- Trace_T is an event identifier, 'data' are the information to pass @@ -50,7 +49,7 @@ -- corresponding Send_Trace_Info procedure. It may be required for some -- target to modify Send_Trace (e.g. VxWorks). --- To add a new target, just adapt System.Traces.Send to your own purposes +-- To add a new target, just adapt System.Traces.Send as needed package System.Traces is pragma Preelaborate; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 75f430c5762..58acefdd7a7 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -11017,10 +11017,10 @@ package body Sem_Prag is -- processing is required here. when Pragma_Assertion_Policy => Assertion_Policy : declare - LocP : Source_Ptr; - Policy : Node_Id; Arg : Node_Id; Kind : Name_Id; + LocP : Source_Ptr; + Policy : Node_Id; begin Ada_2005_Pragma; @@ -11102,12 +11102,17 @@ package body Sem_Prag is Check_Arg_Is_One_Of (Arg, Name_Check, Name_Disable, Name_Ignore); - -- We rewrite the Assertion_Policy pragma as a series of - -- Check_Policy pragmas: + -- Rewrite the Assertion_Policy pragma as a series of + -- Check_Policy pragmas of the form: -- Check_Policy (Kind, Policy); - Insert_Action (N, + -- Note: the insertion of the pragmas cannot be done with + -- Insert_Action because in the configuration case, there + -- are no scopes on the scope stack and the mechanism will + -- fail. + + Insert_Before_And_Analyze (N, Make_Pragma (LocP, Chars => Name_Check_Policy, Pragma_Argument_Associations => New_List ( diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 8b0f6585f88..df88d43d069 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4630,31 +4630,19 @@ package body Sem_Res is -- first place. if Ekind (Nam) = E_Procedure + and then Ekind (F) = E_In_Parameter and then Is_Entity_Name (A) and then Present (Entity (A)) and then Ekind (Entity (A)) = E_Variable then A_Id := Entity (A); - if Ekind (F) = E_In_Parameter then - if Async_Readers_Enabled (A_Id) then - Property_Error (A, A_Id, Name_Async_Readers); - elsif Effective_Reads_Enabled (A_Id) then - Property_Error (A, A_Id, Name_Effective_Reads); - elsif Effective_Writes_Enabled (A_Id) then - Property_Error (A, A_Id, Name_Effective_Writes); - end if; - - elsif Ekind (F) = E_Out_Parameter - and then Async_Writers_Enabled (A_Id) - then - Error_Msg_Name_1 := Name_Async_Writers; - Error_Msg_NE - ("external variable & with enabled property % cannot " - & "appear as actual in procedure call " - & "(SPARK RM 7.1.3(11))", A, A_Id); - Error_Msg_N - ("\\corresponding formal parameter has mode Out", A); + if Async_Readers_Enabled (A_Id) then + Property_Error (A, A_Id, Name_Async_Readers); + elsif Effective_Reads_Enabled (A_Id) then + Property_Error (A, A_Id, Name_Effective_Reads); + elsif Effective_Writes_Enabled (A_Id) then + Property_Error (A, A_Id, Name_Effective_Writes); end if; end if; end if; -- 2.30.2