From 949a18ccb2de8ef2b73b7fc918d31d40e8b50826 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 29 Aug 2011 12:40:08 +0200 Subject: [PATCH] [multiple changes] 2011-08-29 Hristian Kirtchev * sem_res.adb (Resolve_Allocator): Implement Ada2012-B052. Detect cases where an anonymous access discriminant of a limited designated type appears in a non-immutably limited discriminated type and issue an error message. Add local variable Desig_T and replace all occurrences of Designated_Type. 2011-08-29 Jose Ruiz * a-rttiev.adb (Set_Handler): Update comment to indicate that our implementation is compliant to RM D.15(15/2) after the modification imposed by AI05-0094-1 (binding interpretation). From-SVN: r178196 --- gcc/ada/ChangeLog | 14 ++++++++++++++ gcc/ada/a-rttiev.adb | 11 +++++++---- gcc/ada/sem_res.adb | 31 ++++++++++++++++++++++++++----- 3 files changed, 47 insertions(+), 9 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2606c50891c..d9c3a9f5fef 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2011-08-29 Hristian Kirtchev + + * sem_res.adb (Resolve_Allocator): Implement Ada2012-B052. Detect cases + where an anonymous access discriminant of a limited designated type + appears in a non-immutably limited discriminated type and issue an + error message. Add local variable Desig_T and replace all occurrences + of Designated_Type. + +2011-08-29 Jose Ruiz + + * a-rttiev.adb (Set_Handler): Update comment to indicate that our + implementation is compliant to RM D.15(15/2) after the modification + imposed by AI05-0094-1 (binding interpretation). + 2011-08-29 Robert Dewar * exp_ch9.adb, s-tasren.adb, exp_sel.adb, exp_sel.ads, exp_ch11.adb, diff --git a/gcc/ada/a-rttiev.adb b/gcc/ada/a-rttiev.adb index 1c1fe859dd5..67b81c72ba8 100644 --- a/gcc/ada/a-rttiev.adb +++ b/gcc/ada/a-rttiev.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2005-2011, Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -281,12 +281,15 @@ package body Ada.Real_Time.Timing_Events is Remove_From_Queue (Event'Unchecked_Access); Event.Handler := null; - -- RM D.15(15/2) requires that at this point, we check whether the time + -- RM D.15(15/2) required that at this point, we check whether the time -- has already passed, and if so, call Handler.all directly from here - -- instead of doing the enqueuing below. However, this causes a nasty + -- instead of doing the enqueuing below. However, this caused a nasty -- race condition and potential deadlock. If the current task has -- already locked the protected object of Handler.all, and the time has - -- passed, deadlock would occur. Therefore, we ignore the requirement. + -- passed, deadlock would occur. It has been fixed by AI05-0094-1, which + -- says that the handler should be executed as soon as possible, meaning + -- that the timing event will be executed after the protected action + -- finishes (Handler.all should not be called directly from here). -- The same comment applies to the other Set_Handler below. if Handler /= null then diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 51e4f4319c2..b0ea74ca538 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4058,6 +4058,7 @@ package body Sem_Res is ----------------------- procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is + Desig_T : constant Entity_Id := Designated_Type (Typ); E : constant Node_Id := Expression (N); Subtyp : Entity_Id; Discrim : Entity_Id; @@ -4160,7 +4161,7 @@ package body Sem_Res is if Nkind (E) = N_Qualified_Expression then if Is_Class_Wide_Type (Etype (E)) - and then not Is_Class_Wide_Type (Designated_Type (Typ)) + and then not Is_Class_Wide_Type (Desig_T) and then not In_Dispatching_Context then Error_Msg_N @@ -4304,7 +4305,7 @@ package body Sem_Res is -- Expand_Allocator_Expression). if Ada_Version >= Ada_2005 - and then Is_Class_Wide_Type (Designated_Type (Typ)) + and then Is_Class_Wide_Type (Desig_T) then declare Exp_Typ : Entity_Id; @@ -4366,7 +4367,7 @@ package body Sem_Res is -- type when restriction No_Task_Hierarchy applies. if not Is_Library_Level_Entity (Base_Type (Typ)) - and then Has_Task (Base_Type (Designated_Type (Typ))) + and then Has_Task (Base_Type (Desig_T)) then Check_Restriction (No_Task_Hierarchy, N); end if; @@ -4383,6 +4384,26 @@ package body Sem_Res is and then Nkind (Associated_Node_For_Itype (Typ)) = N_Discriminant_Specification then + declare + Discr : constant Entity_Id := + Defining_Identifier (Associated_Node_For_Itype (Typ)); + begin + -- Ada2012-B052: If the designated type of the allocator is + -- limited, then the allocator shall not be used to define the + -- value of an access discriminant, unless the discriminated + -- type is immutably limited. + + if Ada_Version >= Ada_2012 + and then Is_Limited_Type (Desig_T) + and then not Is_Immutably_Limited_Type (Scope (Discr)) + then + Error_Msg_N + ("only immutably limited types can have anonymous ", N); + Error_Msg_N + ("\discriminants of limited designated type", N); + end if; + end; + -- Avoid marking an allocator as a dynamic coextension if it is -- within a static construct. @@ -4402,8 +4423,8 @@ package body Sem_Res is -- its body has not been seen yet, and its activation will fail -- an elaboration check. - if Is_Task_Type (Designated_Type (Typ)) - and then Scope (Base_Type (Designated_Type (Typ))) = Current_Scope + if Is_Task_Type (Desig_T) + and then Scope (Base_Type (Desig_T)) = Current_Scope and then Is_Compilation_Unit (Current_Scope) and then Ekind (Current_Scope) = E_Package and then not In_Package_Body (Current_Scope) -- 2.34.1