-- 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;
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.
------------------------------
-----------------------
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;
------------------------------
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 --
-------------------------------
-- 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.
-- 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;
Skip : Boolean := False)
is
Id : constant Entity_Id := Defining_Identifier (N);
- R_Checks : Check_Result;
T : Entity_Id;
begin
-- 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)
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);
projects / gcc.git / commitdiff