Skip to content

R
riscv-gcc-1
Commit 841dd0f5 by Arnaud Charlet
Options

[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
Showing with 51 additions and 24 deletions
gcc/ada/ChangeLog
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>
* sem_res.adb (Resolve_Call): If the call is rewritten as an indexed of
......
gcc/ada/exp_aggr.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -173,14 +173,14 @@ package body Exp_Aggr is
-----------------------------------------------------
function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean;
-- Very large static aggregates present problems to the back-end, and
-- are transformed into assignments and loops. This function verifies
-- that the total number of components of an aggregate is acceptable
-- for transformation into a purely positional static form. It is called
-- prior to calling Flatten.
-- This function also detects and warns about one-component aggregates
-- that appear in a non-static context. Even if the component value is
-- static, such an aggregate must be expanded into an assignment.
-- Very large static aggregates present problems to the back-end, and are
-- transformed into assignments and loops. This function verifies that the
-- total number of components of an aggregate is acceptable for rewriting
-- into a purely positional static form. It is called prior to calling
-- Flatten.
-- This function also detects and warns about one-component aggregates that
-- appear in a non-static context. Even if the component value is static,
-- such an aggregate must be expanded into an assignment.
procedure Convert_Array_Aggr_In_Allocator
(Decl : Node_Id;
......@@ -3782,10 +3782,11 @@ package body Exp_Aggr is
Rep_Count : Nat;
-- Used to validate Max_Others_Replicate limit
Elmt : Node_Id;
Num : Int := UI_To_Int (Lov);
Choice : Node_Id;
Lo, Hi : Node_Id;
Elmt : Node_Id;
Num : Int := UI_To_Int (Lov);
Choice_Index : Int;
Choice : Node_Id;
Lo, Hi : Node_Id;
begin
if Present (Expressions (N)) then
......@@ -3911,9 +3912,18 @@ package body Exp_Aggr is
return False;
else
Vals (UI_To_Int (Expr_Value (Choice))) :=
New_Copy_Tree (Expression (Elmt));
goto Continue;
Choice_Index := UI_To_Int (Expr_Value (Choice));
if Choice_Index in Vals'Range then
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;
......
gcc/ada/exp_util.adb
......@@ -1487,7 +1487,7 @@ package body Exp_Util is
-- Handle access types
if Is_Access_Type (Typ) then
Typ := Directly_Designated_Type (Typ);
Typ := Designated_Type (Typ);
end if;
-- Handle task and protected types implementing interfaces
......@@ -1594,7 +1594,7 @@ package body Exp_Util is
-- Handle access types
if Is_Access_Type (Typ) then
Typ := Directly_Designated_Type (Typ);
Typ := Designated_Type (Typ);
end if;
-- Handle class-wide types
......@@ -2129,9 +2129,9 @@ package body Exp_Util is
if Ekind (D_Typ) = E_Anonymous_Access_Type
and then
(Is_Controlled (Directly_Designated_Type (D_Typ))
(Is_Controlled (Designated_Type (D_Typ))
or else
Is_Concurrent_Type (Directly_Designated_Type (D_Typ)))
Is_Concurrent_Type (Designated_Type (D_Typ)))
then
return True;
end if;
......
gcc/ada/sem_res.adb
......@@ -218,7 +218,7 @@ package body Sem_Res is
-- A call to a user-defined intrinsic operator is rewritten as a call
-- to the corresponding predefined operator, with suitable conversions.
-- 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.
procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);
......@@ -4625,7 +4625,7 @@ package body Sem_Res is
-- If the context is Universal_Fixed and the operands are also
-- 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
T := Unique_Fixed_Point_Type (N);
......@@ -8608,11 +8608,11 @@ package body Sem_Res is
begin
if Is_Access_Type (Opnd) then
Opnd := Directly_Designated_Type (Opnd);
Opnd := Designated_Type (Opnd);
end if;
if Is_Access_Type (Target_Typ) then
Target := Directly_Designated_Type (Target);
Target := Designated_Type (Target);
end if;
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