diff options
| -rw-r--r-- | gcc/ada/checks.adb | 223 | ||||
| -rw-r--r-- | gcc/ada/checks.ads | 22 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 64 |
3 files changed, 137 insertions, 172 deletions
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index b68f366..b22d6f3 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -240,16 +240,6 @@ package body Checks is -- described for the above routines. The Do_Static flag indicates that -- only a static check is to be done. - procedure Apply_Selected_Range_Checks - (Expr : Node_Id; - Target_Typ : Entity_Id; - Source_Typ : Entity_Id; - Do_Static : Boolean); - -- This is the subprogram that does all the work for Apply_Range_Check. - -- Expr, Target_Typ and Source_Typ are as described for the above - -- routine. The Do_Static flag indicates that only a static check is - -- to be done. - procedure Compute_Range_For_Arithmetic_Op (Op : Node_Kind; Lo_Left : Uint; @@ -364,8 +354,8 @@ package body Checks is Target_Typ : Entity_Id; Source_Typ : Entity_Id; Warn_Node : Node_Id) return Check_Result; - -- Like Apply_Selected_Range_Checks, except it doesn't modify anything, - -- just returns a list of nodes as described in the spec of this package + -- Like Apply_Range_Checks, except it doesn't modify anything, just + -- returns a list of nodes as described in the spec of this package -- for the Range_Check function. ------------------------------ @@ -2910,13 +2900,107 @@ package body Checks is ----------------------- procedure Apply_Range_Check - (Expr : Node_Id; - Target_Typ : Entity_Id; - Source_Typ : Entity_Id := Empty) + (Expr : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty; + Insert_Node : Node_Id := Empty) is + Checks_On : constant Boolean := + not Index_Checks_Suppressed (Target_Typ) + or else + not Range_Checks_Suppressed (Target_Typ); + + Loc : constant Source_Ptr := Sloc (Expr); + + Cond : Node_Id; + R_Cno : Node_Id; + R_Result : Check_Result; + begin - Apply_Selected_Range_Checks - (Expr, Target_Typ, Source_Typ, Do_Static => False); + -- Only apply checks when generating code. In GNATprove mode, we do not + -- apply the checks, but we still call Selected_Range_Checks to possibly + -- issue errors on SPARK code when a run-time error can be detected at + -- compile time. + + if not GNATprove_Mode then + if not Expander_Active or not Checks_On then + return; + end if; + end if; + + R_Result := + Selected_Range_Checks (Expr, Target_Typ, Source_Typ, Insert_Node); + + if GNATprove_Mode then + return; + end if; + + for J in 1 .. 2 loop + R_Cno := R_Result (J); + exit when No (R_Cno); + + -- The range check requires runtime evaluation. Depending on what its + -- triggering condition is, the check may be converted into a compile + -- time constraint check. + + if Nkind (R_Cno) = N_Raise_Constraint_Error + and then Present (Condition (R_Cno)) + then + Cond := Condition (R_Cno); + + -- Insert the range check before the related context. Note that + -- this action analyses the triggering condition. + + if Present (Insert_Node) then + Insert_Action (Insert_Node, R_Cno); + else + Insert_Action (Expr, R_Cno); + end if; + + -- The triggering condition evaluates to True, the range check + -- can be converted into a compile time constraint check. + + if Is_Entity_Name (Cond) + and then Entity (Cond) = Standard_True + then + -- Since an N_Range is technically not an expression, we have + -- to set one of the bounds to C_E and then just flag the + -- N_Range. The warning message will point to the lower bound + -- and complain about a range, which seems OK. + + if Nkind (Expr) = N_Range then + Apply_Compile_Time_Constraint_Error + (Low_Bound (Expr), + "static range out of bounds of}??", + CE_Range_Check_Failed, + Ent => Target_Typ, + Typ => Target_Typ); + + Set_Raises_Constraint_Error (Expr); + + else + Apply_Compile_Time_Constraint_Error + (Expr, + "static value out of range of}??", + CE_Range_Check_Failed, + Ent => Target_Typ, + Typ => Target_Typ); + end if; + end if; + + -- The range check raises Constraint_Error explicitly + + elsif Present (Insert_Node) then + R_Cno := + Make_Raise_Constraint_Error (Sloc (Insert_Node), + Reason => CE_Range_Check_Failed); + + Insert_Action (Insert_Node, R_Cno); + + else + Install_Static_Check (R_Cno, Loc); + end if; + end loop; end Apply_Range_Check; ------------------------------ @@ -3429,111 +3513,6 @@ package body Checks is end loop; end Apply_Selected_Length_Checks; - --------------------------------- - -- Apply_Selected_Range_Checks -- - --------------------------------- - - procedure Apply_Selected_Range_Checks - (Expr : Node_Id; - Target_Typ : Entity_Id; - Source_Typ : Entity_Id; - Do_Static : Boolean) - is - Checks_On : constant Boolean := - not Index_Checks_Suppressed (Target_Typ) - or else - not Range_Checks_Suppressed (Target_Typ); - - Loc : constant Source_Ptr := Sloc (Expr); - - Cond : Node_Id; - R_Cno : Node_Id; - R_Result : Check_Result; - - begin - -- Only apply checks when generating code. In GNATprove mode, we do not - -- apply the checks, but we still call Selected_Range_Checks to possibly - -- issue errors on SPARK code when a run-time error can be detected at - -- compile time. - - if not GNATprove_Mode then - if not Expander_Active or not Checks_On then - return; - end if; - end if; - - R_Result := - Selected_Range_Checks (Expr, Target_Typ, Source_Typ, Empty); - - if GNATprove_Mode then - return; - end if; - - for J in 1 .. 2 loop - R_Cno := R_Result (J); - exit when No (R_Cno); - - -- The range check requires runtime evaluation. Depending on what its - -- triggering condition is, the check may be converted into a compile - -- time constraint check. - - if Nkind (R_Cno) = N_Raise_Constraint_Error - and then Present (Condition (R_Cno)) - then - Cond := Condition (R_Cno); - - -- Insert the range check before the related context. Note that - -- this action analyses the triggering condition. - - Insert_Action (Expr, R_Cno); - - -- The triggering condition evaluates to True, the range check - -- can be converted into a compile time constraint check. - - if Is_Entity_Name (Cond) - and then Entity (Cond) = Standard_True - then - -- Since an N_Range is technically not an expression, we have - -- to set one of the bounds to C_E and then just flag the - -- N_Range. The warning message will point to the lower bound - -- and complain about a range, which seems OK. - - if Nkind (Expr) = N_Range then - Apply_Compile_Time_Constraint_Error - (Low_Bound (Expr), - "static range out of bounds of}??", - CE_Range_Check_Failed, - Ent => Target_Typ, - Typ => Target_Typ); - - Set_Raises_Constraint_Error (Expr); - - else - Apply_Compile_Time_Constraint_Error - (Expr, - "static value out of range of}??", - CE_Range_Check_Failed, - Ent => Target_Typ, - Typ => Target_Typ); - end if; - - -- If we were only doing a static check, or if checks are not - -- on, then we want to delete the check, since it is not needed. - -- We do this by replacing the if statement by a null statement - - elsif Do_Static then - Remove_Warning_Messages (R_Cno); - Rewrite (R_Cno, Make_Null_Statement (Loc)); - end if; - - -- The range check raises Constraint_Error explicitly - - else - Install_Static_Check (R_Cno, Loc); - end if; - end loop; - end Apply_Selected_Range_Checks; - ------------------------------- -- Apply_Static_Length_Check -- ------------------------------- diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 79657c3..46fdda8 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -578,10 +578,20 @@ package Checks is -- which the check is to be done. Used to filter out specific cases where -- the check is superfluous. - procedure Apply_Range_Check + procedure Apply_Static_Length_Check (Expr : Node_Id; Target_Typ : Entity_Id; Source_Typ : Entity_Id := Empty); + -- Tries to determine statically whether the two array types source type + -- and Target_Typ have the same length. If it can be determined at compile + -- time that they do not, then an N_Raise_Constraint_Error node replaces + -- Expr, and a warning message is issued. + + procedure Apply_Range_Check + (Expr : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty; + Insert_Node : Node_Id := Empty); -- For a Node of kind N_Range, constructs a range check action that tests -- first that the range is not null and then that the range is contained in -- the Target_Typ range. @@ -606,14 +616,8 @@ package Checks is -- The source type is used by type conversions to unconstrained array -- types to retrieve the corresponding bounds. - procedure Apply_Static_Length_Check - (Expr : Node_Id; - Target_Typ : Entity_Id; - Source_Typ : Entity_Id := Empty); - -- Tries to determine statically whether the two array types source type - -- and Target_Typ have the same length. If it can be determined at compile - -- time that they do not, then an N_Raise_Constraint_Error node replaces - -- Expr, and a warning message is issued. + -- Insert_Node indicates the node where the check should be inserted. + -- If it is empty, then the check is inserted directly at Expr instead. procedure Apply_Scalar_Range_Check (Expr : Node_Id; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 8bb62c7..e33e3b3 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5266,7 +5266,6 @@ package body Sem_Ch3 is Skip : Boolean := False) is Id : constant Entity_Id := Defining_Identifier (N); - R_Checks : Check_Result; T : Entity_Id; begin @@ -5791,32 +5790,28 @@ package body Sem_Ch3 is -- Check that Constraint_Error is raised for a scalar subtype indication -- when the lower or upper bound of a non-null range lies outside the - -- range of the type mark. + -- range of the type mark. Likewise for an array subtype, but check the + -- compatibility for each index. if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then - if Is_Scalar_Type (Etype (Id)) - and then Scalar_Range (Id) /= - Scalar_Range - (Etype (Subtype_Mark (Subtype_Indication (N)))) - then - Apply_Range_Check - (Scalar_Range (Id), - Etype (Subtype_Mark (Subtype_Indication (N)))); - - -- In the array case, check compatibility for each index + declare + Indic_Typ : constant Entity_Id := + Etype (Subtype_Mark (Subtype_Indication (N))); + Subt_Index : Node_Id; + Target_Index : Node_Id; - elsif Is_Array_Type (Etype (Id)) and then Present (First_Index (Id)) - then - -- This really should be a subprogram that finds the indications - -- to check??? + begin + if Is_Scalar_Type (Etype (Id)) + and then Scalar_Range (Id) /= Scalar_Range (Indic_Typ) + then + Apply_Range_Check (Scalar_Range (Id), Indic_Typ); - declare - Subt_Index : Node_Id := First_Index (Id); - Target_Index : Node_Id := - First_Index (Etype - (Subtype_Mark (Subtype_Indication (N)))); + elsif Is_Array_Type (Etype (Id)) + and then Present (First_Index (Id)) + then + Subt_Index := First_Index (Id); + Target_Index := First_Index (Indic_Typ); - begin while Present (Subt_Index) loop if ((Nkind (Subt_Index) = N_Identifier and then Ekind (Entity (Subt_Index)) in Scalar_Kind) @@ -5824,30 +5819,17 @@ package body Sem_Ch3 is and then Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range then - declare - Target_Typ : constant Entity_Id := - Etype (Target_Index); - begin - R_Checks := - Get_Range_Checks - (Scalar_Range (Etype (Subt_Index)), - Target_Typ, - Etype (Subt_Index), - Defining_Identifier (N)); - - Insert_Range_Checks - (R_Checks, - N, - Target_Typ, - Sloc (Defining_Identifier (N))); - end; + Apply_Range_Check + (Scalar_Range (Etype (Subt_Index)), + Etype (Target_Index), + Insert_Node => N); end if; Next_Index (Subt_Index); Next_Index (Target_Index); end loop; - end; - end if; + end if; + end; end if; Set_Optimize_Alignment_Flags (Id); |