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

1 files changed, 19 insertions, 9 deletions

diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 4880b4d..54da8cb4 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -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,