diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a923a920a60a..edb7aeeb9211 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,52 @@ +2009-07-07 Gary Dismukes + + * 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 * sem_ch4.adb (Analyze_Conditional_Expression): handle properly diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 4cfcb8e91356..fe6ac149f1dd 100644 --- a/gcc/ada/checks.adb +++ b/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))), diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 897b9e1a87dd..c22598582cac 100644 --- a/gcc/ada/exp_attr.adb +++ b/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; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 219175b5a14e..5aa5b6445398 100644 --- a/gcc/ada/exp_ch3.adb +++ b/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; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 66e9ed6351d3..4d50e0b9ccb7 100644 --- a/gcc/ada/exp_ch4.adb +++ b/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: diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 0659c7ef8f90..ddbe19f5b651 100644 --- a/gcc/ada/exp_ch5.adb +++ b/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 diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 991783f9415f..55e1f15db745 100644 --- a/gcc/ada/exp_ch6.adb +++ b/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. diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 43ed7c01295f..2c40c92ad172 100644 --- a/gcc/ada/sem_aggr.adb +++ b/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 diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index fb18cf34acf2..1e948f09566b 100644 --- a/gcc/ada/sem_eval.adb +++ b/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); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ba06ee8b58cc..3af4785a0262 100644 --- a/gcc/ada/sem_res.adb +++ b/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