diff options
Diffstat (limited to 'gcc/ada/checks.adb')
| -rw-r--r-- | gcc/ada/checks.adb | 63 |
1 files changed, 42 insertions, 21 deletions
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index d815a534a21..1dfd0de9914 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -450,6 +450,17 @@ package body Checks is return; end if; + -- No check if accessing the Offset_To_Top component of a dispatch + -- table. They are safe by construction. + + if Present (Etype (P)) + and then RTU_Loaded (Ada_Tags) + and then RTE_Available (RE_Offset_To_Top_Ptr) + and then Etype (P) = RTE (RE_Offset_To_Top_Ptr) + then + return; + end if; + -- Otherwise go ahead and install the check Install_Null_Excluding_Check (P); @@ -1239,12 +1250,23 @@ package body Checks is return; end if; - exit when - not Is_OK_Static_Expression (ItemS) - or else - not Is_OK_Static_Expression (ItemT); + -- If the expressions for the discriminants are identical + -- and it is side-effect free (for now just an entity), + -- this may be a shared constraint, e.g. from a subtype + -- without a constraint introduced as a generic actual. + -- Examine other discriminants if any. + + if ItemS = ItemT + and then Is_Entity_Name (ItemS) + then + null; + + elsif not Is_OK_Static_Expression (ItemS) + or else not Is_OK_Static_Expression (ItemT) + then + exit; - if Expr_Value (ItemS) /= Expr_Value (ItemT) then + elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then if Do_Access then -- needs run-time check. exit; else @@ -2723,10 +2745,13 @@ package body Checks is end if; end if; - -- Check that null-excluding objects are always initialized + -- Check that null-excluding objects are always initialized, except for + -- deferred constants, for which the expression will appear in the full + -- declaration. if K = N_Object_Declaration and then No (Expression (N)) + and then not Constant_Present (N) and then not No_Initialization (N) then -- Add an expression that assigns null. This node is needed by @@ -2742,9 +2767,9 @@ package body Checks is Reason => CE_Null_Not_Allowed); end if; - -- Check that a null-excluding component, formal or object is not - -- being assigned a null value. Otherwise generate a warning message - -- and replace Expression (N) by a N_Constraint_Error node. + -- Check that a null-excluding component, formal or object is not being + -- assigned a null value. Otherwise generate a warning message and + -- replace Expression (N) by an N_Contraint_Error node. if K /= N_Function_Specification then Expr := Expression (N); @@ -3368,14 +3393,14 @@ package body Checks is -- Nothing to do if the range of the result is known OK. We skip this -- for conversions, since the caller already did the check, and in any -- case the condition for deleting the check for a type conversion is - -- different in any case. + -- different. if Nkind (N) /= N_Type_Conversion then Determine_Range (N, OK, Lo, Hi); - -- Note in the test below that we assume that if a bound of the - -- range is equal to that of the type. That's not quite accurate - -- but we do this for the following reasons: + -- Note in the test below that we assume that the range is not OK + -- if a bound of the range is equal to that of the type. That's not + -- quite accurate but we do this for the following reasons: -- a) The way that Determine_Range works, it will typically report -- the bounds of the value as being equal to the bounds of the @@ -3385,7 +3410,7 @@ package body Checks is -- b) It is very unusual to have a situation in which this would -- generate an unnecessary overflow check (an example would be -- a subtype with a range 0 .. Integer'Last - 1 to which the - -- literal value one is added. + -- literal value one is added). -- c) The alternative is a lot of special casing in this routine -- which would partially duplicate Determine_Range processing. @@ -4121,12 +4146,7 @@ package body Checks is -- appropriate one for our purposes. if (Ekind (Ent) = E_Variable - or else - Ekind (Ent) = E_Constant - or else - Ekind (Ent) = E_Loop_Parameter - or else - Ekind (Ent) = E_In_Parameter) + or else Is_Constant_Object (Ent)) and then not Is_Library_Level_Entity (Ent) then Entry_OK := True; @@ -4371,7 +4391,8 @@ package body Checks is Duplicate_Subexpr_Move_Checks (Sub)), Right_Opnd => Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr_Move_Checks (A), + Prefix => + Duplicate_Subexpr_Move_Checks (A, Name_Req => True), Attribute_Name => Name_Range, Expressions => Num)), Reason => CE_Index_Check_Failed)); |
