Commit df170605 by Arnaud Charlet

[multiple changes]

2011-08-29  Bob Duff  <duff@adacore.com>

	* sem_ch4.adb (Analyze_Allocator): Analyze the subpool specification.

2011-08-29  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch3.adb (Expand_N_Object_Declaration): If the entity is tagged
	and a separate tag assignment is generated, ensure that the tag
	assignment is analyzed.

From-SVN: r178170
parent 864a4236
2011-08-29 Bob Duff <duff@adacore.com>
* sem_ch4.adb (Analyze_Allocator): Analyze the subpool specification.
2011-08-29 Ed Schonberg <schonberg@adacore.com>
* exp_ch3.adb (Expand_N_Object_Declaration): If the entity is tagged
and a separate tag assignment is generated, ensure that the tag
assignment is analyzed.
2011-08-29 Ed Schonberg <schonberg@adacore.com> 2011-08-29 Ed Schonberg <schonberg@adacore.com>
* atree.ads, atree.adb (Copy_Separate_List): New function that applies * atree.ads, atree.adb (Copy_Separate_List): New function that applies
Copy_Separate_Tree to a list of nodes. Used to create disjoint copies Copy_Separate_Tree to a list of nodes. Used to create disjoint copies
of statement lists that may contain local declarations. of statement lists that may contain local declarations.
(Expand_N_Timed_Entry_Call): Use Copy_Separate_List to duplicate the * exp_ch9.adb (Expand_N_Timed_Entry_Call): Use Copy_Separate_List to
triggering statements needed for the expansion of this construct, when duplicate the triggering statements needed for the expansion of this
the trigger is a dispatching call to a synchronized primitive. construct, when the trigger is a dispatching call to a synchronized
primitive.
2011-08-29 Arnaud Charlet <charlet@adacore.com> 2011-08-29 Arnaud Charlet <charlet@adacore.com>
......
...@@ -5108,25 +5108,24 @@ package body Exp_Ch3 is ...@@ -5108,25 +5108,24 @@ package body Exp_Ch3 is
begin begin
-- The re-assignment of the tag has to be done even if the -- The re-assignment of the tag has to be done even if the
-- object is a constant. -- object is a constant. The assignment must be analyzed
-- after the declaration.
New_Ref := New_Ref :=
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => New_Reference_To (Def_Id, Loc), Prefix => New_Occurrence_Of (Def_Id, Loc),
Selector_Name => Selector_Name =>
New_Reference_To (First_Tag_Component (Full_Typ), New_Reference_To (First_Tag_Component (Full_Typ),
Loc)); Loc));
Set_Assignment_OK (New_Ref); Set_Assignment_OK (New_Ref);
Insert_After (Init_After, Insert_Action_After (Init_After,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => New_Ref, Name => New_Ref,
Expression => Expression =>
Unchecked_Convert_To (RTE (RE_Tag), Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To New_Reference_To
(Node (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
(First_Elmt
(Access_Disp_Table (Full_Typ))),
Loc)))); Loc))));
end; end;
...@@ -5196,10 +5195,6 @@ package body Exp_Ch3 is ...@@ -5196,10 +5195,6 @@ package body Exp_Ch3 is
if (Is_Possibly_Unaligned_Slice (Expr) if (Is_Possibly_Unaligned_Slice (Expr)
or else (Is_Possibly_Unaligned_Object (Expr) or else (Is_Possibly_Unaligned_Object (Expr)
and then not Represented_As_Scalar (Etype (Expr)))) and then not Represented_As_Scalar (Etype (Expr))))
-- The exclusion of the unconstrained case is wrong, but for now
-- it is too much trouble ???
and then not (Is_Array_Type (Etype (Expr)) and then not (Is_Array_Type (Etype (Expr))
and then not Is_Constrained (Etype (Expr))) and then not Is_Constrained (Etype (Expr)))
then then
...@@ -5302,7 +5297,7 @@ package body Exp_Ch3 is ...@@ -5302,7 +5297,7 @@ package body Exp_Ch3 is
-- If the last variant does not contain the Others choice, replace it with -- If the last variant does not contain the Others choice, replace it with
-- an N_Others_Choice node since Gigi always wants an Others. Note that we -- an N_Others_Choice node since Gigi always wants an Others. Note that we
-- do not bother to call Analyze on the modified variant part, since it's -- do not bother to call Analyze on the modified variant part, since its
-- only effect would be to compute the Others_Discrete_Choices node -- only effect would be to compute the Others_Discrete_Choices node
-- laboriously, and of course we already know the list of choices that -- laboriously, and of course we already know the list of choices that
-- corresponds to the others choice (it's the list we are replacing!) -- corresponds to the others choice (it's the list we are replacing!)
...@@ -6838,7 +6833,7 @@ package body Exp_Ch3 is ...@@ -6838,7 +6833,7 @@ package body Exp_Ch3 is
(Get_Rep_Item_For_Entity (Get_Rep_Item_For_Entity
(First_Subtype (T), Name_Default_Value))); (First_Subtype (T), Name_Default_Value)));
-- Othersie, for scalars, we must have normalize/initialize scalars -- Otherwise, for scalars, we must have normalize/initialize scalars
-- case, or if the node N is an 'Invalid_Value attribute node. -- case, or if the node N is an 'Invalid_Value attribute node.
elsif Is_Scalar_Type (T) then elsif Is_Scalar_Type (T) then
...@@ -6854,8 +6849,8 @@ package body Exp_Ch3 is ...@@ -6854,8 +6849,8 @@ package body Exp_Ch3 is
Size_To_Use := Size; Size_To_Use := Size;
end if; end if;
-- Maximum size to use is 64 bits, since we will create values -- Maximum size to use is 64 bits, since we will create values of
-- of type Unsigned_64 and the range must fit this type. -- type Unsigned_64 and the range must fit this type.
if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then
Size_To_Use := Uint_64; Size_To_Use := Uint_64;
...@@ -6883,7 +6878,7 @@ package body Exp_Ch3 is ...@@ -6883,7 +6878,7 @@ package body Exp_Ch3 is
-- For signed integer types that have no negative values, either -- For signed integer types that have no negative values, either
-- there is room for negative values, or there is not. If there -- there is room for negative values, or there is not. If there
-- is, then all 1 bits may be interpreted as minus one, which is -- is, then all 1-bits may be interpreted as minus one, which is
-- certainly invalid. Alternatively it is treated as the largest -- certainly invalid. Alternatively it is treated as the largest
-- positive value, in which case the observation for modular types -- positive value, in which case the observation for modular types
-- still applies. -- still applies.
...@@ -6897,8 +6892,8 @@ package body Exp_Ch3 is ...@@ -6897,8 +6892,8 @@ package body Exp_Ch3 is
then then
Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1); Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1);
-- Resolve as Unsigned_64, because the largest number we -- Resolve as Unsigned_64, because the largest number we can
-- can generate is out of range of universal integer. -- generate is out of range of universal integer.
Analyze_And_Resolve (Val, RTE (RE_Unsigned_64)); Analyze_And_Resolve (Val, RTE (RE_Unsigned_64));
...@@ -6910,10 +6905,10 @@ package body Exp_Ch3 is ...@@ -6910,10 +6905,10 @@ package body Exp_Ch3 is
UI_Min (Uint_63, Size_To_Use - 1); UI_Min (Uint_63, Size_To_Use - 1);
begin begin
-- Normally we like to use the most negative number. The -- Normally we like to use the most negative number. The one
-- one exception is when this number is in the known -- exception is when this number is in the known subtype
-- subtype range and the largest positive number is not in -- range and the largest positive number is not in the known
-- the known subtype range. -- subtype range.
-- For this exceptional case, use largest positive value -- For this exceptional case, use largest positive value
...@@ -6923,7 +6918,7 @@ package body Exp_Ch3 is ...@@ -6923,7 +6918,7 @@ package body Exp_Ch3 is
then then
Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1); Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1);
-- Normal case of largest negative value -- Normal case of largest negative value
else else
Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size)); Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size));
...@@ -6992,14 +6987,14 @@ package body Exp_Ch3 is ...@@ -6992,14 +6987,14 @@ package body Exp_Ch3 is
-- The final expression is obtained by doing an unchecked conversion -- The final expression is obtained by doing an unchecked conversion
-- of this result to the base type of the required subtype. We use -- of this result to the base type of the required subtype. We use
-- the base type to avoid the unchecked conversion from chopping -- the base type to prevent the unchecked conversion from chopping
-- bits, and then we set Kill_Range_Check to preserve the "bad" -- bits, and then we set Kill_Range_Check to preserve the "bad"
-- value. -- value.
Result := Unchecked_Convert_To (Base_Type (T), Val); Result := Unchecked_Convert_To (Base_Type (T), Val);
-- Ensure result is not truncated, since we want the "bad" bits -- Ensure result is not truncated, since we want the "bad" bits, and
-- and also kill range check on result. -- also kill range check on result.
if Nkind (Result) = N_Unchecked_Type_Conversion then if Nkind (Result) = N_Unchecked_Type_Conversion then
Set_No_Truncation (Result); Set_No_Truncation (Result);
...@@ -7031,12 +7026,11 @@ package body Exp_Ch3 is ...@@ -7031,12 +7026,11 @@ package body Exp_Ch3 is
-- Access type is initialized to null -- Access type is initialized to null
elsif Is_Access_Type (T) then elsif Is_Access_Type (T) then
return return Make_Null (Loc);
Make_Null (Loc);
-- No other possibilities should arise, since we should only be -- No other possibilities should arise, since we should only be calling
-- calling Get_Simple_Init_Val if Needs_Simple_Initialization -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True,
-- returned True, indicating one of the above cases held. -- indicating one of the above cases held.
else else
raise Program_Error; raise Program_Error;
...@@ -7085,7 +7079,7 @@ package body Exp_Ch3 is ...@@ -7085,7 +7079,7 @@ package body Exp_Ch3 is
S1 := Scope (S1); S1 := Scope (S1);
end loop; end loop;
return Chars (S1) = Name_System or else Chars (S1) = Name_Ada; return Is_RTU (S1, RU_System) or else Is_RTU (S1, RU_Ada);
end In_Runtime; end In_Runtime;
---------------------------- ----------------------------
......
...@@ -443,7 +443,29 @@ package body Sem_Ch4 is ...@@ -443,7 +443,29 @@ package body Sem_Ch4 is
end loop; end loop;
end if; end if;
-- Analyze the allocator -- Ada 2012 (AI05-0111-3): Analyze the subpool_specification, if
-- any. The expected type for the name is any type. A non-overloading
-- rule then requires it to be of a type descended from
-- System.Storage_Pools.Subpools.Subpool_Handle. This isn't exactly what
-- the AI says, but I think it's the right rule. The AI should be fixed.
declare
Subpool : constant Node_Id := Subpool_Handle_Name (N);
begin
if Present (Subpool) then
Analyze (Subpool);
if Is_Overloaded (Subpool) then
Error_Msg_N ("ambiguous subpool handle", Subpool);
end if;
-- ???We need to check that Etype (Subpool) is descended from
-- Subpool_Handle
Resolve (Subpool);
end if;
end;
-- Analyze the qualified expression or subtype indication
if Nkind (E) = N_Qualified_Expression then if Nkind (E) = N_Qualified_Expression then
Acc_Type := Create_Itype (E_Allocator_Type, N); Acc_Type := Create_Itype (E_Allocator_Type, 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