Commit c2a2dbcc by Robert Dewar Committed by Arnaud Charlet

aspects.ads, [...]: Add entries for aspect Obsolescent.

2014-08-04  Robert Dewar  <dewar@adacore.com>

	* aspects.ads, aspects.adb: Add entries for aspect Obsolescent.
	* gnat_rm.texi: Add documentation for aspect Obsolescent.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Implement aspect
	Obsolescent.
	(Check_Aspect_At_Freeze_Point): Add dummy entry for pragma Obsolescent.
	* s-osprim-mingw.adb: Minor reformatting.
	* sem_res.adb (Is_Atomic_Ref_With_Address): New function
	(Resolve_Indexed_Component): Rework warnings for non-atomic access
	(Resolve_Selected_Component): Add warnings for non-atomic access.

From-SVN: r213588
parent 6cf7eae6
2014-08-04 Robert Dewar <dewar@adacore.com>
* aspects.ads, aspects.adb: Add entries for aspect Obsolescent.
* gnat_rm.texi: Add documentation for aspect Obsolescent.
* sem_ch13.adb (Analyze_Aspect_Specifications): Implement aspect
Obsolescent.
(Check_Aspect_At_Freeze_Point): Add dummy entry for pragma Obsolescent.
* s-osprim-mingw.adb: Minor reformatting.
* sem_res.adb (Is_Atomic_Ref_With_Address): New function
(Resolve_Indexed_Component): Rework warnings for non-atomic access
(Resolve_Selected_Component): Add warnings for non-atomic access.
2014-08-04 Doug Rupp <rupp@adacore.com> 2014-08-04 Doug Rupp <rupp@adacore.com>
* g-calend.adb (timeval_to_duration, duration_to_timeval): Change sec * g-calend.adb (timeval_to_duration, duration_to_timeval): Change sec
......
...@@ -546,6 +546,7 @@ package body Aspects is ...@@ -546,6 +546,7 @@ package body Aspects is
Aspect_Machine_Radix => Aspect_Machine_Radix, Aspect_Machine_Radix => Aspect_Machine_Radix,
Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All, Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All,
Aspect_No_Return => Aspect_No_Return, Aspect_No_Return => Aspect_No_Return,
Aspect_Obsolescent => Aspect_Obsolescent,
Aspect_Object_Size => Aspect_Object_Size, Aspect_Object_Size => Aspect_Object_Size,
Aspect_Output => Aspect_Output, Aspect_Output => Aspect_Output,
Aspect_Pack => Aspect_Pack, Aspect_Pack => Aspect_Pack,
......
...@@ -109,6 +109,7 @@ package Aspects is ...@@ -109,6 +109,7 @@ package Aspects is
Aspect_Linker_Section, -- GNAT Aspect_Linker_Section, -- GNAT
Aspect_Machine_Radix, Aspect_Machine_Radix,
Aspect_Object_Size, -- GNAT Aspect_Object_Size, -- GNAT
Aspect_Obsolescent, -- GNAT
Aspect_Output, Aspect_Output,
Aspect_Part_Of, -- GNAT Aspect_Part_Of, -- GNAT
Aspect_Post, Aspect_Post,
...@@ -333,6 +334,7 @@ package Aspects is ...@@ -333,6 +334,7 @@ package Aspects is
Aspect_Linker_Section => Expression, Aspect_Linker_Section => Expression,
Aspect_Machine_Radix => Expression, Aspect_Machine_Radix => Expression,
Aspect_Object_Size => Expression, Aspect_Object_Size => Expression,
Aspect_Obsolescent => Optional_Expression,
Aspect_Output => Name, Aspect_Output => Name,
Aspect_Part_Of => Expression, Aspect_Part_Of => Expression,
Aspect_Post => Expression, Aspect_Post => Expression,
...@@ -433,6 +435,7 @@ package Aspects is ...@@ -433,6 +435,7 @@ package Aspects is
Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All, Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All,
Aspect_No_Return => Name_No_Return, Aspect_No_Return => Name_No_Return,
Aspect_Object_Size => Name_Object_Size, Aspect_Object_Size => Name_Object_Size,
Aspect_Obsolescent => Name_Obsolescent,
Aspect_Output => Name_Output, Aspect_Output => Name_Output,
Aspect_Pack => Name_Pack, Aspect_Pack => Name_Pack,
Aspect_Part_Of => Name_Part_Of, Aspect_Part_Of => Name_Part_Of,
...@@ -688,6 +691,7 @@ package Aspects is ...@@ -688,6 +691,7 @@ package Aspects is
Aspect_Initial_Condition => Never_Delay, Aspect_Initial_Condition => Never_Delay,
Aspect_Initializes => Never_Delay, Aspect_Initializes => Never_Delay,
Aspect_No_Elaboration_Code_All => Never_Delay, Aspect_No_Elaboration_Code_All => Never_Delay,
Aspect_Obsolescent => Never_Delay,
Aspect_Part_Of => Never_Delay, Aspect_Part_Of => Never_Delay,
Aspect_Refined_Depends => Never_Delay, Aspect_Refined_Depends => Never_Delay,
Aspect_Refined_Global => Never_Delay, Aspect_Refined_Global => Never_Delay,
......
...@@ -313,6 +313,7 @@ Implementation Defined Aspects ...@@ -313,6 +313,7 @@ Implementation Defined Aspects
* Aspect Linker_Section:: * Aspect Linker_Section::
* Aspect No_Elaboration_Code_All:: * Aspect No_Elaboration_Code_All::
* Aspect Object_Size:: * Aspect Object_Size::
* Aspect Obsolescent::
* Aspect Part_Of:: * Aspect Part_Of::
* Aspect Persistent_BSS:: * Aspect Persistent_BSS::
* Aspect Predicate:: * Aspect Predicate::
...@@ -8068,6 +8069,7 @@ clause. ...@@ -8068,6 +8069,7 @@ clause.
* Aspect Lock_Free:: * Aspect Lock_Free::
* Aspect No_Elaboration_Code_All:: * Aspect No_Elaboration_Code_All::
* Aspect Object_Size:: * Aspect Object_Size::
* Aspect Obsolescent::
* Aspect Part_Of:: * Aspect Part_Of::
* Aspect Persistent_BSS:: * Aspect Persistent_BSS::
* Aspect Predicate:: * Aspect Predicate::
...@@ -8350,6 +8352,14 @@ statement for a program unit. ...@@ -8350,6 +8352,14 @@ statement for a program unit.
This aspect is equivalent to an @code{Object_Size} attribute definition This aspect is equivalent to an @code{Object_Size} attribute definition
clause. clause.
@node Aspect Obsolescent
@unnumberedsec Aspect Obsolescent
@findex Obsolsecent
@noindent
This aspect is equivalent to an @code{Obsolescent} pragma. Note that the
evaluation of this aspect happens at the point of occurrence, it is not
delayed until the freeze point.
@node Aspect Part_Of @node Aspect Part_Of
@unnumberedsec Aspect Part_Of @unnumberedsec Aspect Part_Of
@findex Part_Of @findex Part_Of
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1998-2013, Free Software Foundation, Inc. -- -- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -87,15 +87,15 @@ package body System.OS_Primitives is ...@@ -87,15 +87,15 @@ package body System.OS_Primitives is
-- the base data for the changes to get undetected. -- the base data for the changes to get undetected.
type Signature_Type is mod 2**32; type Signature_Type is mod 2**32;
Signature : Signature_Type := 0; Signature : Signature_Type := 0;
pragma Atomic (Signature); pragma Atomic (Signature);
procedure Get_Base_Time (Data : out Clock_Data); procedure Get_Base_Time (Data : out Clock_Data);
-- Retrieve the base time and base ticks. These values will be used by -- Retrieve the base time and base ticks. These values will be used by
-- clock to compute the current time by adding to it a fraction of the -- clock to compute the current time by adding to it a fraction of the
-- performance counter. This is for the implementation of a -- performance counter. This is for the implementation of a high-resolution
-- high-resolution clock. Note that this routine does not change the base -- clock. Note that this routine does not change the base monotonic values
-- monotonic values used by the monotonic clock. -- used by the monotonic clock.
----------- -----------
-- Clock -- -- Clock --
......
...@@ -2388,6 +2388,25 @@ package body Sem_Ch13 is ...@@ -2388,6 +2388,25 @@ package body Sem_Ch13 is
goto Continue; goto Continue;
end Initializes; end Initializes;
-- Obsolescent
when Aspect_Obsolescent => declare
Args : List_Id;
begin
if No (Expr) then
Args := No_List;
else
Args := New_List (
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Relocate_Node (Expr)));
end if;
Make_Aitem_Pragma
(Pragma_Argument_Associations => Args,
Pragma_Name => Chars (Id));
end;
-- Part_Of -- Part_Of
when Aspect_Part_Of => when Aspect_Part_Of =>
...@@ -8758,6 +8777,7 @@ package body Sem_Ch13 is ...@@ -8758,6 +8777,7 @@ package body Sem_Ch13 is
Aspect_Implicit_Dereference | Aspect_Implicit_Dereference |
Aspect_Initial_Condition | Aspect_Initial_Condition |
Aspect_Initializes | Aspect_Initializes |
Aspect_Obsolescent |
Aspect_Part_Of | Aspect_Part_Of |
Aspect_Post | Aspect_Post |
Aspect_Postcondition | Aspect_Postcondition |
......
...@@ -128,6 +128,11 @@ package body Sem_Res is ...@@ -128,6 +128,11 @@ package body Sem_Res is
-- for restriction No_Direct_Boolean_Operators. This procedure also handles -- for restriction No_Direct_Boolean_Operators. This procedure also handles
-- the style check for Style_Check_Boolean_And_Or. -- the style check for Style_Check_Boolean_And_Or.
function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean;
-- N is either an indexed component or a selected component. This function
-- returns true if the prefix refers to an object that has an address
-- clause (the case in which we may want to issue a warning).
function Is_Definite_Access_Type (E : Entity_Id) return Boolean; function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
-- Determine whether E is an access type declared by an access declaration, -- Determine whether E is an access type declared by an access declaration,
-- and not an (anonymous) allocator type. -- and not an (anonymous) allocator type.
...@@ -1131,6 +1136,29 @@ package body Sem_Res is ...@@ -1131,6 +1136,29 @@ package body Sem_Res is
end if; end if;
end Check_Parameterless_Call; end Check_Parameterless_Call;
--------------------------------
-- Is_Atomic_Ref_With_Address --
--------------------------------
function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean is
Pref : constant Node_Id := Prefix (N);
begin
if not Is_Entity_Name (Pref) then
return False;
else
declare
Pent : constant Entity_Id := Entity (Pref);
Ptyp : constant Entity_Id := Etype (Pent);
begin
return not Is_Access_Type (Ptyp)
and then (Is_Atomic (Ptyp) or else Is_Atomic (Pent))
and then Present (Address_Clause (Pent));
end;
end if;
end Is_Atomic_Ref_With_Address;
----------------------------- -----------------------------
-- Is_Definite_Access_Type -- -- Is_Definite_Access_Type --
----------------------------- -----------------------------
...@@ -7973,19 +8001,20 @@ package body Sem_Res is ...@@ -7973,19 +8001,20 @@ package body Sem_Res is
Eval_Indexed_Component (N); Eval_Indexed_Component (N);
end if; end if;
-- If the array type is atomic, and is packed, and we are in a left side -- If the array type is atomic, and the component is not atomic, then
-- context, then this is worth a warning, since we have a situation -- this is worth a warning, since we have a situation where the access
-- where the access to the component may cause extra read/writes of -- to the component may cause extra read/writes of the atomic array
-- the atomic array object, which could be considered unexpected. -- object, or partial word accesses, which could be unexpected.
if Nkind (N) = N_Indexed_Component if Nkind (N) = N_Indexed_Component
and then (Is_Atomic (Array_Type) and then Is_Atomic_Ref_With_Address (N)
or else (Is_Entity_Name (Prefix (N)) and then not (Has_Atomic_Components (Array_Type)
and then Is_Atomic (Entity (Prefix (N))))) or else (Is_Entity_Name (Prefix (N))
and then Is_Bit_Packed_Array (Array_Type) and then Has_Atomic_Components
and then Is_LHS (N) = Yes (Entity (Prefix (N)))))
and then not Is_Atomic (Component_Type (Array_Type))
then then
Error_Msg_N ("??assignment to component of packed atomic array", Error_Msg_N ("??access to non-atomic component of atomic array",
Prefix (N)); Prefix (N));
Error_Msg_N ("??\may cause unexpected accesses to atomic object", Error_Msg_N ("??\may cause unexpected accesses to atomic object",
Prefix (N)); Prefix (N));
...@@ -9293,7 +9322,7 @@ package body Sem_Res is ...@@ -9293,7 +9322,7 @@ package body Sem_Res is
procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is
Comp : Entity_Id; Comp : Entity_Id;
Comp1 : Entity_Id := Empty; -- prevent junk warning Comp1 : Entity_Id := Empty; -- prevent junk warning
P : constant Node_Id := Prefix (N); P : constant Node_Id := Prefix (N);
S : constant Node_Id := Selector_Name (N); S : constant Node_Id := Selector_Name (N);
T : Entity_Id := Etype (P); T : Entity_Id := Etype (P);
I : Interp_Index; I : Interp_Index;
...@@ -9470,22 +9499,22 @@ package body Sem_Res is ...@@ -9470,22 +9499,22 @@ package body Sem_Res is
-- Note: No Eval processing is required, because the prefix is of a -- Note: No Eval processing is required, because the prefix is of a
-- record type, or protected type, and neither can possibly be static. -- record type, or protected type, and neither can possibly be static.
-- If the array type is atomic, and is packed, and we are in a left side -- If the record type is atomic, and the component is non-atomic, then
-- context, then this is worth a warning, since we have a situation -- this is worth a warning, since we have a situation where the access
-- where the access to the component may cause extra read/writes of the -- to the component may cause extra read/writes of the atomic array
-- atomic array object, which could be considered unexpected. -- object, or partial word accesses, both of which may be unexpected.
if Nkind (N) = N_Selected_Component if Nkind (N) = N_Selected_Component
and then (Is_Atomic (T) and then Is_Atomic_Ref_With_Address (N)
or else (Is_Entity_Name (Prefix (N)) and then not Is_Atomic (Entity (S))
and then Is_Atomic (Entity (Prefix (N))))) and then not Is_Atomic (Etype (Entity (S)))
and then Is_Packed (T)
and then Is_LHS (N) = Yes
then then
Error_Msg_N Error_Msg_N
("??assignment to component of packed atomic record", Prefix (N)); ("??access to non-atomic component of atomic record",
Prefix (N));
Error_Msg_N Error_Msg_N
("\??may cause unexpected accesses to atomic object", Prefix (N)); ("\??may cause unexpected accesses to atomic object",
Prefix (N));
end if; end if;
Analyze_Dimension (N); Analyze_Dimension (N);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment