OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

exp_ch4.adb (Expand_N_In): Replace test of expression in its own type by valid test and generate warning. 

2005-09-01  Robert Dewar  <dewar@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* exp_ch4.adb (Expand_N_In): Replace test of expression in its own
	type by valid test and generate warning.
	(Tagged_Membership): Generate call to the run-time
	subprogram IW_Membership in case of "Iface_CW_Typ in Typ'Class"
	Change formal name Subtype_Mark to Result_Definition in several calls to
	Make_Function_Specification.
	(Expand_Allocator_Expression): Add tests for suppression of the AI-344
	check for proper accessibility of the operand of a class-wide allocator.
	The check can be left out if checks are suppressed or if the expression
	has a specific tagged type whose level is known to be safe.

	* exp_ch5.adb (Expand_N_Assignment_Statement): Simplify the code that
	generates the run-time check associated with null-excluding entities.
	(Expand_N_Return_Statement): Add tests to determine if the accessibility
	check on the level of the return expression of a class-wide function
	can be elided. The check usually isn't needed if the expression has a
	specific type (unless it's a conversion or a formal parameter). Also
	add a test for whether accessibility checks are suppressed. Augment
	the comments to describe the conditions for performing the check.

From-SVN: r103849
This commit is contained in:
Robert Dewar 2005-09-05 09:47:26 +02:00 committed by Arnaud Charlet
parent 1a2c495da9
commit 630d30e96d
2 changed files with 129 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

144
gcc/ada/exp_ch4.adb
View File

@ -444,21 +444,24 @@ package body Exp_Ch4 is
Expression => Node));
end if;
-- Ada 2005 (AI-344):
-- For an allocator with a class-wide designated type, generate an
-- accessibility check to verify that the level of the type of the
-- created object is not deeper than the level of the access type.
-- If the type of the qualified expression is class-wide, then
-- always generate the check. Otherwise, only generate the check
-- if the level of the qualified expression type is statically deeper
-- than the access type. Although the static accessibility will
-- generally have been performed as a legality check, it won't have
-- been done in cases where the allocator appears in a generic body,
-- so the run-time check is needed in general. (Not yet doing the
-- optimization to suppress the check for the static level case.???)
-- Ada 2005 (AI-344): For an allocator with a class-wide designated
-- type, generate an accessibility check to verify that the level of
-- the type of the created object is not deeper than the level of the
-- access type. If the type of the qualified expression is class-
-- wide, then always generate the check. Otherwise, only generate the
-- check if the level of the qualified expression type is statically
-- deeper than the access type. Although the static accessibility
-- will generally have been performed as a legality check, it won't
-- have been done in cases where the allocator appears in generic
-- body, so a run-time check is needed in general.
if Ada_Version >= Ada_05
and then Is_Class_Wide_Type (Designated_Type (PtrT))
and then not Scope_Suppress (Accessibility_Check)
and then
(Is_Class_Wide_Type (Etype (Exp))
or else
Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT))
then
Insert_Action (N,
Make_Raise_Program_Error (Loc,
@ -1388,7 +1391,7 @@ package body Exp_Ch4 is
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Name,
Parameter_Specifications => Formals,
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
Declarations => Decls,
@ -1833,7 +1836,7 @@ package body Exp_Ch4 is
-- end loop;
-- end if;
-- . . .
-- ...
-- if Sn'Length /= 0 then
-- P := Sn'First;
@ -2215,7 +2218,7 @@ package body Exp_Ch4 is
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Id,
Parameter_Specifications => Param_Specs,
Subtype_Mark => New_Reference_To (Base_Typ, Loc));
Result_Definition => New_Reference_To (Base_Typ, Loc));
-- Construct L's object declaration
@ -3034,22 +3037,81 @@ package body Exp_Ch4 is
Rop : constant Node_Id := Right_Opnd (N);
Static : constant Boolean := Is_OK_Static_Expression (N);
procedure Substitute_Valid_Check;
-- Replaces node N by Lop'Valid. This is done when we have an explicit
-- test for the left operand being in range of its subtype.
----------------------------
-- Substitute_Valid_Check --
----------------------------
procedure Substitute_Valid_Check is
begin
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Lop),
Attribute_Name => Name_Valid));
Analyze_And_Resolve (N, Rtyp);
Error_Msg_N ("?explicit membership test may be optimized away", N);
Error_Msg_N ("\?use ''Valid attribute instead", N);
return;
end Substitute_Valid_Check;
-- Start of processing for Expand_N_In
begin
-- If we have an explicit range, do a bit of optimization based
-- on range analysis (we may be able to kill one or both checks).
-- Check case of explicit test for an expression in range of its
-- subtype. This is suspicious usage and we replace it with a 'Valid
-- test and give a warning.
if Is_Scalar_Type (Etype (Lop))
and then Nkind (Rop) in N_Has_Entity
and then Etype (Lop) = Entity (Rop)
and then Comes_From_Source (N)
then
Substitute_Valid_Check;
return;
end if;
-- Case of explicit range
if Nkind (Rop) = N_Range then
declare
Lcheck : constant Compare_Result :=
Compile_Time_Compare (Lop, Low_Bound (Rop));
Ucheck : constant Compare_Result :=
Compile_Time_Compare (Lop, High_Bound (Rop));
Lo : constant Node_Id := Low_Bound (Rop);
Hi : constant Node_Id := High_Bound (Rop);
Lo_Orig : constant Node_Id := Original_Node (Lo);
Hi_Orig : constant Node_Id := Original_Node (Hi);
Lcheck : constant Compare_Result := Compile_Time_Compare (Lop, Lo);
Ucheck : constant Compare_Result := Compile_Time_Compare (Lop, Hi);
begin
-- If either check is known to fail, replace result
-- by False, since the other check does not matter.
-- Preserve the static flag for legality checks, because
-- we are constant-folding beyond RM 4.9.
-- If test is explicit x'first .. x'last, replace by valid check
if Is_Scalar_Type (Etype (Lop))
and then Nkind (Lo_Orig) = N_Attribute_Reference
and then Attribute_Name (Lo_Orig) = Name_First
and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
and then Entity (Prefix (Lo_Orig)) = Etype (Lop)
and then Nkind (Hi_Orig) = N_Attribute_Reference
and then Attribute_Name (Hi_Orig) = Name_Last
and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
and then Entity (Prefix (Hi_Orig)) = Etype (Lop)
and then Comes_From_Source (N)
then
Substitute_Valid_Check;
return;
end if;
-- If we have an explicit range, do a bit of optimization based
-- on range analysis (we may be able to kill one or both checks).
-- If either check is known to fail, replace result by False since
-- the other check does not matter. Preserve the static flag for
-- legality checks, because we are constant-folding beyond RM 4.9.
if Lcheck = LT or else Ucheck = GT then
Rewrite (N,
@ -3452,8 +3514,9 @@ package body Exp_Ch4 is
-- can be done. This avoids needing to duplicate this expansion code.
procedure Expand_N_Not_In (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Cfs : constant Boolean := Comes_From_Source (N);
begin
Rewrite (N,
@ -3461,7 +3524,16 @@ package body Exp_Ch4 is
Right_Opnd =>
Make_In (Loc,
Left_Opnd => Left_Opnd (N),
Right_Opnd => Right_Opnd (N))));
Right_Opnd => Right_Opnd (N))));
-- We want this tp appear as coming from source if original does (see
-- tranformations in Expand_N_In).
Set_Comes_From_Source (N, Cfs);
Set_Comes_From_Source (Right_Opnd (N), Cfs);
-- Now analyze tranformed node
Analyze_And_Resolve (N, Typ);
end Expand_N_Not_In;
@ -3995,7 +4067,7 @@ package body Exp_Ch4 is
-- Obj1 : Enclosing_Non_UU_Type;
-- Obj2 : Enclosing_Non_UU_Type (1);
-- . . . Obj1 = Obj2 . . .
-- ... Obj1 = Obj2 ...
-- Generated code:
@ -5446,7 +5518,7 @@ package body Exp_Ch4 is
Make_Parameter_Specification (Loc,
Defining_Identifier => A,
Parameter_Type => New_Reference_To (Typ, Loc))),
Subtype_Mark => New_Reference_To (Typ, Loc)),
Result_Definition => New_Reference_To (Typ, Loc)),
Declarations => New_List (
Make_Object_Declaration (Loc,
@ -7715,7 +7787,7 @@ package body Exp_Ch4 is
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Name,
Parameter_Specifications => Formals,
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
Declarations => New_List (
Make_Object_Declaration (Loc,
@ -7846,7 +7918,7 @@ package body Exp_Ch4 is
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Name,
Parameter_Specifications => Formals,
Subtype_Mark => New_Reference_To (Typ, Loc)),
Result_Definition => New_Reference_To (Typ, Loc)),
Declarations => New_List (
Make_Object_Declaration (Loc,
@ -8052,7 +8124,12 @@ package body Exp_Ch4 is
-- Ada 2005 (AI-251): Class-wide applied to interfaces
if Is_Interface (Etype (Class_Wide_Type (Right_Type))) then
if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
-- Give support to: "Iface_CW_Typ in Typ'Class"
or else Is_Interface (Left_Type)
then
return
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
@ -8087,7 +8164,6 @@ package body Exp_Ch4 is
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
end if;
end Tagged_Membership;
------------------------------

28
gcc/ada/exp_ch5.adb
View File

@ -1542,7 +1542,7 @@ package body Exp_Ch5 is
-- create dereferences but are not semantic aliasings.
elsif Is_Private_Type (Etype (Lhs))
and then Has_Discriminants (Typ)
and then Has_Discriminants (Typ)
and then Nkind (Lhs) = N_Explicit_Dereference
and then Comes_From_Source (Lhs)
then
@ -1621,17 +1621,13 @@ package body Exp_Ch5 is
(Expression (Rhs), Designated_Type (Etype (Lhs)));
end if;
-- Ada 2005 (AI-231): Generate conversion to the null-excluding
-- type to force the corresponding run-time check
-- Ada 2005 (AI-231): Generate the run-time check
if Is_Access_Type (Typ)
and then
((Is_Entity_Name (Lhs) and then Can_Never_Be_Null (Entity (Lhs)))
or else Can_Never_Be_Null (Etype (Lhs)))
and then Can_Never_Be_Null (Etype (Lhs))
and then not Can_Never_Be_Null (Etype (Rhs))
then
Rewrite (Rhs, Convert_To (Etype (Lhs),
Relocate_Node (Rhs)));
Analyze_And_Resolve (Rhs, Etype (Lhs));
Apply_Constraint_Check (Rhs, Etype (Lhs));
end if;
-- If we are assigning an access type and the left side is an
@ -2833,9 +2829,23 @@ package body Exp_Ch5 is
-- Ada 2005 (AI-344): If the result type is class-wide, then insert
-- a check that the level of the return expression's underlying type
-- is not deeper than the level of the master enclosing the function.
-- Always generate the check when the type of the return expression
-- is class-wide, when it's a type conversion, or when it's a formal
-- parameter. Otherwise, suppress the check in the case where the
-- return expression has a specific type whose level is known not to
-- be statically deeper than the function's result type.
elsif Ada_Version >= Ada_05
and then Is_Class_Wide_Type (Return_Type)
and then not Scope_Suppress (Accessibility_Check)
and then
(Is_Class_Wide_Type (Etype (Exp))
or else Nkind (Exp) = N_Type_Conversion
or else Nkind (Exp) = N_Unchecked_Type_Conversion
or else (Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) in Formal_Kind)
or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))
then
Insert_Action (Exp,
Make_Raise_Program_Error (Loc,