+2015-01-06 Robert Dewar <dewar@adacore.com>
+
+ * s-taskin.ads, s-traces.ads: Minor reformatting.
+ * exp_util.adb: Minor typo fix.
+
+2015-01-06 Vincent Celier <celier@adacore.com>
+
+ * 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 <kirtchev@adacore.com>
+
+ * 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 <duff@adacore.com>
+
+ * 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 <kirtchev@adacore.com>
+
+ * 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 <jakub@redhat.com>
* gnat_ugn.texi: Bump @copying's copyright year.
-- 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;
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;
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
is
procedure Sort is
new Generic_Array_Sort
- (Index_Type => Capacity_Range,
+ (Index_Type => Array_Index,
Element_Type => Element_Type,
Array_Type => Elements_Array,
"<" => "<");
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;
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;
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;
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;
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;
-- 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);
-------------------------------------
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;
-- 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;
-- 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));
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
-- 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;
-- --
-- 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- --
-- 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
-- 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;
-- 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;
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 (
-- 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;
projects / gcc.git / commitdiff