+2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * 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 <ruiz@adacore.com>
+
+ * 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 <dewar@adacore.com>
* exp_ch9.adb, s-tasren.adb, exp_sel.adb, exp_sel.ads, exp_ch11.adb,
-- --
-- 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- --
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
-----------------------
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;
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
-- 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;
-- 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;
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.
-- 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)