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

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

gcc/ada/exp_ch4.adb

@@ -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
-      --  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).
+         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
+      --  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,
@@ -3454,6 +3516,7 @@ package body Exp_Ch4 is
    procedure Expand_N_Not_In (N : Node_Id) is
       Loc : constant Source_Ptr := Sloc (N);
       Typ : constant Entity_Id  := Etype (N);
+      Cfs : constant Boolean    := Comes_From_Source (N);
 
    begin
       Rewrite (N,
@@ -3462,6 +3525,15 @@ package body Exp_Ch4 is
             Make_In (Loc,
               Left_Opnd  => Left_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;
 
    ------------------------------

gcc/ada/exp_ch5.adb

@@ -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,