diff options
Diffstat (limited to 'gcc/ada/checks.adb')
| -rw-r--r-- | gcc/ada/checks.adb | 72 |
1 files changed, 59 insertions, 13 deletions
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 38b6ea4d7e2..a0ca4c61a43 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -575,6 +575,8 @@ package body Checks is -------------------------------- procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is + pragma Assert (Nkind (N) = N_Freeze_Entity); + AC : constant Node_Id := Address_Clause (E); Loc : constant Source_Ptr := Sloc (AC); Typ : constant Entity_Id := Etype (E); @@ -734,7 +736,11 @@ package body Checks is Remove_Side_Effects (Expr); end if; - Insert_After_And_Analyze (N, + if No (Actions (N)) then + Set_Actions (N, New_List); + end if; + + Prepend_To (Actions (N), Make_Raise_Program_Error (Loc, Condition => Make_Op_Ne (Loc, @@ -745,11 +751,11 @@ package body Checks is (RTE (RE_Integer_Address), Expr), Right_Opnd => Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (E, Loc), + Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Alignment)), Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), - Reason => PE_Misaligned_Address_Value), - Suppress => All_Checks); + Reason => PE_Misaligned_Address_Value)); + Analyze (First (Actions (N)), Suppress => All_Checks); return; end if; @@ -5516,6 +5522,23 @@ package body Checks is or else Index_Checks_Suppressed (Etype (A)) then return; + + -- The indexed component we are dealing with contains 'Loop_Entry in its + -- prefix. This case arises when analysis has determined that constructs + -- such as + + -- Prefix'Loop_Entry (Expr) + -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN) + + -- require rewriting for error detection purposes. A side effect of this + -- action is the generation of index checks that mention 'Loop_Entry. + -- Delay the generation of the check until 'Loop_Entry has been properly + -- expanded. This is done in Expand_Loop_Entry_Attributes. + + elsif Nkind (Prefix (N)) = N_Attribute_Reference + and then Attribute_Name (Prefix (N)) = Name_Loop_Entry + then + return; end if; -- Generate a raise of constraint error with the appropriate reason and @@ -6216,6 +6239,8 @@ package body Checks is declare DRC : constant Boolean := Do_Range_Check (Exp); + PV : Node_Id; + CE : Node_Id; begin Set_Do_Range_Check (Exp, False); @@ -6228,22 +6253,43 @@ package body Checks is Force_Evaluation (Exp, Name_Req => True); end if; - -- Insert the validity check. Note that we do this with validity - -- checks turned off, to avoid recursion, we do not want validity - -- checks on the validity checking code itself! + -- Build the prefix for the 'Valid call + + PV := Duplicate_Subexpr_No_Checks (Exp, Name_Req => True); - Insert_Action - (Expr, + -- A rather specialized kludge. If PV is an analyzed expression + -- which is an indexed component of a packed array that has not + -- been properly expanded, turn off its Analyzed flag to make sure + -- it gets properly reexpanded. + + -- The reason this arises is that Duplicate_Subexpr_No_Checks did + -- an analyze with the old parent pointer. This may point e.g. to + -- a subprogram call, which deactivates this expansion. + + if Analyzed (PV) + and then Nkind (PV) = N_Indexed_Component + and then Present (Packed_Array_Type (Etype (Prefix (PV)))) + then + Set_Analyzed (PV, False); + end if; + + -- Build the raise CE node to check for validity + + CE := Make_Raise_Constraint_Error (Loc, Condition => Make_Op_Not (Loc, Right_Opnd => Make_Attribute_Reference (Loc, - Prefix => - Duplicate_Subexpr_No_Checks (Exp, Name_Req => True), + Prefix => PV, Attribute_Name => Name_Valid)), - Reason => CE_Invalid_Data), - Suppress => Validity_Check); + Reason => CE_Invalid_Data); + + -- Insert the validity check. Note that we do this with validity + -- checks turned off, to avoid recursion, we do not want validity + -- checks on the validity checking code itself! + + Insert_Action (Expr, CE, Suppress => Validity_Check); -- If the expression is a reference to an element of a bit-packed -- array, then it is rewritten as a renaming declaration. If the |