checks.adb (Generate_Range_Check): Replace type conversions with unchecked…

checks.adb (Generate_Range_Check): Replace type conversions with unchecked conversions to support the case of...

2009-07-07  Gary Dismukes  <dismukes@adacore.com>

	* checks.adb (Generate_Range_Check): Replace type conversions with
	unchecked conversions to support the case of performing range checks
	on Enum'Val (permits integer values to be converted to enumeration).

	* exp_attr.adb (Expand_N_Attribute_Reference, cases Attribute_Pred,
	Attribute_Succ): Set Do_Range_Check to False before calling
	Expand_Pred_Succ, to prevent gigi from generating any range checks.
	(Expand_N_Attribute_Reference, case Attribute_Val):
	Generate a range check when needed (and set Do_Range_Check to False).

	* exp_ch3.adb (Expand_N_Object_Declaration): Generate a range check on
	scalar object initialization if needed.

	* exp_ch4.adb (Expand_Allocator_Expression): Generate range checks
	when needed on scalar allocators.
	(Expand_N_Qualified_Expression): Generate range check when needed.
	(Expand_N_Slice): Remove call to Enable_Range_Check on slice ranges.
	Checks on slice ranges handled in Resolve_Slice.

	* exp_ch5.adb (Expand_N_Assignment_Statement): Generate a range check,
	when needed, for all scalar assignments, not just discrete.
	(Expand_Simple_Function_Return): Resolve the conversion created for a
	scalar function return so that the conversion will get expanded to
	generate a possible constraint check.

	* exp_ch6.adb (Expand_Actuals): Call Add_Call_By_Copy_Code for out and
	in out scalar actuals when subtypes don't match, to ensure generation
	of return checks (and set Do_Range_Check to False).
	(Expand_Call): Uncomment code to perform range checks, but make it apply
	only to in and in out parameters (checks on parameter returns are
	handled in Expand_Actuals). If a scalar actual for a call to a derived
	subprogram is marked as needing a range check, peform it here (and set
	Do_Range_Check to False).

	* sem_aggr.adb (Resolve_*_Aggregate.Resolve_Aggr_Expr): Generate a
	range check on scalar component associations when needed.

	* sem_eval.adb (In_Subrange_Of): Return False when the first type has
	infinities but the second type does not, as these aren't compatible
	floating-point types.

	* sem_res.adb (Resolve_Slice): In the case where the prefix of the
	slice is itself a slice, pick up the Etype of the prefix. This handles
	the case where the prefix was an Image attribute expanded to a slice,
	and ensures that we get the subtype with the slice constraint rather
	than the unconstrained subbtype of the 'Image.

From-SVN: r149318

gcc/ada/ChangeLog

+2009-07-07  Gary Dismukes  <dismukes@adacore.com>
+
+	* checks.adb (Generate_Range_Check): Replace type conversions with
+	unchecked conversions to support the case of performing range checks
+	on Enum'Val (permits integer values to be converted to enumeration).
+
+	* exp_attr.adb (Expand_N_Attribute_Reference, cases Attribute_Pred,
+	Attribute_Succ): Set Do_Range_Check to False before calling
+	Expand_Pred_Succ, to prevent gigi from generating any range checks.
+	(Expand_N_Attribute_Reference, case Attribute_Val):
+	Generate a range check when needed (and set Do_Range_Check to False).
+
+	* exp_ch3.adb (Expand_N_Object_Declaration): Generate a range check on
+	scalar object initialization if needed.
+
+	* exp_ch4.adb (Expand_Allocator_Expression): Generate range checks
+	when needed on scalar allocators.
+	(Expand_N_Qualified_Expression): Generate range check when needed.
+	(Expand_N_Slice): Remove call to Enable_Range_Check on slice ranges.
+	Checks on slice ranges handled in Resolve_Slice.
+
+	* exp_ch5.adb (Expand_N_Assignment_Statement): Generate a range check,
+	when needed, for all scalar assignments, not just discrete.
+	(Expand_Simple_Function_Return): Resolve the conversion created for a
+	scalar function return so that the conversion will get expanded to
+	generate a possible constraint check.
+
+	* exp_ch6.adb (Expand_Actuals): Call Add_Call_By_Copy_Code for out and
+	in out scalar actuals when subtypes don't match, to ensure generation
+	of return checks (and set Do_Range_Check to False).
+	(Expand_Call): Uncomment code to perform range checks, but make it apply
+	only to in and in out parameters (checks on parameter returns are
+	handled in Expand_Actuals). If a scalar actual for a call to a derived
+	subprogram is marked as needing a range check, peform it here (and set
+	Do_Range_Check to False).
+
+	* sem_aggr.adb (Resolve_*_Aggregate.Resolve_Aggr_Expr): Generate a
+	range check on scalar component associations when needed.
+
+	* sem_eval.adb (In_Subrange_Of): Return False when the first type has
+	infinities but the second type does not, as these aren't compatible
+	floating-point types.
+
+	* sem_res.adb (Resolve_Slice): In the case where the prefix of the
+	slice is itself a slice, pick up the Etype of the prefix. This handles
+	the case where the prefix was an Image attribute expanded to a slice,
+	and ensures that we get the subtype with the slice constraint rather
+	than the unconstrained subbtype of the 'Image.
+
 2009-07-07  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_ch4.adb (Analyze_Conditional_Expression): handle properly

