Commit 841dd0f5 by Arnaud Charlet

[multiple changes]

2010-06-22  Gary Dismukes  <dismukes@adacore.com>

	* exp_util.adb (Find_Interface_ADT): Retrieve Designated_Type instead of
	Directly_Designated_Type when the type argument is an access type.
	(Find_Interface_Tag): Retrieve Designated_Type instead of
	Directly_Designated_Type when the type argument is an access type.
	(Has_Controlled_Coextensions): Retrieve Designated_Type instead of
	Directly_Designated_Type of each access discriminant.
	* sem_res.adb (Resolve_Type_Conversion): Retrieve Designated_Type
	instead of Directly_Designated_Type when the operand and target types
	are access types.

2010-06-22  Thomas Quinot  <quinot@adacore.com>

	* exp_aggr.adb (Flatten): Return False if one choice is statically
	known to be out of bounds.

From-SVN: r161137
parent 196379c6
2010-06-22 Gary Dismukes <dismukes@adacore.com>
* exp_util.adb (Find_Interface_ADT): Retrieve Designated_Type instead of
Directly_Designated_Type when the type argument is an access type.
(Find_Interface_Tag): Retrieve Designated_Type instead of
Directly_Designated_Type when the type argument is an access type.
(Has_Controlled_Coextensions): Retrieve Designated_Type instead of
Directly_Designated_Type of each access discriminant.
* sem_res.adb (Resolve_Type_Conversion): Retrieve Designated_Type
instead of Directly_Designated_Type when the operand and target types
are access types.
2010-06-22 Thomas Quinot <quinot@adacore.com>
* exp_aggr.adb (Flatten): Return False if one choice is statically
known to be out of bounds.
2010-06-22 Ed Schonberg <schonberg@adacore.com> 2010-06-22 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Call): If the call is rewritten as an indexed of * sem_res.adb (Resolve_Call): If the call is rewritten as an indexed of
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -173,14 +173,14 @@ package body Exp_Aggr is ...@@ -173,14 +173,14 @@ package body Exp_Aggr is
----------------------------------------------------- -----------------------------------------------------
function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean; function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean;
-- Very large static aggregates present problems to the back-end, and -- Very large static aggregates present problems to the back-end, and are
-- are transformed into assignments and loops. This function verifies -- transformed into assignments and loops. This function verifies that the
-- that the total number of components of an aggregate is acceptable -- total number of components of an aggregate is acceptable for rewriting
-- for transformation into a purely positional static form. It is called -- into a purely positional static form. It is called prior to calling
-- prior to calling Flatten. -- Flatten.
-- This function also detects and warns about one-component aggregates -- This function also detects and warns about one-component aggregates that
-- that appear in a non-static context. Even if the component value is -- appear in a non-static context. Even if the component value is static,
-- static, such an aggregate must be expanded into an assignment. -- such an aggregate must be expanded into an assignment.
procedure Convert_Array_Aggr_In_Allocator procedure Convert_Array_Aggr_In_Allocator
(Decl : Node_Id; (Decl : Node_Id;
...@@ -3782,10 +3782,11 @@ package body Exp_Aggr is ...@@ -3782,10 +3782,11 @@ package body Exp_Aggr is
Rep_Count : Nat; Rep_Count : Nat;
-- Used to validate Max_Others_Replicate limit -- Used to validate Max_Others_Replicate limit
Elmt : Node_Id; Elmt : Node_Id;
Num : Int := UI_To_Int (Lov); Num : Int := UI_To_Int (Lov);
Choice : Node_Id; Choice_Index : Int;
Lo, Hi : Node_Id; Choice : Node_Id;
Lo, Hi : Node_Id;
begin begin
if Present (Expressions (N)) then if Present (Expressions (N)) then
...@@ -3911,9 +3912,18 @@ package body Exp_Aggr is ...@@ -3911,9 +3912,18 @@ package body Exp_Aggr is
return False; return False;
else else
Vals (UI_To_Int (Expr_Value (Choice))) := Choice_Index := UI_To_Int (Expr_Value (Choice));
New_Copy_Tree (Expression (Elmt)); if Choice_Index in Vals'Range then
goto Continue; Vals (Choice_Index) :=
New_Copy_Tree (Expression (Elmt));
goto Continue;
else
-- Choice is statically out-of-range, will be
-- rewritten to raise Constraint_Error.
return False;
end if;
end if; end if;
end if; end if;
......
...@@ -1487,7 +1487,7 @@ package body Exp_Util is ...@@ -1487,7 +1487,7 @@ package body Exp_Util is
-- Handle access types -- Handle access types
if Is_Access_Type (Typ) then if Is_Access_Type (Typ) then
Typ := Directly_Designated_Type (Typ); Typ := Designated_Type (Typ);
end if; end if;
-- Handle task and protected types implementing interfaces -- Handle task and protected types implementing interfaces
...@@ -1594,7 +1594,7 @@ package body Exp_Util is ...@@ -1594,7 +1594,7 @@ package body Exp_Util is
-- Handle access types -- Handle access types
if Is_Access_Type (Typ) then if Is_Access_Type (Typ) then
Typ := Directly_Designated_Type (Typ); Typ := Designated_Type (Typ);
end if; end if;
-- Handle class-wide types -- Handle class-wide types
...@@ -2129,9 +2129,9 @@ package body Exp_Util is ...@@ -2129,9 +2129,9 @@ package body Exp_Util is
if Ekind (D_Typ) = E_Anonymous_Access_Type if Ekind (D_Typ) = E_Anonymous_Access_Type
and then and then
(Is_Controlled (Directly_Designated_Type (D_Typ)) (Is_Controlled (Designated_Type (D_Typ))
or else or else
Is_Concurrent_Type (Directly_Designated_Type (D_Typ))) Is_Concurrent_Type (Designated_Type (D_Typ)))
then then
return True; return True;
end if; end if;
......
...@@ -218,7 +218,7 @@ package body Sem_Res is ...@@ -218,7 +218,7 @@ package body Sem_Res is
-- A call to a user-defined intrinsic operator is rewritten as a call -- A call to a user-defined intrinsic operator is rewritten as a call
-- to the corresponding predefined operator, with suitable conversions. -- to the corresponding predefined operator, with suitable conversions.
-- Note that this applies only for intrinsic operators that denote -- Note that this applies only for intrinsic operators that denote
-- predefined operators, not opeartors that are intrinsic imports of -- predefined operators, not operators that are intrinsic imports of
-- back-end builtins. -- back-end builtins.
procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);
...@@ -4625,7 +4625,7 @@ package body Sem_Res is ...@@ -4625,7 +4625,7 @@ package body Sem_Res is
-- If the context is Universal_Fixed and the operands are also -- If the context is Universal_Fixed and the operands are also
-- universal fixed, this is an error, unless there is only one -- universal fixed, this is an error, unless there is only one
-- applicable fixed_point type (usually duration). -- applicable fixed_point type (usually Duration).
if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then
T := Unique_Fixed_Point_Type (N); T := Unique_Fixed_Point_Type (N);
...@@ -8608,11 +8608,11 @@ package body Sem_Res is ...@@ -8608,11 +8608,11 @@ package body Sem_Res is
begin begin
if Is_Access_Type (Opnd) then if Is_Access_Type (Opnd) then
Opnd := Directly_Designated_Type (Opnd); Opnd := Designated_Type (Opnd);
end if; end if;
if Is_Access_Type (Target_Typ) then if Is_Access_Type (Target_Typ) then
Target := Directly_Designated_Type (Target); Target := Designated_Type (Target);
end if; end if;
if Opnd = Target then if Opnd = Target then
......
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