This patch provides proper detection of the error of passing pointer to volatile to pointer to non-volatile in the case of a component reference A.B.
The following test program (compiled with -gnatld7 -gnatj60 -gnat2005) shows detection of this error 1. procedure Atomic_Test is 2. 3. type X32 is mod 2 ** 32; 4. 5. type X32_Array is array (1 .. 1) of aliased X32; 6. pragma Atomic_Components (X32_Array); 7. 8. type Rec is record 9. A : X32_Array; 10. B : aliased X32; 11. pragma Atomic (B); 12. end record; 13. 14. procedure Test (X : access X32) is null; 15. 16. C : aliased X32; 17. pragma Atomic (C); 18. 19. Object : Rec; 20. begin 21. Test (Object.A (1)'Access); | >>> access to volatile object cannot yield access-to-non-volatile type 22. Test (Object.B'Access); | >>> access to volatile object cannot yield access-to-non-volatile type 23. Test (C'Access); | >>> access to volatile object cannot yield access-to-non-volatile type 24. end Atomic_Test; Before the patch not all these errors were caught. This change necessitated fixes to two runtime files, namely s-atocou-builtin.adb and s-taprop-linux.adb, which had this error. These were both fixed by using Unrestricted_Access instead of Access. Tested on x86_64-pc-linux-gnu, committed on trunk 2011-11-21 Robert Dewar <de...@adacore.com> * s-atocou-builtin.adb (Decrement): Use Unrestricted_Access to deal with fact that we properly detect the error if Access is used. (Increment): Same fix. * s-taprop-linux.adb (Create_Task): Use Unrestricted_Access to deal with fact that we properly detect the error if Access is used. * sem_util.adb (Is_Volatile_Object): Properly record that A.B is volatile if the B component is volatile. This affects the check for passing such a by reference volatile actual to a non-volatile formal (which should be illegal)
Index: sem_util.adb =================================================================== --- sem_util.adb (revision 181563) +++ sem_util.adb (working copy) @@ -8727,11 +8727,16 @@ then return True; - elsif Nkind (N) = N_Indexed_Component - or else Nkind (N) = N_Selected_Component + elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) + and then Is_Volatile_Prefix (Prefix (N)) then - return Is_Volatile_Prefix (Prefix (N)); + return True; + elsif Nkind (N) = N_Selected_Component + and then Is_Volatile (Entity (Selector_Name (N))) + then + return True; + else return False; end if; @@ -10833,9 +10838,7 @@ -- source. This excludes, for example, calls to a dispatching -- assignment operation when the left-hand side is tagged. - if Modification_Comes_From_Source - or else Alfa_Mode - then + if Modification_Comes_From_Source or else Alfa_Mode then Generate_Reference (Ent, Exp, 'm'); -- If the target of the assignment is the bound variable Index: s-taprop-linux.adb =================================================================== --- s-taprop-linux.adb (revision 181565) +++ s-taprop-linux.adb (working copy) @@ -990,12 +990,19 @@ -- do not need to manipulate caller's signal mask at this point. -- All tasks in RTS will have All_Tasks_Mask initially. - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); + -- Note: the use of Unrestricted_Access in the following call is needed + -- because otherwise we have an error of getting a access-to-volatile + -- value which points to a non-volatile object. But in this case it is + -- safe to do this, since we know we have no problems with aliasing and + -- Unrestricted_Access bypasses this check. + Result := + pthread_create + (T.Common.LL.Thread'Unrestricted_Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN or else Result = ENOMEM); Index: s-atocou-builtin.adb =================================================================== --- s-atocou-builtin.adb (revision 181556) +++ s-atocou-builtin.adb (working copy) @@ -50,7 +50,12 @@ function Decrement (Item : in out Atomic_Counter) return Boolean is begin - return Sync_Sub_And_Fetch (Item.Value'Access, 1) = 0; + -- Note: the use of Unrestricted_Access here is required because we + -- are obtaining an access-to-volatile pointer to a non-volatile object. + -- This is not allowed for [Unchecked_]Access, but is safe in this case + -- because we know that no aliases are being created. + + return Sync_Sub_And_Fetch (Item.Value'Unrestricted_Access, 1) = 0; end Decrement; --------------- @@ -59,7 +64,12 @@ procedure Increment (Item : in out Atomic_Counter) is begin - Sync_Add_And_Fetch (Item.Value'Access, 1); + -- Note: the use of Unrestricted_Access here is required because we + -- are obtaining an access-to-volatile pointer to a non-volatile object. + -- This is not allowed for [Unchecked_]Access, but is safe in this case + -- because we know that no aliases are being created. + + Sync_Add_And_Fetch (Item.Value'Unrestricted_Access, 1); end Increment; ------------