gcc/ada/checks.adb

@@ -4682,6 +4682,12 @@ package body Checks is
 
       --  The conversions will always work and need no check
 
+      --  Unchecked_Convert_To is used instead of Convert_To to handle the case
+      --  of converting from an enumeration value to an integer type, such as
+      --  occurs for the case of generating a range check on Enum'Val(Exp)
+      --  (which used to be handled by gigi). This is OK, since the conversion
+      --  itself does not require a check.
+
       elsif In_Subrange_Of (Target_Type, Source_Base_Type) then
          Insert_Action (N,
            Make_Raise_Constraint_Error (Loc,
@@ -4692,14 +4698,14 @@ package body Checks is
                  Right_Opnd =>
                    Make_Range (Loc,
                      Low_Bound =>
-                       Convert_To (Source_Base_Type,
+                       Unchecked_Convert_To (Source_Base_Type,
                          Make_Attribute_Reference (Loc,
                            Prefix =>
                              New_Occurrence_Of (Target_Type, Loc),
                            Attribute_Name => Name_First)),
 
                      High_Bound =>
-                       Convert_To (Source_Base_Type,
+                       Unchecked_Convert_To (Source_Base_Type,
                          Make_Attribute_Reference (Loc,
                            Prefix =>
                              New_Occurrence_Of (Target_Type, Loc),
@@ -4891,7 +4897,7 @@ package body Checks is
                      New_Occurrence_Of (Target_Base_Type, Loc),
                    Constant_Present    => True,
                    Expression          =>
-                     Make_Type_Conversion (Loc,
+                     Make_Unchecked_Type_Conversion (Loc,
                        Subtype_Mark =>
                          New_Occurrence_Of (Target_Base_Type, Loc),
                        Expression   => Duplicate_Subexpr (N))),

gcc/ada/exp_attr.adb

@@ -3388,10 +3388,13 @@ package body Exp_Attr is
          elsif Is_Modular_Integer_Type (Ptyp) then
             null;
 
-         --  For other types, if range checking is enabled, we must generate
-         --  a check if overflow checking is enabled.
+         --  For other types, if argument is marked as needing a range check or
+         --  overflow checking is enabled, we must generate a check.
 
-         elsif not Overflow_Checks_Suppressed (Ptyp) then
+         elsif not Overflow_Checks_Suppressed (Ptyp)
+           or else Do_Range_Check (First (Exprs))
+         then
+            Set_Do_Range_Check (First (Exprs), False);
             Expand_Pred_Succ (N);
          end if;
       end Pred;
@@ -4319,10 +4322,13 @@ package body Exp_Attr is
          elsif Is_Modular_Integer_Type (Ptyp) then
             null;
 
-         --  For other types, if range checking is enabled, we must generate
-         --  a check if overflow checking is enabled.
+         --  For other types, if argument is marked as needing a range check or
+         --  overflow checking is enabled, we must generate a check.
 
-         elsif not Overflow_Checks_Suppressed (Ptyp) then
+         elsif not Overflow_Checks_Suppressed (Ptyp)
+           or else Do_Range_Check (First (Exprs))
+         then
+            Set_Do_Range_Check (First (Exprs), False);
             Expand_Pred_Succ (N);
          end if;
       end Succ;
@@ -4629,6 +4635,13 @@ package body Exp_Attr is
             end if;
 
             Analyze_And_Resolve (N, Typ);
+
+         --  If the argument is marked as requiring a range check then generate
+         --  it here.
+
+         elsif Do_Range_Check (First (Exprs)) then
+            Set_Do_Range_Check (First (Exprs), False);
+            Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
          end if;
       end Val;
 

gcc/ada/exp_ch3.adb

@@ -4515,6 +4515,14 @@ package body Exp_Ch3 is
                   null;
                else
                   Apply_Constraint_Check (Expr, Typ);
+
+                  --  If the expression has been marked as requiring a range
+                  --  generate it now and reset the flag.
+
+                  if Do_Range_Check (Expr) then
+                     Set_Do_Range_Check (Expr, False);
+                     Generate_Range_Check (Expr, Typ, CE_Range_Check_Failed);
+                  end if;
                end if;
             end if;
 

gcc/ada/exp_ch4.adb

@@ -1038,6 +1038,11 @@ package body Exp_Ch4 is
 
          Apply_Constraint_Check (Exp, T, No_Sliding => True);
 
+         if Do_Range_Check (Exp) then
+            Set_Do_Range_Check (Exp, False);
+            Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
+         end if;
+
          --  A check is also needed in cases where the designated subtype is
          --  constrained and differs from the subtype given in the qualified
          --  expression. Note that the check on the qualified expression does
@@ -1048,6 +1053,11 @@ package body Exp_Ch4 is
          then
             Apply_Constraint_Check
               (Exp, DesigT, No_Sliding => False);
+
+            if Do_Range_Check (Exp) then
+               Set_Do_Range_Check (Exp, False);
+               Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
+            end if;
          end if;
 
          --  For an access to unconstrained packed array, GIGI needs to see an
@@ -7073,6 +7083,11 @@ package body Exp_Ch4 is
       --  Apply possible constraint check
 
       Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
+
+      if Do_Range_Check (Operand) then
+         Set_Do_Range_Check (Operand, False);
+         Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
+      end if;
    end Expand_N_Qualified_Expression;
 
    ---------------------------------
@@ -7429,32 +7444,6 @@ package body Exp_Ch4 is
          Make_Build_In_Place_Call_In_Anonymous_Context (Pfx);
       end if;
 
-      --  Range checks are potentially also needed for cases involving a slice
-      --  indexed by a subtype indication, but Do_Range_Check can currently
-      --  only be set for expressions ???
-
-      if not Index_Checks_Suppressed (Ptp)
-        and then (not Is_Entity_Name (Pfx)
-                   or else not Index_Checks_Suppressed (Entity (Pfx)))
-        and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
-
-         --  Do not enable range check to nodes associated with the frontend
-         --  expansion of the dispatch table. We first check if Ada.Tags is
-         --  already loaded to avoid the addition of an undesired dependence
-         --  on such run-time unit.
-
-        and then
-          (not Tagged_Type_Expansion
-            or else not
-             (RTU_Loaded (Ada_Tags)
-               and then Nkind (Prefix (N)) = N_Selected_Component
-               and then Present (Entity (Selector_Name (Prefix (N))))
-               and then Entity (Selector_Name (Prefix (N))) =
-                                  RTE_Record_Component (RE_Prims_Ptr)))
-      then
-         Enable_Range_Check (Discrete_Range (N));
-      end if;
-
       --  The remaining case to be handled is packed slices. We can leave
       --  packed slices as they are in the following situations:
 

gcc/ada/exp_ch5.adb

@@ -1530,12 +1530,9 @@ package body Exp_Ch5 is
          end;
       end if;
 
-      --  First deal with generation of range check if required. For now we do
-      --  this only for discrete types.
+      --  First deal with generation of range check if required
 
-      if Do_Range_Check (Rhs)
-        and then Is_Discrete_Type (Typ)
-      then
+      if Do_Range_Check (Rhs) then
          Set_Do_Range_Check (Rhs, False);
          Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
       end if;
@@ -3853,7 +3850,11 @@ package body Exp_Ch5 is
 
       if Is_Scalar_Type (Exptyp) then
          Rewrite (Exp, Convert_To (R_Type, Exp));
-         Analyze (Exp);
+
+         --  The expression is resolved to ensure that the conversion gets
+         --  expanded to generate a possible constraint check.
+
+         Analyze_And_Resolve (Exp, R_Type);
       end if;
 
       --  Deal with returning variable length objects and controlled types

gcc/ada/exp_ch6.adb

@@ -1589,6 +1589,25 @@ package body Exp_Ch6 is
               and then Has_Volatile_Components (Entity (Prefix (Actual)))
             then
                Add_Call_By_Copy_Code;
+
+            --  Add call-by-copy code for the case of scalar out parameters
+            --  when it is not known at compile time that the subtype of the
+            --  formal is a subrange of the subtype of the actual, in order
+            --  to get return range checks on such actuals. (Maybe this case
+            --  should be handled earlier in the if statement???)
+
+            elsif Is_Scalar_Type (E_Formal)
+              and then not In_Subrange_Of (E_Formal, Etype (Actual))
+            then
+               --  Perhaps the setting back to False should be done within
+               --  Add_Call_By_Copy_Code, since it could get set on other
+               --  cases occurring above???
+
+               if Do_Range_Check (Actual) then
+                  Set_Do_Range_Check (Actual, False);
+               end if;
+
+               Add_Call_By_Copy_Code;
             end if;
 
          --  Processing for IN parameters
@@ -2028,13 +2047,15 @@ package body Exp_Ch6 is
       Param_Count := 1;
       while Present (Formal) loop
 
-         --  Generate range check if required (not activated yet ???)
+         --  Generate range check if required
 
---         if Do_Range_Check (Actual) then
---            Set_Do_Range_Check (Actual, False);
---            Generate_Range_Check
---              (Actual, Etype (Formal), CE_Range_Check_Failed);
---         end if;
+         if Do_Range_Check (Actual)
+           and then Ekind (Formal) /= E_Out_Parameter
+         then
+            Set_Do_Range_Check (Actual, False);
+            Generate_Range_Check
+              (Actual, Etype (Formal), CE_Range_Check_Failed);
+         end if;
 
          --  Prepare to examine current entry
 
@@ -2711,6 +2732,15 @@ package body Exp_Ch6 is
                      Convert (Actual, Parent_Typ);
                      Enable_Range_Check (Actual);
 
+                     --  If the actual has been marked as requiring a range
+                     --  check, then generate it here.
+
+                     if Do_Range_Check (Actual) then
+                        Set_Do_Range_Check (Actual, False);
+                        Generate_Range_Check
+                          (Actual, Etype (Formal), CE_Range_Check_Failed);
+                     end if;
+
                   --  For access types, the parent formal type and actual type
                   --  differ.
 

gcc/ada/sem_aggr.adb

@@ -1473,6 +1473,14 @@ package body Sem_Aggr is
             Set_Raises_Constraint_Error (N);
          end if;
 
+         --  If the expression has been marked as requiring a range check,
+         --  then generate it here.
+
+         if Do_Range_Check (Expr) then
+            Set_Do_Range_Check (Expr, False);
+            Generate_Range_Check (Expr, Component_Typ, CE_Range_Check_Failed);
+         end if;
+
          return Resolution_OK;
       end Resolve_Aggr_Expr;
 
@@ -2801,6 +2809,14 @@ package body Sem_Aggr is
             Set_Raises_Constraint_Error (N);
          end if;
 
+         --  If the expression has been marked as requiring a range check,
+         --  then generate it here.
+
+         if Do_Range_Check (Expr) then
+            Set_Do_Range_Check (Expr, False);
+            Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed);
+         end if;
+
          if Relocate then
             Add_Association (New_C, Relocate_Node (Expr), New_Assoc_List);
          else

gcc/ada/sem_eval.adb

@@ -3738,6 +3738,16 @@ package body Sem_Eval is
       elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then
          return False;
 
+      --  If T1 has infinities but T2 doesn't have infinities, then T1 is
+      --  definitely not compatible with T2.
+
+      elsif Is_Floating_Point_Type (T1)
+        and then Has_Infinities (T1)
+        and then Is_Floating_Point_Type (T2)
+        and then not Has_Infinities (T2)
+      then
+         return False;
+
       else
          L1 := Type_Low_Bound  (T1);
          H1 := Type_High_Bound (T1);

gcc/ada/sem_res.adb

@@ -7887,6 +7887,16 @@ package body Sem_Res is
             Insert_Action (N, Act_Decl);
             Array_Type := Defining_Identifier (Act_Decl);
          end;
+
+      --  Maybe this should just be "else", instead of checking for the
+      --  specific case of slice??? This is needed for the case where
+      --  the prefix is an Image attribute, which gets expanded to a
+      --  slice, and so has a constrained subtype which we want to use
+      --  for the slice range check applied below (the range check won't
+      --  get done if the unconstrained subtype of the 'Image is used).
+
+      elsif Nkind (Name) = N_Slice then
+         Array_Type := Etype (Name);
       end if;
 
       --  If name was overloaded, set slice type correctly now