| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- C H E C K S -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; use Atree; |
| with Debug; use Debug; |
| with Einfo; use Einfo; |
| with Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| with Elists; use Elists; |
| with Eval_Fat; use Eval_Fat; |
| with Exp_Ch11; use Exp_Ch11; |
| with Exp_Ch4; use Exp_Ch4; |
| with Exp_Pakd; use Exp_Pakd; |
| with Exp_Util; use Exp_Util; |
| with Expander; use Expander; |
| with Freeze; use Freeze; |
| with Lib; use Lib; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Output; use Output; |
| with Restrict; use Restrict; |
| with Rident; use Rident; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Ch3; use Sem_Ch3; |
| with Sem_Ch8; use Sem_Ch8; |
| with Sem_Cat; use Sem_Cat; |
| with Sem_Disp; use Sem_Disp; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Mech; use Sem_Mech; |
| with Sem_Res; use Sem_Res; |
| with Sem_Util; use Sem_Util; |
| with Sem_Warn; use Sem_Warn; |
| with Sinfo; use Sinfo; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| with Sinput; use Sinput; |
| with Snames; use Snames; |
| with Sprint; use Sprint; |
| with Stand; use Stand; |
| with Stringt; use Stringt; |
| with Targparm; use Targparm; |
| with Tbuild; use Tbuild; |
| with Ttypes; use Ttypes; |
| with Validsw; use Validsw; |
| |
| package body Checks is |
| |
| -- General note: many of these routines are concerned with generating |
| -- checking code to make sure that constraint error is raised at runtime. |
| -- Clearly this code is only needed if the expander is active, since |
| -- otherwise we will not be generating code or going into the runtime |
| -- execution anyway. |
| |
| -- We therefore disconnect most of these checks if the expander is |
| -- inactive. This has the additional benefit that we do not need to |
| -- worry about the tree being messed up by previous errors (since errors |
| -- turn off expansion anyway). |
| |
| -- There are a few exceptions to the above rule. For instance routines |
| -- such as Apply_Scalar_Range_Check that do not insert any code can be |
| -- safely called even when the Expander is inactive (but Errors_Detected |
| -- is 0). The benefit of executing this code when expansion is off, is |
| -- the ability to emit constraint error warnings for static expressions |
| -- even when we are not generating code. |
| |
| -- The above is modified in gnatprove mode to ensure that proper check |
| -- flags are always placed, even if expansion is off. |
| |
| ------------------------------------- |
| -- Suppression of Redundant Checks -- |
| ------------------------------------- |
| |
| -- This unit implements a limited circuit for removal of redundant |
| -- checks. The processing is based on a tracing of simple sequential |
| -- flow. For any sequence of statements, we save expressions that are |
| -- marked to be checked, and then if the same expression appears later |
| -- with the same check, then under certain circumstances, the second |
| -- check can be suppressed. |
| |
| -- Basically, we can suppress the check if we know for certain that |
| -- the previous expression has been elaborated (together with its |
| -- check), and we know that the exception frame is the same, and that |
| -- nothing has happened to change the result of the exception. |
| |
| -- Let us examine each of these three conditions in turn to describe |
| -- how we ensure that this condition is met. |
| |
| -- First, we need to know for certain that the previous expression has |
| -- been executed. This is done principally by the mechanism of calling |
| -- Conditional_Statements_Begin at the start of any statement sequence |
| -- and Conditional_Statements_End at the end. The End call causes all |
| -- checks remembered since the Begin call to be discarded. This does |
| -- miss a few cases, notably the case of a nested BEGIN-END block with |
| -- no exception handlers. But the important thing is to be conservative. |
| -- The other protection is that all checks are discarded if a label |
| -- is encountered, since then the assumption of sequential execution |
| -- is violated, and we don't know enough about the flow. |
| |
| -- Second, we need to know that the exception frame is the same. We |
| -- do this by killing all remembered checks when we enter a new frame. |
| -- Again, that's over-conservative, but generally the cases we can help |
| -- with are pretty local anyway (like the body of a loop for example). |
| |
| -- Third, we must be sure to forget any checks which are no longer valid. |
| -- This is done by two mechanisms, first the Kill_Checks_Variable call is |
| -- used to note any changes to local variables. We only attempt to deal |
| -- with checks involving local variables, so we do not need to worry |
| -- about global variables. Second, a call to any non-global procedure |
| -- causes us to abandon all stored checks, since such a all may affect |
| -- the values of any local variables. |
| |
| -- The following define the data structures used to deal with remembering |
| -- checks so that redundant checks can be eliminated as described above. |
| |
| -- Right now, the only expressions that we deal with are of the form of |
| -- simple local objects (either declared locally, or IN parameters) or |
| -- such objects plus/minus a compile time known constant. We can do |
| -- more later on if it seems worthwhile, but this catches many simple |
| -- cases in practice. |
| |
| -- The following record type reflects a single saved check. An entry |
| -- is made in the stack of saved checks if and only if the expression |
| -- has been elaborated with the indicated checks. |
| |
| type Saved_Check is record |
| Killed : Boolean; |
| -- Set True if entry is killed by Kill_Checks |
| |
| Entity : Entity_Id; |
| -- The entity involved in the expression that is checked |
| |
| Offset : Uint; |
| -- A compile time value indicating the result of adding or |
| -- subtracting a compile time value. This value is to be |
| -- added to the value of the Entity. A value of zero is |
| -- used for the case of a simple entity reference. |
| |
| Check_Type : Character; |
| -- This is set to 'R' for a range check (in which case Target_Type |
| -- is set to the target type for the range check) or to 'O' for an |
| -- overflow check (in which case Target_Type is set to Empty). |
| |
| Target_Type : Entity_Id; |
| -- Used only if Do_Range_Check is set. Records the target type for |
| -- the check. We need this, because a check is a duplicate only if |
| -- it has the same target type (or more accurately one with a |
| -- range that is smaller or equal to the stored target type of a |
| -- saved check). |
| end record; |
| |
| -- The following table keeps track of saved checks. Rather than use an |
| -- extensible table, we just use a table of fixed size, and we discard |
| -- any saved checks that do not fit. That's very unlikely to happen and |
| -- this is only an optimization in any case. |
| |
| Saved_Checks : array (Int range 1 .. 200) of Saved_Check; |
| -- Array of saved checks |
| |
| Num_Saved_Checks : Nat := 0; |
| -- Number of saved checks |
| |
| -- The following stack keeps track of statement ranges. It is treated |
| -- as a stack. When Conditional_Statements_Begin is called, an entry |
| -- is pushed onto this stack containing the value of Num_Saved_Checks |
| -- at the time of the call. Then when Conditional_Statements_End is |
| -- called, this value is popped off and used to reset Num_Saved_Checks. |
| |
| -- Note: again, this is a fixed length stack with a size that should |
| -- always be fine. If the value of the stack pointer goes above the |
| -- limit, then we just forget all saved checks. |
| |
| Saved_Checks_Stack : array (Int range 1 .. 100) of Nat; |
| Saved_Checks_TOS : Nat := 0; |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id); |
| -- Used to apply arithmetic overflow checks for all cases except operators |
| -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we |
| -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a |
| -- signed integer arithmetic operator (but not an if or case expression). |
| -- It is also called for types other than signed integers. |
| |
| procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id); |
| -- Used to apply arithmetic overflow checks for the case where the overflow |
| -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer |
| -- arithmetic op (which includes the case of if and case expressions). Note |
| -- that Do_Overflow_Check may or may not be set for node Op. In these modes |
| -- we have work to do even if overflow checking is suppressed. |
| |
| procedure Apply_Division_Check |
| (N : Node_Id; |
| Rlo : Uint; |
| Rhi : Uint; |
| ROK : Boolean); |
| -- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies |
| -- division checks as required if the Do_Division_Check flag is set. |
| -- Rlo and Rhi give the possible range of the right operand, these values |
| -- can be referenced and trusted only if ROK is set True. |
| |
| procedure Apply_Float_Conversion_Check |
| (Expr : Node_Id; |
| Target_Typ : Entity_Id); |
| -- The checks on a conversion from a floating-point type to an integer |
| -- type are delicate. They have to be performed before conversion, they |
| -- have to raise an exception when the operand is a NaN, and rounding must |
| -- be taken into account to determine the safe bounds of the operand. |
| |
| procedure Apply_Selected_Length_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_Length_Check |
| -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as |
| -- described for the above routines. 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; |
| Hi_Left : Uint; |
| Lo_Right : Uint; |
| Hi_Right : Uint; |
| OK : out Boolean; |
| Lo : out Uint; |
| Hi : out Uint); |
| -- Given an integer arithmetical operation Op and the range of values of |
| -- its operand(s), try to compute a conservative estimate of the possible |
| -- range of values for the result of the operation. Thus if OK is True on |
| -- return, the result is known to lie in the range Lo .. Hi (inclusive). |
| -- If OK is false, both Lo and Hi are set to No_Uint. |
| |
| type Check_Type is new Check_Id range Access_Check .. Division_Check; |
| function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean; |
| -- This function is used to see if an access or division by zero check is |
| -- needed. The check is to be applied to a single variable appearing in the |
| -- source, and N is the node for the reference. If N is not of this form, |
| -- True is returned with no further processing. If N is of the right form, |
| -- then further processing determines if the given Check is needed. |
| -- |
| -- The particular circuit is to see if we have the case of a check that is |
| -- not needed because it appears in the right operand of a short circuited |
| -- conditional where the left operand guards the check. For example: |
| -- |
| -- if Var = 0 or else Q / Var > 12 then |
| -- ... |
| -- end if; |
| -- |
| -- In this example, the division check is not required. At the same time |
| -- we can issue warnings for suspicious use of non-short-circuited forms, |
| -- such as: |
| -- |
| -- if Var = 0 or Q / Var > 12 then |
| -- ... |
| -- end if; |
| |
| procedure Find_Check |
| (Expr : Node_Id; |
| Check_Type : Character; |
| Target_Type : Entity_Id; |
| Entry_OK : out Boolean; |
| Check_Num : out Nat; |
| Ent : out Entity_Id; |
| Ofs : out Uint); |
| -- This routine is used by Enable_Range_Check and Enable_Overflow_Check |
| -- to see if a check is of the form for optimization, and if so, to see |
| -- if it has already been performed. Expr is the expression to check, |
| -- and Check_Type is 'R' for a range check, 'O' for an overflow check. |
| -- Target_Type is the target type for a range check, and Empty for an |
| -- overflow check. If the entry is not of the form for optimization, |
| -- then Entry_OK is set to False, and the remaining out parameters |
| -- are undefined. If the entry is OK, then Ent/Ofs are set to the |
| -- entity and offset from the expression. Check_Num is the number of |
| -- a matching saved entry in Saved_Checks, or zero if no such entry |
| -- is located. |
| |
| function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id; |
| -- If a discriminal is used in constraining a prival, Return reference |
| -- to the discriminal of the protected body (which renames the parameter |
| -- of the enclosing protected operation). This clumsy transformation is |
| -- needed because privals are created too late and their actual subtypes |
| -- are not available when analysing the bodies of the protected operations. |
| -- This function is called whenever the bound is an entity and the scope |
| -- indicates a protected operation. If the bound is an in-parameter of |
| -- a protected operation that is not a prival, the function returns the |
| -- bound itself. |
| -- To be cleaned up??? |
| |
| function Guard_Access |
| (Cond : Node_Id; |
| Loc : Source_Ptr; |
| Expr : Node_Id) return Node_Id; |
| -- In the access type case, guard the test with a test to ensure |
| -- that the access value is non-null, since the checks do not |
| -- not apply to null access values. |
| |
| procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr); |
| -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the |
| -- Constraint_Error node. |
| |
| function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean; |
| -- Returns True if node N is for an arithmetic operation with signed |
| -- integer operands. This includes unary and binary operators, and also |
| -- if and case expression nodes where the dependent expressions are of |
| -- a signed integer type. These are the kinds of nodes for which special |
| -- handling applies in MINIMIZED or ELIMINATED overflow checking mode. |
| |
| function Range_Or_Validity_Checks_Suppressed |
| (Expr : Node_Id) return Boolean; |
| -- Returns True if either range or validity checks or both are suppressed |
| -- for the type of the given expression, or, if the expression is the name |
| -- of an entity, if these checks are suppressed for the entity. |
| |
| function Selected_Length_Checks |
| (Expr : Node_Id; |
| Target_Typ : Entity_Id; |
| Source_Typ : Entity_Id; |
| Warn_Node : Node_Id) return Check_Result; |
| -- Like Apply_Selected_Length_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. |
| -- ??? In fact it does construct the test and insert it into the tree, |
| -- and insert actions in various ways (calling Insert_Action directly |
| -- in particular) so we do not call it in GNATprove mode, contrary to |
| -- Selected_Range_Checks. |
| |
| function Selected_Range_Checks |
| (Expr : Node_Id; |
| Target_Typ : Entity_Id; |
| Source_Typ : Entity_Id; |
| Warn_Node : Node_Id) return Check_Result; |
| -- Like Apply_Range_Check, except it does not modify anything, just |
| -- returns a list of nodes as described in the spec of this package |
| -- for the Range_Check function. |
| |
| ------------------------------ |
| -- Access_Checks_Suppressed -- |
| ------------------------------ |
| |
| function Access_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if Present (E) and then Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Access_Check); |
| else |
| return Scope_Suppress.Suppress (Access_Check); |
| end if; |
| end Access_Checks_Suppressed; |
| |
| ------------------------------------- |
| -- Accessibility_Checks_Suppressed -- |
| ------------------------------------- |
| |
| function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if No_Dynamic_Accessibility_Checks_Enabled (E) then |
| return True; |
| |
| elsif Present (E) and then Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Accessibility_Check); |
| |
| else |
| return Scope_Suppress.Suppress (Accessibility_Check); |
| end if; |
| end Accessibility_Checks_Suppressed; |
| |
| ----------------------------- |
| -- Activate_Division_Check -- |
| ----------------------------- |
| |
| procedure Activate_Division_Check (N : Node_Id) is |
| begin |
| Set_Do_Division_Check (N, True); |
| Possible_Local_Raise (N, Standard_Constraint_Error); |
| end Activate_Division_Check; |
| |
| ----------------------------- |
| -- Activate_Overflow_Check -- |
| ----------------------------- |
| |
| procedure Activate_Overflow_Check (N : Node_Id) is |
| Typ : constant Entity_Id := Etype (N); |
| |
| begin |
| -- Floating-point case. If Etype is not set (this can happen when we |
| -- activate a check on a node that has not yet been analyzed), then |
| -- we assume we do not have a floating-point type (as per our spec). |
| |
| if Present (Typ) and then Is_Floating_Point_Type (Typ) then |
| |
| -- Ignore call if we have no automatic overflow checks on the target |
| -- and Check_Float_Overflow mode is not set. These are the cases in |
| -- which we expect to generate infinities and NaN's with no check. |
| |
| if not (Machine_Overflows_On_Target or Check_Float_Overflow) then |
| return; |
| |
| -- Ignore for unary operations ("+", "-", abs) since these can never |
| -- result in overflow for floating-point cases. |
| |
| elsif Nkind (N) in N_Unary_Op then |
| return; |
| |
| -- Otherwise we will set the flag |
| |
| else |
| null; |
| end if; |
| |
| -- Discrete case |
| |
| else |
| -- Nothing to do for Rem/Mod/Plus (overflow not possible, the check |
| -- for zero-divide is a divide check, not an overflow check). |
| |
| if Nkind (N) in N_Op_Rem | N_Op_Mod | N_Op_Plus then |
| return; |
| end if; |
| end if; |
| |
| -- Fall through for cases where we do set the flag |
| |
| Set_Do_Overflow_Check (N); |
| Possible_Local_Raise (N, Standard_Constraint_Error); |
| end Activate_Overflow_Check; |
| |
| -------------------------- |
| -- Activate_Range_Check -- |
| -------------------------- |
| |
| procedure Activate_Range_Check (N : Node_Id) is |
| begin |
| Set_Do_Range_Check (N); |
| Possible_Local_Raise (N, Standard_Constraint_Error); |
| end Activate_Range_Check; |
| |
| --------------------------------- |
| -- Alignment_Checks_Suppressed -- |
| --------------------------------- |
| |
| function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if Present (E) and then Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Alignment_Check); |
| else |
| return Scope_Suppress.Suppress (Alignment_Check); |
| end if; |
| end Alignment_Checks_Suppressed; |
| |
| ---------------------------------- |
| -- Allocation_Checks_Suppressed -- |
| ---------------------------------- |
| |
| -- Note: at the current time there are no calls to this function, because |
| -- the relevant check is in the run-time, so it is not a check that the |
| -- compiler can suppress anyway, but we still have to recognize the check |
| -- name Allocation_Check since it is part of the standard. |
| |
| function Allocation_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if Present (E) and then Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Allocation_Check); |
| else |
| return Scope_Suppress.Suppress (Allocation_Check); |
| end if; |
| end Allocation_Checks_Suppressed; |
| |
| ------------------------- |
| -- Append_Range_Checks -- |
| ------------------------- |
| |
| procedure Append_Range_Checks |
| (Checks : Check_Result; |
| Stmts : List_Id; |
| Suppress_Typ : Entity_Id; |
| Static_Sloc : Source_Ptr) |
| is |
| Checks_On : constant Boolean := |
| not Index_Checks_Suppressed (Suppress_Typ) |
| or else |
| not Range_Checks_Suppressed (Suppress_Typ); |
| |
| begin |
| -- For now we just return if Checks_On is false, however this could be |
| -- enhanced to check for an always True value in the condition and to |
| -- generate a compilation warning. |
| |
| if not Checks_On then |
| return; |
| end if; |
| |
| for J in 1 .. 2 loop |
| exit when No (Checks (J)); |
| |
| if Nkind (Checks (J)) = N_Raise_Constraint_Error |
| and then Present (Condition (Checks (J))) |
| then |
| Append_To (Stmts, Checks (J)); |
| else |
| Append_To |
| (Stmts, |
| Make_Raise_Constraint_Error (Static_Sloc, |
| Reason => CE_Range_Check_Failed)); |
| end if; |
| end loop; |
| end Append_Range_Checks; |
| |
| ------------------------ |
| -- Apply_Access_Check -- |
| ------------------------ |
| |
| procedure Apply_Access_Check (N : Node_Id) is |
| P : constant Node_Id := Prefix (N); |
| |
| begin |
| -- We do not need checks if we are not generating code (i.e. the |
| -- expander is not active). This is not just an optimization, there |
| -- are cases (e.g. with pragma Debug) where generating the checks |
| -- can cause real trouble. |
| |
| if not Expander_Active then |
| return; |
| end if; |
| |
| -- No check if short circuiting makes check unnecessary |
| |
| if not Check_Needed (P, Access_Check) then |
| return; |
| end if; |
| |
| -- No check if accessing the Offset_To_Top component of a dispatch |
| -- table. They are safe by construction. |
| |
| if Tagged_Type_Expansion |
| and then Present (Etype (P)) |
| and then Is_RTE (Etype (P), RE_Offset_To_Top_Ptr) |
| then |
| return; |
| end if; |
| |
| -- Otherwise go ahead and install the check |
| |
| Install_Null_Excluding_Check (P); |
| end Apply_Access_Check; |
| |
| ------------------------------- |
| -- Apply_Accessibility_Check -- |
| ------------------------------- |
| |
| procedure Apply_Accessibility_Check |
| (N : Node_Id; |
| Typ : Entity_Id; |
| Insert_Node : Node_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| Check_Cond : Node_Id; |
| Param_Ent : Entity_Id := Param_Entity (N); |
| Param_Level : Node_Id; |
| Type_Level : Node_Id; |
| |
| begin |
| -- Verify we haven't tried to add a dynamic accessibility check when we |
| -- shouldn't. |
| |
| pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N)); |
| |
| if Ada_Version >= Ada_2012 |
| and then No (Param_Ent) |
| and then Is_Entity_Name (N) |
| and then Ekind (Entity (N)) in E_Constant | E_Variable |
| and then Present (Effective_Extra_Accessibility (Entity (N))) |
| then |
| Param_Ent := Entity (N); |
| while Present (Renamed_Object (Param_Ent)) loop |
| -- Renamed_Object must return an Entity_Name here |
| -- because of preceding "Present (E_E_A (...))" test. |
| |
| Param_Ent := Entity (Renamed_Object (Param_Ent)); |
| end loop; |
| end if; |
| |
| if Inside_A_Generic then |
| return; |
| |
| -- Only apply the run-time check if the access parameter has an |
| -- associated extra access level parameter and when accessibility checks |
| -- are enabled. |
| |
| elsif Present (Param_Ent) |
| and then Present (Get_Dynamic_Accessibility (Param_Ent)) |
| and then not Accessibility_Checks_Suppressed (Param_Ent) |
| and then not Accessibility_Checks_Suppressed (Typ) |
| then |
| -- Obtain the parameter's accessibility level |
| |
| Param_Level := |
| New_Occurrence_Of (Get_Dynamic_Accessibility (Param_Ent), Loc); |
| |
| -- Use the dynamic accessibility parameter for the function's result |
| -- when one has been created instead of statically referring to the |
| -- deepest type level so as to appropriatly handle the rules for |
| -- RM 3.10.2 (10.1/3). |
| |
| if Ekind (Scope (Param_Ent)) = E_Function |
| and then In_Return_Value (N) |
| and then Ekind (Typ) = E_Anonymous_Access_Type |
| then |
| -- Associate the level of the result type to the extra result |
| -- accessibility parameter belonging to the current function. |
| |
| if Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) then |
| Type_Level := |
| New_Occurrence_Of |
| (Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc); |
| |
| -- In Ada 2005 and earlier modes, a result extra accessibility |
| -- parameter is not generated and no dynamic check is performed. |
| |
| else |
| return; |
| end if; |
| |
| -- Otherwise get the type's accessibility level normally |
| |
| else |
| Type_Level := |
| Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ)); |
| end if; |
| |
| -- Raise Program_Error if the accessibility level of the access |
| -- parameter is deeper than the level of the target access type. |
| |
| Check_Cond := |
| Make_Op_Gt (Loc, |
| Left_Opnd => Param_Level, |
| Right_Opnd => Type_Level); |
| |
| Insert_Action (Insert_Node, |
| Make_Raise_Program_Error (Loc, |
| Condition => Check_Cond, |
| Reason => PE_Accessibility_Check_Failed)); |
| |
| Analyze_And_Resolve (N); |
| |
| -- If constant folding has happened on the condition for the |
| -- generated error, then warn about it being unconditional. |
| |
| if Nkind (Check_Cond) = N_Identifier |
| and then Entity (Check_Cond) = Standard_True |
| then |
| Error_Msg_Warn := SPARK_Mode /= On; |
| Error_Msg_N ("accessibility check fails<<", N); |
| Error_Msg_N ("\Program_Error [<<", N); |
| end if; |
| end if; |
| end Apply_Accessibility_Check; |
| |
| -------------------------------- |
| -- Apply_Address_Clause_Check -- |
| -------------------------------- |
| |
| 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); |
| |
| Expr : Node_Id; |
| -- Address expression (not necessarily the same as Aexp, for example |
| -- when Aexp is a reference to a constant, in which case Expr gets |
| -- reset to reference the value expression of the constant). |
| |
| begin |
| -- See if alignment check needed. Note that we never need a check if the |
| -- maximum alignment is one, since the check will always succeed. |
| |
| -- Note: we do not check for checks suppressed here, since that check |
| -- was done in Sem_Ch13 when the address clause was processed. We are |
| -- only called if checks were not suppressed. The reason for this is |
| -- that we have to delay the call to Apply_Alignment_Check till freeze |
| -- time (so that all types etc are elaborated), but we have to check |
| -- the status of check suppressing at the point of the address clause. |
| |
| if No (AC) |
| or else not Check_Address_Alignment (AC) |
| or else Maximum_Alignment = 1 |
| then |
| return; |
| end if; |
| |
| -- Obtain expression from address clause |
| |
| Expr := Address_Value (Expression (AC)); |
| |
| -- See if we know that Expr has an acceptable value at compile time. If |
| -- it hasn't or we don't know, we defer issuing the warning until the |
| -- end of the compilation to take into account back end annotations. |
| |
| if Compile_Time_Known_Value (Expr) |
| and then (Known_Alignment (E) or else Known_Alignment (Typ)) |
| then |
| declare |
| AL : Uint := Alignment (Typ); |
| |
| begin |
| -- The object alignment might be more restrictive than the type |
| -- alignment. |
| |
| if Known_Alignment (E) then |
| AL := Alignment (E); |
| end if; |
| |
| if Expr_Value (Expr) mod AL = 0 then |
| return; |
| end if; |
| end; |
| |
| -- If the expression has the form X'Address, then we can find out if the |
| -- object X has an alignment that is compatible with the object E. If it |
| -- hasn't or we don't know, we defer issuing the warning until the end |
| -- of the compilation to take into account back end annotations. |
| |
| elsif Nkind (Expr) = N_Attribute_Reference |
| and then Attribute_Name (Expr) = Name_Address |
| and then |
| Has_Compatible_Alignment (E, Prefix (Expr), False) = Known_Compatible |
| then |
| return; |
| end if; |
| |
| -- Here we do not know if the value is acceptable. Strictly we don't |
| -- have to do anything, since if the alignment is bad, we have an |
| -- erroneous program. However we are allowed to check for erroneous |
| -- conditions and we decide to do this by default if the check is not |
| -- suppressed. |
| |
| -- However, don't do the check if elaboration code is unwanted |
| |
| if Restriction_Active (No_Elaboration_Code) then |
| return; |
| |
| -- Generate a check to raise PE if alignment may be inappropriate |
| |
| else |
| -- If the original expression is a nonstatic constant, use the name |
| -- of the constant itself rather than duplicating its initialization |
| -- expression, which was extracted above. |
| |
| -- Note: Expr is empty if the address-clause is applied to in-mode |
| -- actuals (allowed by 13.1(22)). |
| |
| if No (Expr) |
| or else |
| (Is_Entity_Name (Expression (AC)) |
| and then Ekind (Entity (Expression (AC))) = E_Constant |
| and then Nkind (Parent (Entity (Expression (AC)))) = |
| N_Object_Declaration) |
| then |
| Expr := New_Copy_Tree (Expression (AC)); |
| else |
| Remove_Side_Effects (Expr); |
| end if; |
| |
| 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, |
| Left_Opnd => |
| Make_Op_Mod (Loc, |
| Left_Opnd => |
| Unchecked_Convert_To |
| (RTE (RE_Integer_Address), Expr), |
| Right_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (E, Loc), |
| Attribute_Name => Name_Alignment)), |
| Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), |
| Reason => PE_Misaligned_Address_Value)); |
| |
| Warning_Msg := No_Error_Msg; |
| Analyze (First (Actions (N)), Suppress => All_Checks); |
| |
| -- If the above raise action generated a warning message (for example |
| -- from Warn_On_Non_Local_Exception mode with the active restriction |
| -- No_Exception_Propagation). |
| |
| if Warning_Msg /= No_Error_Msg then |
| |
| -- If the expression has a known at compile time value, then |
| -- once we know the alignment of the type, we can check if the |
| -- exception will be raised or not, and if not, we don't need |
| -- the warning so we will kill the warning later on. |
| |
| if Compile_Time_Known_Value (Expr) then |
| Alignment_Warnings.Append |
| ((E => E, |
| A => Expr_Value (Expr), |
| P => Empty, |
| W => Warning_Msg)); |
| |
| -- Likewise if the expression is of the form X'Address |
| |
| elsif Nkind (Expr) = N_Attribute_Reference |
| and then Attribute_Name (Expr) = Name_Address |
| then |
| Alignment_Warnings.Append |
| ((E => E, |
| A => No_Uint, |
| P => Prefix (Expr), |
| W => Warning_Msg)); |
| |
| -- Add explanation of the warning generated by the check |
| |
| else |
| Error_Msg_N |
| ("\address value may be incompatible with alignment of " |
| & "object?.x?", AC); |
| end if; |
| end if; |
| |
| return; |
| end if; |
| |
| exception |
| |
| -- If we have some missing run time component in configurable run time |
| -- mode then just skip the check (it is not required in any case). |
| |
| when RE_Not_Available => |
| return; |
| end Apply_Address_Clause_Check; |
| |
| ------------------------------------- |
| -- Apply_Arithmetic_Overflow_Check -- |
| ------------------------------------- |
| |
| procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is |
| begin |
| -- Use old routine in almost all cases (the only case we are treating |
| -- specially is the case of a signed integer arithmetic op with the |
| -- overflow checking mode set to MINIMIZED or ELIMINATED). |
| |
| if Overflow_Check_Mode = Strict |
| or else not Is_Signed_Integer_Arithmetic_Op (N) |
| then |
| Apply_Arithmetic_Overflow_Strict (N); |
| |
| -- Otherwise use the new routine for the case of a signed integer |
| -- arithmetic op, with Do_Overflow_Check set to True, and the checking |
| -- mode is MINIMIZED or ELIMINATED. |
| |
| else |
| Apply_Arithmetic_Overflow_Minimized_Eliminated (N); |
| end if; |
| end Apply_Arithmetic_Overflow_Check; |
| |
| -------------------------------------- |
| -- Apply_Arithmetic_Overflow_Strict -- |
| -------------------------------------- |
| |
| -- This routine is called only if the type is an integer type and an |
| -- arithmetic overflow check may be needed for op (add, subtract, or |
| -- multiply). This check is performed if Backend_Overflow_Checks_On_Target |
| -- is not enabled and Do_Overflow_Check is set. In this case we expand the |
| -- operation into a more complex sequence of tests that ensures that |
| -- overflow is properly caught. |
| |
| -- This is used in CHECKED modes. It is identical to the code for this |
| -- cases before the big overflow earthquake, thus ensuring that in this |
| -- modes we have compatible behavior (and reliability) to what was there |
| -- before. It is also called for types other than signed integers, and if |
| -- the Do_Overflow_Check flag is off. |
| |
| -- Note: we also call this routine if we decide in the MINIMIZED case |
| -- to give up and just generate an overflow check without any fuss. |
| |
| procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Typ : constant Entity_Id := Etype (N); |
| Rtyp : constant Entity_Id := Root_Type (Typ); |
| |
| begin |
| -- Nothing to do if Do_Overflow_Check not set or overflow checks |
| -- suppressed. |
| |
| if not Do_Overflow_Check (N) then |
| return; |
| end if; |
| |
| -- An interesting special case. If the arithmetic operation appears as |
| -- the operand of a type conversion: |
| |
| -- type1 (x op y) |
| |
| -- and all the following conditions apply: |
| |
| -- arithmetic operation is for a signed integer type |
| -- target type type1 is a static integer subtype |
| -- range of x and y are both included in the range of type1 |
| -- range of x op y is included in the range of type1 |
| -- size of type1 is at least twice the result size of op |
| |
| -- then we don't do an overflow check in any case. Instead, we transform |
| -- the operation so that we end up with: |
| |
| -- type1 (type1 (x) op type1 (y)) |
| |
| -- This avoids intermediate overflow before the conversion. It is |
| -- explicitly permitted by RM 3.5.4(24): |
| |
| -- For the execution of a predefined operation of a signed integer |
| -- type, the implementation need not raise Constraint_Error if the |
| -- result is outside the base range of the type, so long as the |
| -- correct result is produced. |
| |
| -- It's hard to imagine that any programmer counts on the exception |
| -- being raised in this case, and in any case it's wrong coding to |
| -- have this expectation, given the RM permission. Furthermore, other |
| -- Ada compilers do allow such out of range results. |
| |
| -- Note that we do this transformation even if overflow checking is |
| -- off, since this is precisely about giving the "right" result and |
| -- avoiding the need for an overflow check. |
| |
| -- Note: this circuit is partially redundant with respect to the similar |
| -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals |
| -- with cases that do not come through here. We still need the following |
| -- processing even with the Exp_Ch4 code in place, since we want to be |
| -- sure not to generate the arithmetic overflow check in these cases |
| -- (Exp_Ch4 would have a hard time removing them once generated). |
| |
| if Is_Signed_Integer_Type (Typ) |
| and then Nkind (Parent (N)) = N_Type_Conversion |
| then |
| Conversion_Optimization : declare |
| Target_Type : constant Entity_Id := |
| Base_Type (Entity (Subtype_Mark (Parent (N)))); |
| |
| Llo, Lhi : Uint; |
| Rlo, Rhi : Uint; |
| LOK, ROK : Boolean; |
| |
| Vlo : Uint; |
| Vhi : Uint; |
| VOK : Boolean; |
| |
| Tlo : Uint; |
| Thi : Uint; |
| |
| begin |
| if Is_Integer_Type (Target_Type) |
| and then RM_Size (Root_Type (Target_Type)) >= 2 * RM_Size (Rtyp) |
| then |
| Tlo := Expr_Value (Type_Low_Bound (Target_Type)); |
| Thi := Expr_Value (Type_High_Bound (Target_Type)); |
| |
| Determine_Range |
| (Left_Opnd (N), LOK, Llo, Lhi, Assume_Valid => True); |
| Determine_Range |
| (Right_Opnd (N), ROK, Rlo, Rhi, Assume_Valid => True); |
| |
| if (LOK and ROK) |
| and then Tlo <= Llo and then Lhi <= Thi |
| and then Tlo <= Rlo and then Rhi <= Thi |
| then |
| Determine_Range (N, VOK, Vlo, Vhi, Assume_Valid => True); |
| |
| if VOK and then Tlo <= Vlo and then Vhi <= Thi then |
| -- Rewrite the conversion operand so that the original |
| -- node is retained, in order to avoid the warning for |
| -- redundant conversions in Resolve_Type_Conversion. |
| |
| declare |
| Op : constant Node_Id := New_Op_Node (Nkind (N), Loc); |
| begin |
| Set_Left_Opnd (Op, |
| Make_Type_Conversion (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Target_Type, Loc), |
| Expression => Relocate_Node (Left_Opnd (N)))); |
| Set_Right_Opnd (Op, |
| Make_Type_Conversion (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Target_Type, Loc), |
| Expression => Relocate_Node (Right_Opnd (N)))); |
| |
| Rewrite (N, Op); |
| end; |
| |
| Set_Etype (N, Target_Type); |
| |
| Analyze_And_Resolve (Left_Opnd (N), Target_Type); |
| Analyze_And_Resolve (Right_Opnd (N), Target_Type); |
| |
| -- Given that the target type is twice the size of the |
| -- source type, overflow is now impossible, so we can |
| -- safely kill the overflow check and return. |
| |
| Set_Do_Overflow_Check (N, False); |
| return; |
| end if; |
| end if; |
| end if; |
| end Conversion_Optimization; |
| end if; |
| |
| -- Now see if an overflow check is required |
| |
| declare |
| Dsiz : constant Uint := 2 * Esize (Rtyp); |
| Opnod : Node_Id; |
| Ctyp : Entity_Id; |
| Opnd : Node_Id; |
| Cent : RE_Id; |
| |
| begin |
| -- Skip check if back end does overflow checks, or the overflow flag |
| -- is not set anyway, or we are not doing code expansion, or the |
| -- parent node is a type conversion whose operand is an arithmetic |
| -- operation on signed integers on which the expander can promote |
| -- later the operands to type Integer (see Expand_N_Type_Conversion). |
| |
| if Backend_Overflow_Checks_On_Target |
| or else not Do_Overflow_Check (N) |
| or else not Expander_Active |
| or else (Present (Parent (N)) |
| and then Nkind (Parent (N)) = N_Type_Conversion |
| and then Integer_Promotion_Possible (Parent (N))) |
| then |
| return; |
| end if; |
| |
| -- Otherwise, generate the full general code for front end overflow |
| -- detection, which works by doing arithmetic in a larger type: |
| |
| -- x op y |
| |
| -- is expanded into |
| |
| -- Typ (Checktyp (x) op Checktyp (y)); |
| |
| -- where Typ is the type of the original expression, and Checktyp is |
| -- an integer type of sufficient length to hold the largest possible |
| -- result. |
| |
| -- If the size of the check type exceeds the maximum integer size, |
| -- we use a different approach, expanding to: |
| |
| -- typ (xxx_With_Ovflo_Check (Integer_NN (x), Integer_NN (y))) |
| |
| -- where xxx is Add, Multiply or Subtract as appropriate |
| |
| -- Find check type if one exists |
| |
| if Dsiz <= System_Max_Integer_Size then |
| Ctyp := Integer_Type_For (Dsiz, Uns => False); |
| |
| -- No check type exists, use runtime call |
| |
| else |
| if System_Max_Integer_Size = 64 then |
| Ctyp := RTE (RE_Integer_64); |
| else |
| Ctyp := RTE (RE_Integer_128); |
| end if; |
| |
| if Nkind (N) = N_Op_Add then |
| if System_Max_Integer_Size = 64 then |
| Cent := RE_Add_With_Ovflo_Check64; |
| else |
| Cent := RE_Add_With_Ovflo_Check128; |
| end if; |
| |
| elsif Nkind (N) = N_Op_Subtract then |
| if System_Max_Integer_Size = 64 then |
| Cent := RE_Subtract_With_Ovflo_Check64; |
| else |
| Cent := RE_Subtract_With_Ovflo_Check128; |
| end if; |
| |
| else pragma Assert (Nkind (N) = N_Op_Multiply); |
| if System_Max_Integer_Size = 64 then |
| Cent := RE_Multiply_With_Ovflo_Check64; |
| else |
| Cent := RE_Multiply_With_Ovflo_Check128; |
| end if; |
| end if; |
| |
| Rewrite (N, |
| OK_Convert_To (Typ, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (Cent), Loc), |
| Parameter_Associations => New_List ( |
| OK_Convert_To (Ctyp, Left_Opnd (N)), |
| OK_Convert_To (Ctyp, Right_Opnd (N)))))); |
| |
| Analyze_And_Resolve (N, Typ); |
| return; |
| end if; |
| |
| -- If we fall through, we have the case where we do the arithmetic |
| -- in the next higher type and get the check by conversion. In these |
| -- cases Ctyp is set to the type to be used as the check type. |
| |
| Opnod := Relocate_Node (N); |
| |
| Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod)); |
| |
| Analyze (Opnd); |
| Set_Etype (Opnd, Ctyp); |
| Set_Analyzed (Opnd, True); |
| Set_Left_Opnd (Opnod, Opnd); |
| |
| Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod)); |
| |
| Analyze (Opnd); |
| Set_Etype (Opnd, Ctyp); |
| Set_Analyzed (Opnd, True); |
| Set_Right_Opnd (Opnod, Opnd); |
| |
| -- The type of the operation changes to the base type of the check |
| -- type, and we reset the overflow check indication, since clearly no |
| -- overflow is possible now that we are using a double length type. |
| -- We also set the Analyzed flag to avoid a recursive attempt to |
| -- expand the node. |
| |
| Set_Etype (Opnod, Base_Type (Ctyp)); |
| Set_Do_Overflow_Check (Opnod, False); |
| Set_Analyzed (Opnod, True); |
| |
| -- Now build the outer conversion |
| |
| Opnd := OK_Convert_To (Typ, Opnod); |
| Analyze (Opnd); |
| Set_Etype (Opnd, Typ); |
| |
| -- In the discrete type case, we directly generate the range check |
| -- for the outer operand. This range check will implement the |
| -- required overflow check. |
| |
| if Is_Discrete_Type (Typ) then |
| Rewrite (N, Opnd); |
| Generate_Range_Check |
| (Expression (N), Typ, CE_Overflow_Check_Failed); |
| |
| -- For other types, we enable overflow checking on the conversion, |
| -- after setting the node as analyzed to prevent recursive attempts |
| -- to expand the conversion node. |
| |
| else |
| Set_Analyzed (Opnd, True); |
| Enable_Overflow_Check (Opnd); |
| Rewrite (N, Opnd); |
| end if; |
| |
| exception |
| when RE_Not_Available => |
| return; |
| end; |
| end Apply_Arithmetic_Overflow_Strict; |
| |
| ---------------------------------------------------- |
| -- Apply_Arithmetic_Overflow_Minimized_Eliminated -- |
| ---------------------------------------------------- |
| |
| procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id) is |
| pragma Assert (Is_Signed_Integer_Arithmetic_Op (Op)); |
| |
| Loc : constant Source_Ptr := Sloc (Op); |
| P : constant Node_Id := Parent (Op); |
| |
| LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); |
| -- Operands and results are of this type when we convert |
| |
| Result_Type : constant Entity_Id := Etype (Op); |
| -- Original result type |
| |
| Check_Mode : constant Overflow_Mode_Type := Overflow_Check_Mode; |
| pragma Assert (Check_Mode in Minimized_Or_Eliminated); |
| |
| Lo, Hi : Uint; |
| -- Ranges of values for result |
| |
| begin |
| -- Nothing to do if our parent is one of the following: |
| |
| -- Another signed integer arithmetic op |
| -- A membership operation |
| -- A comparison operation |
| |
| -- In all these cases, we will process at the higher level (and then |
| -- this node will be processed during the downwards recursion that |
| -- is part of the processing in Minimize_Eliminate_Overflows). |
| |
| if Is_Signed_Integer_Arithmetic_Op (P) |
| or else Nkind (P) in N_Membership_Test |
| or else Nkind (P) in N_Op_Compare |
| |
| -- This is also true for an alternative in a case expression |
| |
| or else Nkind (P) = N_Case_Expression_Alternative |
| |
| -- This is also true for a range operand in a membership test |
| |
| or else (Nkind (P) = N_Range |
| and then Nkind (Parent (P)) in N_Membership_Test) |
| then |
| -- If_Expressions and Case_Expressions are treated as arithmetic |
| -- ops, but if they appear in an assignment or similar contexts |
| -- there is no overflow check that starts from that parent node, |
| -- so apply check now. |
| -- Similarly, if these expressions are nested, we should go on. |
| |
| if Nkind (P) in N_If_Expression | N_Case_Expression |
| and then not Is_Signed_Integer_Arithmetic_Op (Parent (P)) |
| then |
| null; |
| elsif Nkind (P) in N_If_Expression | N_Case_Expression |
| and then Nkind (Op) in N_If_Expression | N_Case_Expression |
| then |
| null; |
| else |
| return; |
| end if; |
| end if; |
| |
| -- Otherwise, we have a top level arithmetic operation node, and this |
| -- is where we commence the special processing for MINIMIZED/ELIMINATED |
| -- modes. This is the case where we tell the machinery not to move into |
| -- Bignum mode at this top level (of course the top level operation |
| -- will still be in Bignum mode if either of its operands are of type |
| -- Bignum). |
| |
| Minimize_Eliminate_Overflows (Op, Lo, Hi, Top_Level => True); |
| |
| -- That call may but does not necessarily change the result type of Op. |
| -- It is the job of this routine to undo such changes, so that at the |
| -- top level, we have the proper type. This "undoing" is a point at |
| -- which a final overflow check may be applied. |
| |
| -- If the result type was not fiddled we are all set. We go to base |
| -- types here because things may have been rewritten to generate the |
| -- base type of the operand types. |
| |
| if Base_Type (Etype (Op)) = Base_Type (Result_Type) then |
| return; |
| |
| -- Bignum case |
| |
| elsif Is_RTE (Etype (Op), RE_Bignum) then |
| |
| -- We need a sequence that looks like: |
| |
| -- Rnn : Result_Type; |
| |
| -- declare |
| -- M : Mark_Id := SS_Mark; |
| -- begin |
| -- Rnn := Long_Long_Integer'Base (From_Bignum (Op)); |
| -- SS_Release (M); |
| -- end; |
| |
| -- This block is inserted (using Insert_Actions), and then the node |
| -- is replaced with a reference to Rnn. |
| |
| -- If our parent is a conversion node then there is no point in |
| -- generating a conversion to Result_Type. Instead, we let the parent |
| -- handle this. Note that this special case is not just about |
| -- optimization. Consider |
| |
| -- A,B,C : Integer; |
| -- ... |
| -- X := Long_Long_Integer'Base (A * (B ** C)); |
| |
| -- Now the product may fit in Long_Long_Integer but not in Integer. |
| -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an |
| -- overflow exception for this intermediate value. |
| |
| declare |
| Blk : constant Node_Id := Make_Bignum_Block (Loc); |
| Rnn : constant Entity_Id := Make_Temporary (Loc, 'R', Op); |
| RHS : Node_Id; |
| |
| Rtype : Entity_Id; |
| |
| begin |
| RHS := Convert_From_Bignum (Op); |
| |
| if Nkind (P) /= N_Type_Conversion then |
| Convert_To_And_Rewrite (Result_Type, RHS); |
| Rtype := Result_Type; |
| |
| -- Interesting question, do we need a check on that conversion |
| -- operation. Answer, not if we know the result is in range. |
| -- At the moment we are not taking advantage of this. To be |
| -- looked at later ??? |
| |
| else |
| Rtype := LLIB; |
| end if; |
| |
| Insert_Before |
| (First (Statements (Handled_Statement_Sequence (Blk))), |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Rnn, Loc), |
| Expression => RHS)); |
| |
| Insert_Actions (Op, New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Rnn, |
| Object_Definition => New_Occurrence_Of (Rtype, Loc)), |
| Blk)); |
| |
| Rewrite (Op, New_Occurrence_Of (Rnn, Loc)); |
| Analyze_And_Resolve (Op); |
| end; |
| |
| -- Here we know the result is Long_Long_Integer'Base, or that it has |
| -- been rewritten because the parent operation is a conversion. See |
| -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization. |
| |
| else |
| pragma Assert |
| (Etype (Op) = LLIB or else Nkind (Parent (Op)) = N_Type_Conversion); |
| |
| -- All we need to do here is to convert the result to the proper |
| -- result type. As explained above for the Bignum case, we can |
| -- omit this if our parent is a type conversion. |
| |
| if Nkind (P) /= N_Type_Conversion then |
| Convert_To_And_Rewrite (Result_Type, Op); |
| end if; |
| |
| Analyze_And_Resolve (Op); |
| end if; |
| end Apply_Arithmetic_Overflow_Minimized_Eliminated; |
| |
| ---------------------------- |
| -- Apply_Constraint_Check -- |
| ---------------------------- |
| |
| procedure Apply_Constraint_Check |
| (N : Node_Id; |
| Typ : Entity_Id; |
| No_Sliding : Boolean := False) |
| is |
| Desig_Typ : Entity_Id; |
| |
| begin |
| -- No checks inside a generic (check the instantiations) |
| |
| if Inside_A_Generic then |
| return; |
| end if; |
| |
| -- Apply required constraint checks |
| |
| if Is_Scalar_Type (Typ) then |
| Apply_Scalar_Range_Check (N, Typ); |
| |
| elsif Is_Array_Type (Typ) then |
| |
| -- A useful optimization: an aggregate with only an others clause |
| -- always has the right bounds. |
| |
| if Nkind (N) = N_Aggregate |
| and then No (Expressions (N)) |
| and then Nkind (First (Component_Associations (N))) = |
| N_Component_Association |
| and then Nkind |
| (First (Choices (First (Component_Associations (N))))) |
| = N_Others_Choice |
| then |
| return; |
| end if; |
| |
| if Is_Constrained (Typ) then |
| Apply_Length_Check (N, Typ); |
| |
| if No_Sliding then |
| Apply_Range_Check (N, Typ); |
| end if; |
| else |
| Apply_Range_Check (N, Typ); |
| end if; |
| |
| elsif (Is_Record_Type (Typ) or else Is_Private_Type (Typ)) |
| and then Has_Discriminants (Base_Type (Typ)) |
| and then Is_Constrained (Typ) |
| then |
| Apply_Discriminant_Check (N, Typ); |
| |
| elsif Is_Access_Type (Typ) then |
| |
| Desig_Typ := Designated_Type (Typ); |
| |
| -- No checks necessary if expression statically null |
| |
| if Known_Null (N) then |
| if Can_Never_Be_Null (Typ) then |
| Install_Null_Excluding_Check (N); |
| end if; |
| |
| -- No sliding possible on access to arrays |
| |
| elsif Is_Array_Type (Desig_Typ) then |
| if Is_Constrained (Desig_Typ) then |
| Apply_Length_Check (N, Typ); |
| end if; |
| |
| Apply_Range_Check (N, Typ); |
| |
| -- Do not install a discriminant check for a constrained subtype |
| -- created for an unconstrained nominal type because the subtype |
| -- has the correct constraints by construction. |
| |
| elsif Has_Discriminants (Base_Type (Desig_Typ)) |
| and then Is_Constrained (Desig_Typ) |
| and then not Is_Constr_Subt_For_U_Nominal (Desig_Typ) |
| then |
| Apply_Discriminant_Check (N, Typ); |
| end if; |
| |
| -- Apply the 2005 Null_Excluding check. Note that we do not apply |
| -- this check if the constraint node is illegal, as shown by having |
| -- an error posted. This additional guard prevents cascaded errors |
| -- and compiler aborts on illegal programs involving Ada 2005 checks. |
| |
| if Can_Never_Be_Null (Typ) |
| and then not Can_Never_Be_Null (Etype (N)) |
| and then not Error_Posted (N) |
| then |
| Install_Null_Excluding_Check (N); |
| end if; |
| end if; |
| end Apply_Constraint_Check; |
| |
| ------------------------------ |
| -- Apply_Discriminant_Check -- |
| ------------------------------ |
| |
| procedure Apply_Discriminant_Check |
| (N : Node_Id; |
| Typ : Entity_Id; |
| Lhs : Node_Id := Empty) |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Do_Access : constant Boolean := Is_Access_Type (Typ); |
| S_Typ : Entity_Id := Etype (N); |
| Cond : Node_Id; |
| T_Typ : Entity_Id; |
| |
| function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean; |
| -- A heap object with an indefinite subtype is constrained by its |
| -- initial value, and assigning to it requires a constraint_check. |
| -- The target may be an explicit dereference, or a renaming of one. |
| |
| function Is_Aliased_Unconstrained_Component return Boolean; |
| -- It is possible for an aliased component to have a nominal |
| -- unconstrained subtype (through instantiation). If this is a |
| -- discriminated component assigned in the expansion of an aggregate |
| -- in an initialization, the check must be suppressed. This unusual |
| -- situation requires a predicate of its own. |
| |
| ---------------------------------- |
| -- Denotes_Explicit_Dereference -- |
| ---------------------------------- |
| |
| function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean is |
| begin |
| return |
| Nkind (Obj) = N_Explicit_Dereference |
| or else |
| (Is_Entity_Name (Obj) |
| and then Present (Renamed_Object (Entity (Obj))) |
| and then Nkind (Renamed_Object (Entity (Obj))) = |
| N_Explicit_Dereference); |
| end Denotes_Explicit_Dereference; |
| |
| ---------------------------------------- |
| -- Is_Aliased_Unconstrained_Component -- |
| ---------------------------------------- |
| |
| function Is_Aliased_Unconstrained_Component return Boolean is |
| Comp : Entity_Id; |
| Pref : Node_Id; |
| |
| begin |
| if Nkind (Lhs) /= N_Selected_Component then |
| return False; |
| else |
| Comp := Entity (Selector_Name (Lhs)); |
| Pref := Prefix (Lhs); |
| end if; |
| |
| if Ekind (Comp) /= E_Component |
| or else not Is_Aliased (Comp) |
| then |
| return False; |
| end if; |
| |
| return not Comes_From_Source (Pref) |
| and then In_Instance |
| and then not Is_Constrained (Etype (Comp)); |
| end Is_Aliased_Unconstrained_Component; |
| |
| -- Start of processing for Apply_Discriminant_Check |
| |
| begin |
| if Do_Access then |
| T_Typ := Designated_Type (Typ); |
| else |
| T_Typ := Typ; |
| end if; |
| |
| -- If the expression is a function call that returns a limited object |
| -- it cannot be copied. It is not clear how to perform the proper |
| -- discriminant check in this case because the discriminant value must |
| -- be retrieved from the constructed object itself. |
| |
| if Nkind (N) = N_Function_Call |
| and then Is_Limited_Type (Typ) |
| and then Is_Entity_Name (Name (N)) |
| and then Returns_By_Ref (Entity (Name (N))) |
| then |
| return; |
| end if; |
| |
| -- Only apply checks when generating code and discriminant checks are |
| -- not suppressed. In GNATprove mode, we do not apply the checks, but we |
| -- still analyze the expression 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 else Discriminant_Checks_Suppressed (T_Typ) |
| then |
| return; |
| end if; |
| end if; |
| |
| -- No discriminant checks necessary for an access when expression is |
| -- statically Null. This is not only an optimization, it is fundamental |
| -- because otherwise discriminant checks may be generated in init procs |
| -- for types containing an access to a not-yet-frozen record, causing a |
| -- deadly forward reference. |
| |
| -- Also, if the expression is of an access type whose designated type is |
| -- incomplete, then the access value must be null and we suppress the |
| -- check. |
| |
| if Known_Null (N) then |
| return; |
| |
| elsif Is_Access_Type (S_Typ) then |
| S_Typ := Designated_Type (S_Typ); |
| |
| if Ekind (S_Typ) = E_Incomplete_Type then |
| return; |
| end if; |
| end if; |
| |
| -- If an assignment target is present, then we need to generate the |
| -- actual subtype if the target is a parameter or aliased object with |
| -- an unconstrained nominal subtype. |
| |
| -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual |
| -- subtype to the parameter and dereference cases, since other aliased |
| -- objects are unconstrained (unless the nominal subtype is explicitly |
| -- constrained). |
| |
| if Present (Lhs) |
| and then (Present (Param_Entity (Lhs)) |
| or else (Ada_Version < Ada_2005 |
| and then not Is_Constrained (T_Typ) |
| and then Is_Aliased_View (Lhs) |
| and then not Is_Aliased_Unconstrained_Component) |
| or else (Ada_Version >= Ada_2005 |
| and then not Is_Constrained (T_Typ) |
| and then Denotes_Explicit_Dereference (Lhs) |
| and then Nkind (Original_Node (Lhs)) /= |
| N_Function_Call)) |
| then |
| T_Typ := Get_Actual_Subtype (Lhs); |
| end if; |
| |
| -- Nothing to do if the type is unconstrained (this is the case where |
| -- the actual subtype in the RM sense of N is unconstrained and no check |
| -- is required). |
| |
| if not Is_Constrained (T_Typ) then |
| return; |
| |
| -- Ada 2005: nothing to do if the type is one for which there is a |
| -- partial view that is constrained. |
| |
| elsif Ada_Version >= Ada_2005 |
| and then Object_Type_Has_Constrained_Partial_View |
| (Typ => Base_Type (T_Typ), |
| Scop => Current_Scope) |
| then |
| return; |
| end if; |
| |
| -- Nothing to do if the type is an Unchecked_Union |
| |
| if Is_Unchecked_Union (Base_Type (T_Typ)) then |
| return; |
| end if; |
| |
| -- Suppress checks if the subtypes are the same. The check must be |
| -- preserved in an assignment to a formal, because the constraint is |
| -- given by the actual. |
| |
| if Nkind (Original_Node (N)) /= N_Allocator |
| and then (No (Lhs) |
| or else not Is_Entity_Name (Lhs) |
| or else No (Param_Entity (Lhs))) |
| then |
| if (Etype (N) = Typ |
| or else (Do_Access and then Designated_Type (Typ) = S_Typ)) |
| and then not Is_Aliased_View (Lhs) |
| then |
| return; |
| end if; |
| |
| -- We can also eliminate checks on allocators with a subtype mark that |
| -- coincides with the context type. The context type may be a subtype |
| -- without a constraint (common case, a generic actual). |
| |
| elsif Nkind (Original_Node (N)) = N_Allocator |
| and then Is_Entity_Name (Expression (Original_Node (N))) |
| then |
| declare |
| Alloc_Typ : constant Entity_Id := |
| Entity (Expression (Original_Node (N))); |
| |
| begin |
| if Alloc_Typ = T_Typ |
| or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration |
| and then Is_Entity_Name ( |
| Subtype_Indication (Parent (T_Typ))) |
| and then Alloc_Typ = Base_Type (T_Typ)) |
| |
| then |
| return; |
| end if; |
| end; |
| end if; |
| |
| -- See if we have a case where the types are both constrained, and all |
| -- the constraints are constants. In this case, we can do the check |
| -- successfully at compile time. |
| |
| -- We skip this check for the case where the node is rewritten as |
| -- an allocator, because it already carries the context subtype, |
| -- and extracting the discriminants from the aggregate is messy. |
| |
| if Is_Constrained (S_Typ) |
| and then Nkind (Original_Node (N)) /= N_Allocator |
| then |
| declare |
| DconT : Elmt_Id; |
| Discr : Entity_Id; |
| DconS : Elmt_Id; |
| ItemS : Node_Id; |
| ItemT : Node_Id; |
| |
| begin |
| -- S_Typ may not have discriminants in the case where it is a |
| -- private type completed by a default discriminated type. In that |
| -- case, we need to get the constraints from the underlying type. |
| -- If the underlying type is unconstrained (i.e. has no default |
| -- discriminants) no check is needed. |
| |
| if Has_Discriminants (S_Typ) then |
| Discr := First_Discriminant (S_Typ); |
| DconS := First_Elmt (Discriminant_Constraint (S_Typ)); |
| |
| else |
| Discr := First_Discriminant (Underlying_Type (S_Typ)); |
| DconS := |
| First_Elmt |
| (Discriminant_Constraint (Underlying_Type (S_Typ))); |
| |
| if No (DconS) then |
| return; |
| end if; |
| |
| -- A further optimization: if T_Typ is derived from S_Typ |
| -- without imposing a constraint, no check is needed. |
| |
| if Nkind (Original_Node (Parent (T_Typ))) = |
| N_Full_Type_Declaration |
| then |
| declare |
| Type_Def : constant Node_Id := |
| Type_Definition (Original_Node (Parent (T_Typ))); |
| begin |
| if Nkind (Type_Def) = N_Derived_Type_Definition |
| and then Is_Entity_Name (Subtype_Indication (Type_Def)) |
| and then Entity (Subtype_Indication (Type_Def)) = S_Typ |
| then |
| return; |
| end if; |
| end; |
| end if; |
| end if; |
| |
| -- Constraint may appear in full view of type |
| |
| if Ekind (T_Typ) = E_Private_Subtype |
| and then Present (Full_View (T_Typ)) |
| then |
| DconT := |
| First_Elmt (Discriminant_Constraint (Full_View (T_Typ))); |
| else |
| DconT := |
| First_Elmt (Discriminant_Constraint (T_Typ)); |
| end if; |
| |
| while Present (Discr) loop |
| ItemS := Node (DconS); |
| ItemT := Node (DconT); |
| |
| -- For a discriminated component type constrained by the |
| -- current instance of an enclosing type, there is no |
| -- applicable discriminant check. |
| |
| if Nkind (ItemT) = N_Attribute_Reference |
| and then Is_Access_Type (Etype (ItemT)) |
| and then Is_Entity_Name (Prefix (ItemT)) |
| and then Is_Type (Entity (Prefix (ItemT))) |
| then |
| return; |
| end if; |
| |
| -- 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; |
| |
| elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then |
| if Do_Access then -- needs run-time check. |
| exit; |
| else |
| Apply_Compile_Time_Constraint_Error |
| (N, "incorrect value for discriminant&??", |
| CE_Discriminant_Check_Failed, Ent => Discr); |
| return; |
| end if; |
| end if; |
| |
| Next_Elmt (DconS); |
| Next_Elmt (DconT); |
| Next_Discriminant (Discr); |
| end loop; |
| |
| if No (Discr) then |
| return; |
| end if; |
| end; |
| end if; |
| |
| -- In GNATprove mode, we do not apply the checks |
| |
| if GNATprove_Mode then |
| return; |
| end if; |
| |
| -- Here we need a discriminant check. First build the expression |
| -- for the comparisons of the discriminants: |
| |
| -- (n.disc1 /= typ.disc1) or else |
| -- (n.disc2 /= typ.disc2) or else |
| -- ... |
| -- (n.discn /= typ.discn) |
| |
| Cond := Build_Discriminant_Checks (N, T_Typ); |
| |
| -- If Lhs is set and is a parameter, then the condition is guarded by: |
| -- lhs'constrained and then (condition built above) |
| |
| if Present (Param_Entity (Lhs)) then |
| Cond := |
| Make_And_Then (Loc, |
| Left_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc), |
| Attribute_Name => Name_Constrained), |
| Right_Opnd => Cond); |
| end if; |
| |
| if Do_Access then |
| Cond := Guard_Access (Cond, Loc, N); |
| end if; |
| |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => Cond, |
| Reason => CE_Discriminant_Check_Failed)); |
| end Apply_Discriminant_Check; |
| |
| ------------------------- |
| -- Apply_Divide_Checks -- |
| ------------------------- |
| |
| procedure Apply_Divide_Checks (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Typ : constant Entity_Id := Etype (N); |
| Left : constant Node_Id := Left_Opnd (N); |
| Right : constant Node_Id := Right_Opnd (N); |
| |
| Mode : constant Overflow_Mode_Type := Overflow_Check_Mode; |
| -- Current overflow checking mode |
| |
| LLB : Uint; |
| Llo : Uint; |
| Lhi : Uint; |
| LOK : Boolean; |
| Rlo : Uint; |
| Rhi : Uint; |
| ROK : Boolean; |
| |
| pragma Warnings (Off, Lhi); |
| -- Don't actually use this value |
| |
| begin |
| -- If we are operating in MINIMIZED or ELIMINATED mode, and we are |
| -- operating on signed integer types, then the only thing this routine |
| -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That |
| -- procedure will (possibly later on during recursive downward calls), |
| -- ensure that any needed overflow/division checks are properly applied. |
| |
| if Mode in Minimized_Or_Eliminated |
| and then Is_Signed_Integer_Type (Typ) |
| then |
| Apply_Arithmetic_Overflow_Minimized_Eliminated (N); |
| return; |
| end if; |
| |
| -- Proceed here in SUPPRESSED or CHECKED modes |
| |
| if Expander_Active |
| and then not Backend_Divide_Checks_On_Target |
| and then Check_Needed (Right, Division_Check) |
| then |
| Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True); |
| |
| -- Deal with division check |
| |
| if Do_Division_Check (N) |
| and then not Division_Checks_Suppressed (Typ) |
| then |
| Apply_Division_Check (N, Rlo, Rhi, ROK); |
| end if; |
| |
| -- Deal with overflow check |
| |
| if Do_Overflow_Check (N) |
| and then not Overflow_Checks_Suppressed (Etype (N)) |
| then |
| Set_Do_Overflow_Check (N, False); |
| |
| -- Test for extremely annoying case of xxx'First divided by -1 |
| -- for division of signed integer types (only overflow case). |
| |
| if Nkind (N) = N_Op_Divide |
| and then Is_Signed_Integer_Type (Typ) |
| then |
| Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True); |
| LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); |
| |
| if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) |
| and then |
| ((not LOK) or else (Llo = LLB)) |
| then |
| -- Ensure that expressions are not evaluated twice (once |
| -- for their runtime checks and once for their regular |
| -- computation). |
| |
| Force_Evaluation (Left, Mode => Strict); |
| Force_Evaluation (Right, Mode => Strict); |
| |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_And_Then (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| Duplicate_Subexpr_Move_Checks (Left), |
| Right_Opnd => Make_Integer_Literal (Loc, LLB)), |
| |
| Right_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => Duplicate_Subexpr (Right), |
| Right_Opnd => Make_Integer_Literal (Loc, -1))), |
| |
| Reason => CE_Overflow_Check_Failed)); |
| end if; |
| end if; |
| end if; |
| end if; |
| end Apply_Divide_Checks; |
| |
| -------------------------- |
| -- Apply_Division_Check -- |
| -------------------------- |
| |
| procedure Apply_Division_Check |
| (N : Node_Id; |
| Rlo : Uint; |
| Rhi : Uint; |
| ROK : Boolean) |
| is |
| pragma Assert (Do_Division_Check (N)); |
| |
| Loc : constant Source_Ptr := Sloc (N); |
| Right : constant Node_Id := Right_Opnd (N); |
| Opnd : Node_Id; |
| |
| begin |
| if Expander_Active |
| and then not Backend_Divide_Checks_On_Target |
| and then Check_Needed (Right, Division_Check) |
| |
| -- See if division by zero possible, and if so generate test. This |
| -- part of the test is not controlled by the -gnato switch, since it |
| -- is a Division_Check and not an Overflow_Check. |
| |
| and then Do_Division_Check (N) |
| then |
| Set_Do_Division_Check (N, False); |
| |
| if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then |
| if Is_Floating_Point_Type (Etype (N)) then |
| Opnd := Make_Real_Literal (Loc, Ureal_0); |
| else |
| Opnd := Make_Integer_Literal (Loc, 0); |
| end if; |
| |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => Duplicate_Subexpr_Move_Checks (Right), |
| Right_Opnd => Opnd), |
| Reason => CE_Divide_By_Zero)); |
| end if; |
| end if; |
| end Apply_Division_Check; |
| |
| ---------------------------------- |
| -- Apply_Float_Conversion_Check -- |
| ---------------------------------- |
| |
| -- Let F and I be the source and target types of the conversion. The RM |
| -- specifies that a floating-point value X is rounded to the nearest |
| -- integer, with halfway cases being rounded away from zero. The rounded |
| -- value of X is checked against I'Range. |
| |
| -- The catch in the above paragraph is that there is no good way to know |
| -- whether the round-to-integer operation resulted in overflow. A remedy is |
| -- to perform a range check in the floating-point domain instead, however: |
| |
| -- (1) The bounds may not be known at compile time |
| -- (2) The check must take into account rounding or truncation. |
| -- (3) The range of type I may not be exactly representable in F. |
| -- (4) For the rounding case, the end-points I'First - 0.5 and |
| -- I'Last + 0.5 may or may not be in range, depending on the |
| -- sign of I'First and I'Last. |
| -- (5) X may be a NaN, which will fail any comparison |
| |
| -- The following steps correctly convert X with rounding: |
| |
| -- (1) If either I'First or I'Last is not known at compile time, use |
| -- I'Base instead of I in the next three steps and perform a |
| -- regular range check against I'Range after conversion. |
| -- (2) If I'First - 0.5 is representable in F then let Lo be that |
| -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be |
| -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First). |
| -- In other words, take one of the closest floating-point numbers |
| -- (which is an integer value) to I'First, and see if it is in |
| -- range or not. |
| -- (3) If I'Last + 0.5 is representable in F then let Hi be that value |
| -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be |
| -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last). |
| -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo) |
| -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi) |
| |
| -- For the truncating case, replace steps (2) and (3) as follows: |
| -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK |
| -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let |
| -- Lo_OK be True. |
| -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK |
| -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let |
| -- Hi_OK be True. |
| |
| procedure Apply_Float_Conversion_Check |
| (Expr : Node_Id; |
| Target_Typ : Entity_Id) |
| is |
| LB : constant Node_Id := Type_Low_Bound (Target_Typ); |
| HB : constant Node_Id := Type_High_Bound (Target_Typ); |
| Loc : constant Source_Ptr := Sloc (Expr); |
| Expr_Type : constant Entity_Id := Base_Type (Etype (Expr)); |
| Target_Base : constant Entity_Id := |
| Implementation_Base_Type (Target_Typ); |
| |
| Par : constant Node_Id := Parent (Expr); |
| pragma Assert (Nkind (Par) = N_Type_Conversion); |
| -- Parent of check node, must be a type conversion |
| |
| Truncate : constant Boolean := Float_Truncate (Par); |
| Max_Bound : constant Uint := |
| UI_Expon |
| (Machine_Radix_Value (Expr_Type), |
| Machine_Mantissa_Value (Expr_Type) - 1) - 1; |
| |
| -- Largest bound, so bound plus or minus half is a machine number of F |
| |
| Ifirst, Ilast : Uint; |
| -- Bounds of integer type |
| |
| Lo, Hi : Ureal; |
| -- Bounds to check in floating-point domain |
| |
| Lo_OK, Hi_OK : Boolean; |
| -- True iff Lo resp. Hi belongs to I'Range |
| |
| Lo_Chk, Hi_Chk : Node_Id; |
| -- Expressions that are False iff check fails |
| |
| Reason : RT_Exception_Code; |
| |
| begin |
| -- We do not need checks if we are not generating code (i.e. the full |
| -- expander is not active). In SPARK mode, we specifically don't want |
| -- the frontend to expand these checks, which are dealt with directly |
| -- in the formal verification backend. |
| |
| if not Expander_Active then |
| return; |
| end if; |
| |
| -- Here we will generate an explicit range check, so we don't want to |
| -- set the Do_Range check flag, since the range check is taken care of |
| -- by the code we will generate. |
| |
| Set_Do_Range_Check (Expr, False); |
| |
| if not Compile_Time_Known_Value (LB) |
| or not Compile_Time_Known_Value (HB) |
| then |
| declare |
| -- First check that the value falls in the range of the base type, |
| -- to prevent overflow during conversion and then perform a |
| -- regular range check against the (dynamic) bounds. |
| |
| pragma Assert (Target_Base /= Target_Typ); |
| |
| Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Par); |
| |
| begin |
| Apply_Float_Conversion_Check (Expr, Target_Base); |
| Set_Etype (Temp, Target_Base); |
| |
| -- Note: Previously the declaration was inserted above the parent |
| -- of the conversion, apparently as a small optimization for the |
| -- subequent traversal in Insert_Actions. Unfortunately a similar |
| -- optimization takes place in Insert_Actions, assuming that the |
| -- insertion point must be above the expression that creates |
| -- actions. This is not correct in the presence of conditional |
| -- expressions, where the insertion must be in the list of actions |
| -- attached to the current alternative. |
| |
| Insert_Action (Par, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Temp, |
| Object_Definition => New_Occurrence_Of (Target_Typ, Loc), |
| Expression => New_Copy_Tree (Par)), |
| Suppress => All_Checks); |
| |
| Insert_Action (Par, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Not_In (Loc, |
| Left_Opnd => New_Occurrence_Of (Temp, Loc), |
| Right_Opnd => New_Occurrence_Of (Target_Typ, Loc)), |
| Reason => CE_Range_Check_Failed)); |
| Rewrite (Par, New_Occurrence_Of (Temp, Loc)); |
| |
| return; |
| end; |
| end if; |
| |
| -- Get the (static) bounds of the target type |
| |
| Ifirst := Expr_Value (LB); |
| Ilast := Expr_Value (HB); |
| |
| -- A simple optimization: if the expression is a universal literal, |
| -- we can do the comparison with the bounds and the conversion to |
| -- an integer type statically. The range checks are unchanged. |
| |
| if Nkind (Expr) = N_Real_Literal |
| and then Etype (Expr) = Universal_Real |
| and then Is_Integer_Type (Target_Typ) |
| then |
| declare |
| Int_Val : constant Uint := UR_To_Uint (Realval (Expr)); |
| |
| begin |
| if Int_Val <= Ilast and then Int_Val >= Ifirst then |
| |
| -- Conversion is safe |
| |
| Rewrite (Parent (Expr), |
| Make_Integer_Literal (Loc, UI_To_Int (Int_Val))); |
| Analyze_And_Resolve (Parent (Expr), Target_Typ); |
| return; |
| end if; |
| end; |
| end if; |
| |
| -- Check against lower bound |
| |
| if Truncate and then Ifirst > 0 then |
| Lo := Pred (Expr_Type, UR_From_Uint (Ifirst)); |
| Lo_OK := False; |
| |
| elsif Truncate then |
| Lo := Succ (Expr_Type, UR_From_Uint (Ifirst - 1)); |
| Lo_OK := True; |
| |
| elsif abs (Ifirst) < Max_Bound then |
| Lo := UR_From_Uint (Ifirst) - Ureal_Half; |
| Lo_OK := (Ifirst > 0); |
| |
| else |
| Lo := Machine_Number (Expr_Type, UR_From_Uint (Ifirst), Expr); |
| Lo_OK := (Lo >= UR_From_Uint (Ifirst)); |
| end if; |
| |
| -- Saturate the lower bound to that of the expression's type, because |
| -- we do not want to create an out-of-range value but we still need to |
| -- do a comparison to catch NaNs. |
| |
| if Lo < Expr_Value_R (Type_Low_Bound (Expr_Type)) then |
| Lo := Expr_Value_R (Type_Low_Bound (Expr_Type)); |
| Lo_OK := True; |
| end if; |
| |
| if Lo_OK then |
| |
| -- Lo_Chk := (X >= Lo) |
| |
| Lo_Chk := Make_Op_Ge (Loc, |
| Left_Opnd => Duplicate_Subexpr_No_Checks (Expr), |
| Right_Opnd => Make_Real_Literal (Loc, Lo)); |
| |
| else |
| -- Lo_Chk := (X > Lo) |
| |
| Lo_Chk := Make_Op_Gt (Loc, |
| Left_Opnd => Duplicate_Subexpr_No_Checks (Expr), |
| Right_Opnd => Make_Real_Literal (Loc, Lo)); |
| end if; |
| |
| -- Check against higher bound |
| |
| if Truncate and then Ilast < 0 then |
| Hi := Succ (Expr_Type, UR_From_Uint (Ilast)); |
| Hi_OK := False; |
| |
| elsif Truncate then |
| Hi := Pred (Expr_Type, UR_From_Uint (Ilast + 1)); |
| Hi_OK := True; |
| |
| elsif abs (Ilast) < Max_Bound then |
| Hi := UR_From_Uint (Ilast) + Ureal_Half; |
| Hi_OK := (Ilast < 0); |
| else |
| Hi := Machine_Number (Expr_Type, UR_From_Uint (Ilast), Expr); |
| Hi_OK := (Hi <= UR_From_Uint (Ilast)); |
| end if; |
| |
| -- Saturate the higher bound to that of the expression's type, because |
| -- we do not want to create an out-of-range value but we still need to |
| -- do a comparison to catch NaNs. |
| |
| if Hi > Expr_Value_R (Type_High_Bound (Expr_Type)) then |
| Hi := Expr_Value_R (Type_High_Bound (Expr_Type)); |
| Hi_OK := True; |
| end if; |
| |
| if Hi_OK then |
| |
| -- Hi_Chk := (X <= Hi) |
| |
| Hi_Chk := Make_Op_Le (Loc, |
| Left_Opnd => Duplicate_Subexpr_No_Checks (Expr), |
| Right_Opnd => Make_Real_Literal (Loc, Hi)); |
| |
| else |
| -- Hi_Chk := (X < Hi) |
| |
| Hi_Chk := Make_Op_Lt (Loc, |
| Left_Opnd => Duplicate_Subexpr_No_Checks (Expr), |
| Right_Opnd => Make_Real_Literal (Loc, Hi)); |
| end if; |
| |
| -- If the bounds of the target type are the same as those of the base |
| -- type, the check is an overflow check as a range check is not |
| -- performed in these cases. |
| |
| if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst |
| and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast |
| then |
| Reason := CE_Overflow_Check_Failed; |
| else |
| Reason := CE_Range_Check_Failed; |
| end if; |
| |
| -- Raise CE if either conditions does not hold |
| |
| Insert_Action (Expr, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => Make_Op_Not (Loc, Make_And_Then (Loc, Lo_Chk, Hi_Chk)), |
| Reason => Reason)); |
| end Apply_Float_Conversion_Check; |
| |
| ------------------------ |
| -- Apply_Length_Check -- |
| ------------------------ |
| |
| procedure Apply_Length_Check |
| (Expr : Node_Id; |
| Target_Typ : Entity_Id; |
| Source_Typ : Entity_Id := Empty) |
| is |
| begin |
| Apply_Selected_Length_Checks |
| (Expr, Target_Typ, Source_Typ, Do_Static => False); |
| end Apply_Length_Check; |
| |
| -------------------------------------- |
| -- Apply_Length_Check_On_Assignment -- |
| -------------------------------------- |
| |
| procedure Apply_Length_Check_On_Assignment |
| (Expr : Node_Id; |
| Target_Typ : Entity_Id; |
| Target : Node_Id; |
| Source_Typ : Entity_Id := Empty) |
| is |
| Assign : constant Node_Id := Parent (Target); |
| |
| begin |
| -- Do not apply length checks if parent is still an assignment statement |
| -- with Suppress_Assignment_Checks flag set. |
| |
| if Nkind (Assign) = N_Assignment_Statement |
| and then Suppress_Assignment_Checks (Assign) |
| then |
| return; |
| end if; |
| |
| -- No check is needed for the initialization of an object whose |
| -- nominal subtype is unconstrained. |
| |
| if Is_Constr_Subt_For_U_Nominal (Target_Typ) |
| and then Nkind (Parent (Assign)) = N_Freeze_Entity |
| and then Is_Entity_Name (Target) |
| and then Entity (Target) = Entity (Parent (Assign)) |
| then |
| return; |
| end if; |
| |
| Apply_Selected_Length_Checks |
| (Expr, Target_Typ, Source_Typ, Do_Static => False); |
| end Apply_Length_Check_On_Assignment; |
| |
| ------------------------------------- |
| -- Apply_Parameter_Aliasing_Checks -- |
| ------------------------------------- |
| |
| procedure Apply_Parameter_Aliasing_Checks |
| (Call : Node_Id; |
| Subp : Entity_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Call); |
| |
| function Parameter_Passing_Mechanism_Specified |
| (Typ : Entity_Id) |
| return Boolean; |
| -- Returns True if parameter-passing mechanism is specified for type Typ |
| |
| function May_Cause_Aliasing |
| (Formal_1 : Entity_Id; |
| Formal_2 : Entity_Id) return Boolean; |
| -- Determine whether two formal parameters can alias each other |
| -- depending on their modes. |
| |
| function Original_Actual (N : Node_Id) return Node_Id; |
| -- The expander may replace an actual with a temporary for the sake of |
| -- side effect removal. The temporary may hide a potential aliasing as |
| -- it does not share the address of the actual. This routine attempts |
| -- to retrieve the original actual. |
| |
| procedure Overlap_Check |
| (Actual_1 : Node_Id; |
| Actual_2 : Node_Id; |
| Formal_1 : Entity_Id; |
| Formal_2 : Entity_Id; |
| Check : in out Node_Id); |
| -- Create a check to determine whether Actual_1 overlaps with Actual_2. |
| -- If detailed exception messages are enabled, the check is augmented to |
| -- provide information about the names of the corresponding formals. See |
| -- the body for details. Actual_1 and Actual_2 denote the two actuals to |
| -- be tested. Formal_1 and Formal_2 denote the corresponding formals. |
| -- Check contains all and-ed simple tests generated so far or remains |
| -- unchanged in the case of detailed exception messaged. |
| |
| ------------------------------------------- |
| -- Parameter_Passing_Mechanism_Specified -- |
| ------------------------------------------- |
| |
| function Parameter_Passing_Mechanism_Specified |
| (Typ : Entity_Id) |
| return Boolean |
| is |
| begin |
| return Is_Elementary_Type (Typ) |
| or else Is_By_Reference_Type (Typ); |
| end Parameter_Passing_Mechanism_Specified; |
| |
| ------------------------ |
| -- May_Cause_Aliasing -- |
| ------------------------ |
| |
| function May_Cause_Aliasing |
| (Formal_1 : Entity_Id; |
| Formal_2 : Entity_Id) return Boolean |
| is |
| begin |
| -- The following combination cannot lead to aliasing |
| |
| -- Formal 1 Formal 2 |
| -- IN IN |
| |
| if Ekind (Formal_1) = E_In_Parameter |
| and then |
| Ekind (Formal_2) = E_In_Parameter |
| then |
| return False; |
| |
| -- The following combinations may lead to aliasing |
| |
| -- Formal 1 Formal 2 |
| -- IN OUT |
| -- IN IN OUT |
| -- OUT IN |
| -- OUT IN OUT |
| -- OUT OUT |
| |
| else |
| return True; |
| end if; |
| end May_Cause_Aliasing; |
| |
| --------------------- |
| -- Original_Actual -- |
| --------------------- |
| |
| function Original_Actual (N : Node_Id) return Node_Id is |
| begin |
| if Nkind (N) = N_Type_Conversion then |
| return Expression (N); |
| |
| -- The expander created a temporary to capture the result of a type |
| -- conversion where the expression is the real actual. |
| |
| elsif Nkind (N) = N_Identifier |
| and then Present (Original_Node (N)) |
| and then Nkind (Original_Node (N)) = N_Type_Conversion |
| then |
| return Expression (Original_Node (N)); |
| end if; |
| |
| return N; |
| end Original_Actual; |
| |
| ------------------- |
| -- Overlap_Check -- |
| ------------------- |
| |
| procedure Overlap_Check |
| (Actual_1 : Node_Id; |
| Actual_2 : Node_Id; |
| Formal_1 : Entity_Id; |
| Formal_2 : Entity_Id; |
| Check : in out Node_Id) |
| is |
| Cond : Node_Id; |
| Formal_Name : Bounded_String; |
| |
| begin |
| -- Generate: |
| -- Actual_1'Overlaps_Storage (Actual_2) |
| |
| Cond := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Copy_Tree (Original_Actual (Actual_1)), |
| Attribute_Name => Name_Overlaps_Storage, |
| Expressions => |
| New_List (New_Copy_Tree (Original_Actual (Actual_2)))); |
| |
| -- Generate the following check when detailed exception messages are |
| -- enabled: |
| |
| -- if Actual_1'Overlaps_Storage (Actual_2) then |
| -- raise Program_Error with <detailed message>; |
| -- end if; |
| |
| if Exception_Extra_Info then |
| Start_String; |
| |
| -- Do not generate location information for internal calls |
| |
| if Comes_From_Source (Call) then |
| Store_String_Chars (Build_Location_String (Loc)); |
| Store_String_Char (' '); |
| end if; |
| |
| Store_String_Chars ("aliased parameters, actuals for """); |
| |
| Append (Formal_Name, Chars (Formal_1)); |
| Adjust_Name_Case (Formal_Name, Sloc (Formal_1)); |
| Store_String_Chars (To_String (Formal_Name)); |
| |
| Store_String_Chars (""" and """); |
| |
| Formal_Name.Length := 0; |
| |
| Append (Formal_Name, Chars (Formal_2)); |
| Adjust_Name_Case (Formal_Name, Sloc (Formal_2)); |
| Store_String_Chars (To_String (Formal_Name)); |
| |
| Store_String_Chars (""" overlap"); |
| |
| Insert_Action (Call, |
| Make_If_Statement (Loc, |
| Condition => Cond, |
| Then_Statements => New_List ( |
| Make_Raise_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Standard_Program_Error, Loc), |
| Expression => Make_String_Literal (Loc, End_String))))); |
| |
| -- Create a sequence of overlapping checks by and-ing them all |
| -- together. |
| |
| else |
| if No (Check) then |
| Check := Cond; |
| else |
| Check := |
| Make_And_Then (Loc, |
| Left_Opnd => Check, |
| Right_Opnd => Cond); |
| end if; |
| end if; |
| end Overlap_Check; |
| |
| -- Local variables |
| |
| Actual_1 : Node_Id; |
| Actual_2 : Node_Id; |
| Check : Node_Id; |
| Formal_1 : Entity_Id; |
| Formal_2 : Entity_Id; |
| Orig_Act_1 : Node_Id; |
| Orig_Act_2 : Node_Id; |
| |
| -- Start of processing for Apply_Parameter_Aliasing_Checks |
| |
| begin |
| Check := Empty; |
| |
| Actual_1 := First_Actual (Call); |
| Formal_1 := First_Formal (Subp); |
| while Present (Actual_1) and then Present (Formal_1) loop |
| Orig_Act_1 := Original_Actual (Actual_1); |
| |
| if Is_Name_Reference (Orig_Act_1) then |
| Actual_2 := Next_Actual (Actual_1); |
| Formal_2 := Next_Formal (Formal_1); |
| while Present (Actual_2) and then Present (Formal_2) loop |
| Orig_Act_2 := Original_Actual (Actual_2); |
| |
| -- Generate the check only when the mode of the two formals may |
| -- lead to aliasing. |
| |
| if Is_Name_Reference (Orig_Act_2) |
| and then May_Cause_Aliasing (Formal_1, Formal_2) |
| then |
| |
| -- The aliasing check only applies when some of the formals |
| -- have their passing mechanism unspecified; RM 6.2 (12/3). |
| |
| if Parameter_Passing_Mechanism_Specified (Etype (Orig_Act_1)) |
| and then |
| Parameter_Passing_Mechanism_Specified (Etype (Orig_Act_2)) |
| then |
| null; |
| else |
| Remove_Side_Effects (Actual_1); |
| Remove_Side_Effects (Actual_2); |
| |
| Overlap_Check |
| (Actual_1 => Actual_1, |
| Actual_2 => Actual_2, |
| Formal_1 => Formal_1, |
| Formal_2 => Formal_2, |
| Check => Check); |
| end if; |
| end if; |
| |
| Next_Actual (Actual_2); |
| Next_Formal (Formal_2); |
| end loop; |
| end if; |
| |
| Next_Actual (Actual_1); |
| Next_Formal (Formal_1); |
| end loop; |
| |
| -- Place a simple check right before the call |
| |
| if Present (Check) and then not Exception_Extra_Info then |
| Insert_Action (Call, |
| Make_Raise_Program_Error (Loc, |
| Condition => Check, |
| Reason => PE_Aliased_Parameters)); |
| end if; |
| end Apply_Parameter_Aliasing_Checks; |
| |
| ------------------------------------- |
| -- Apply_Parameter_Validity_Checks -- |
| ------------------------------------- |
| |
| procedure Apply_Parameter_Validity_Checks (Subp : Entity_Id) is |
| Subp_Decl : Node_Id; |
| |
| procedure Add_Validity_Check |
| (Formal : Entity_Id; |
| Prag_Nam : Name_Id; |
| For_Result : Boolean := False); |
| -- Add a single 'Valid[_Scalars] check which verifies the initialization |
| -- of Formal. Prag_Nam denotes the pre or post condition pragma name. |
| -- Set flag For_Result when to verify the result of a function. |
| |
| ------------------------ |
| -- Add_Validity_Check -- |
| ------------------------ |
| |
| procedure Add_Validity_Check |
| (Formal : Entity_Id; |
| Prag_Nam : Name_Id; |
| For_Result : Boolean := False) |
| is |
| procedure Build_Pre_Post_Condition (Expr : Node_Id); |
| -- Create a pre/postcondition pragma that tests expression Expr |
| |
| ------------------------------ |
| -- Build_Pre_Post_Condition -- |
| ------------------------------ |
| |
| procedure Build_Pre_Post_Condition (Expr : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (Subp); |
| Decls : List_Id; |
| Prag : Node_Id; |
| |
| begin |
| Prag := |
| Make_Pragma (Loc, |
| Chars => Prag_Nam, |
| Pragma_Argument_Associations => New_List ( |
| Make_Pragma_Argument_Association (Loc, |
| Chars => Name_Check, |
| Expression => Expr))); |
| |
| -- Add a message unless exception messages are suppressed |
| |
| if not Exception_Locations_Suppressed then |
| Append_To (Pragma_Argument_Associations (Prag), |
| Make_Pragma_Argument_Association (Loc, |
| Chars => Name_Message, |
| Expression => |
| Make_String_Literal (Loc, |
| Strval => "failed " |
| & Get_Name_String (Prag_Nam) |
| & " from " |
| & Build_Location_String (Loc)))); |
| end if; |
| |
| -- Insert the pragma in the tree |
| |
| if Nkind (Parent (Subp_Decl)) = N_Compilation_Unit then |
| Add_Global_Declaration (Prag); |
| Analyze (Prag); |
| |
| -- PPC pragmas associated with subprogram bodies must be inserted |
| -- in the declarative part of the body. |
| |
| elsif Nkind (Subp_Decl) = N_Subprogram_Body then |
| Decls := Declarations (Subp_Decl); |
| |
| if No (Decls) then |
| Decls := New_List; |
| Set_Declarations (Subp_Decl, Decls); |
| end if; |
| |
| Prepend_To (Decls, Prag); |
| Analyze (Prag); |
| |
| -- For subprogram declarations insert the PPC pragma right after |
| -- the declarative node. |
| |
| else |
| Insert_After_And_Analyze (Subp_Decl, Prag); |
| end if; |
| end Build_Pre_Post_Condition; |
| |
| -- Local variables |
| |
| Loc : constant Source_Ptr := Sloc (Subp); |
| Typ : constant Entity_Id := Etype (Formal); |
| Check : Node_Id; |
| Nam : Name_Id; |
| |
| -- Start of processing for Add_Validity_Check |
| |
| begin |
| -- For scalars, generate 'Valid test |
| |
| if Is_Scalar_Type (Typ) then |
| Nam := Name_Valid; |
| |
| -- For any non-scalar with scalar parts, generate 'Valid_Scalars test |
| |
| elsif Scalar_Part_Present (Typ) then |
| Nam := Name_Valid_Scalars; |
| |
| -- No test needed for other cases (no scalars to test) |
| |
| else |
| return; |
| end if; |
| |
| -- Step 1: Create the expression to verify the validity of the |
| -- context. |
| |
| Check := New_Occurrence_Of (Formal, Loc); |
| |
| -- When processing a function result, use 'Result. Generate |
| -- Context'Result |
| |
| if For_Result then |
| Check := |
| Make_Attribute_Reference (Loc, |
| Prefix => Check, |
| Attribute_Name => Name_Result); |
| end if; |
| |
| -- Generate: |
| -- Context['Result]'Valid[_Scalars] |
| |
| Check := |
| Make_Attribute_Reference (Loc, |
| Prefix => Check, |
| Attribute_Name => Nam); |
| |
| -- Step 2: Create a pre or post condition pragma |
| |
| Build_Pre_Post_Condition (Check); |
| end Add_Validity_Check; |
| |
| -- Local variables |
| |
| Formal : Entity_Id; |
| Subp_Spec : Node_Id; |
| |
| -- Start of processing for Apply_Parameter_Validity_Checks |
| |
| begin |
| -- Extract the subprogram specification and declaration nodes |
| |
| Subp_Spec := Parent (Subp); |
| |
| if No (Subp_Spec) then |
| return; |
| end if; |
| |
| if Nkind (Subp_Spec) = N_Defining_Program_Unit_Name then |
| Subp_Spec := Parent (Subp_Spec); |
| end if; |
| |
| Subp_Decl := Parent (Subp_Spec); |
| |
| if not Comes_From_Source (Subp) |
| |
| -- Do not process formal subprograms because the corresponding actual |
| -- will receive the proper checks when the instance is analyzed. |
| |
| or else Is_Formal_Subprogram (Subp) |
| |
| -- Do not process imported subprograms since pre and postconditions |
| -- are never verified on routines coming from a different language. |
| |
| or else Is_Imported (Subp) |
| or else Is_Intrinsic_Subprogram (Subp) |
| |
| -- The PPC pragmas generated by this routine do not correspond to |
| -- source aspects, therefore they cannot be applied to abstract |
| -- subprograms. |
| |
| or else Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration |
| |
| -- Do not consider subprogram renaminds because the renamed entity |
| -- already has the proper PPC pragmas. |
| |
| or else Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration |
| |
| -- Do not process null procedures because there is no benefit of |
| -- adding the checks to a no action routine. |
| |
| or else (Nkind (Subp_Spec) = N_Procedure_Specification |
| and then Null_Present (Subp_Spec)) |
| then |
| return; |
| end if; |
| |
| -- Inspect all the formals applying aliasing and scalar initialization |
| -- checks where applicable. |
| |
| Formal := First_Formal (Subp); |
| while Present (Formal) loop |
| |
| -- Generate the following scalar initialization checks for each |
| -- formal parameter: |
| |
| -- mode IN - Pre => Formal'Valid[_Scalars] |
| -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars] |
| -- mode OUT - Post => Formal'Valid[_Scalars] |
| |
| if Ekind (Formal) in E_In_Parameter | E_In_Out_Parameter then |
| Add_Validity_Check (Formal, Name_Precondition, False); |
| end if; |
| |
| if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then |
| Add_Validity_Check (Formal, Name_Postcondition, False); |
| end if; |
| |
| Next_Formal (Formal); |
| end loop; |
| |
| -- Generate following scalar initialization check for function result: |
| |
| -- Post => Subp'Result'Valid[_Scalars] |
| |
| if Ekind (Subp) = E_Function then |
| Add_Validity_Check (Subp, Name_Postcondition, True); |
| end if; |
| end Apply_Parameter_Validity_Checks; |
| |
| --------------------------- |
| -- Apply_Predicate_Check -- |
| --------------------------- |
| |
| procedure Apply_Predicate_Check |
| (N : Node_Id; |
| Typ : Entity_Id; |
| Fun : Entity_Id := Empty) |
| is |
| Par : Node_Id; |
| S : Entity_Id; |
| |
| Check_Disabled : constant Boolean := (not Predicate_Enabled (Typ)) |
| or else not Predicate_Check_In_Scope (N); |
| begin |
| S := Current_Scope; |
| while Present (S) and then not Is_Subprogram (S) loop |
| S := Scope (S); |
| end loop; |
| |
| -- If the check appears within the predicate function itself, it means |
| -- that the user specified a check whose formal is the predicated |
| -- subtype itself, rather than some covering type. This is likely to be |
| -- a common error, and thus deserves a warning. We want to emit this |
| -- warning even if predicate checking is disabled (in which case the |
| -- warning is still useful even if it is not strictly accurate). |
| |
| if Present (S) and then S = Predicate_Function (Typ) then |
| Error_Msg_NE |
| ("predicate check includes a call to& that requires a " |
| & "predicate check??", Parent (N), Fun); |
| Error_Msg_N |
| ("\this will result in infinite recursion??", Parent (N)); |
| |
| if Is_First_Subtype (Typ) then |
| Error_Msg_NE |
| ("\use an explicit subtype of& to carry the predicate", |
| Parent (N), Typ); |
| end if; |
| |
| if not Check_Disabled then |
| Insert_Action (N, |
| Make_Raise_Storage_Error (Sloc (N), |
| Reason => SE_Infinite_Recursion)); |
| return; |
| end if; |
| end if; |
| |
| if Check_Disabled then |
| return; |
| end if; |
| |
| -- Normal case of predicate active |
| |
| -- If the expression is an IN parameter, the predicate will have |
| -- been applied at the point of call. An additional check would |
| -- be redundant, or will lead to out-of-scope references if the |
| -- call appears within an aspect specification for a precondition. |
| |
| -- However, if the reference is within the body of the subprogram |
| -- that declares the formal, the predicate can safely be applied, |
| -- which may be necessary for a nested call whose formal has a |
| -- different predicate. |
| |
| if Is_Entity_Name (N) |
| and then Ekind (Entity (N)) = E_In_Parameter |
| then |
| declare |
| In_Body : Boolean := False; |
| P : Node_Id := Parent (N); |
| |
| begin |
| while Present (P) loop |
| if Nkind (P) = N_Subprogram_Body |
| and then |
| ((Present (Corresponding_Spec (P)) |
| and then |
| Corresponding_Spec (P) = Scope (Entity (N))) |
| or else |
| Defining_Unit_Name (Specification (P)) = |
| Scope (Entity (N))) |
| then |
| In_Body := True; |
| exit; |
| end if; |
| |
| P := Parent (P); |
| end loop; |
| |
| if not In_Body then |
| return; |
| end if; |
| end; |
| end if; |
| |
| -- If the type has a static predicate and the expression is known |
| -- at compile time, see if the expression satisfies the predicate. |
| |
| Check_Expression_Against_Static_Predicate (N, Typ); |
| |
| if not Expander_Active then |
| return; |
| end if; |
| |
| Par := Parent (N); |
| if Nkind (Par) = N_Qualified_Expression then |
| Par := Parent (Par); |
| end if; |
| |
| -- For an entity of the type, generate a call to the predicate |
| -- function, unless its type is an actual subtype, which is not |
| -- visible outside of the enclosing subprogram. |
| |
| if Is_Entity_Name (N) |
| and then not Is_Actual_Subtype (Typ) |
| then |
| Insert_Action (N, |
| Make_Predicate_Check |
| (Typ, New_Occurrence_Of (Entity (N), Sloc (N)))); |
| return; |
| |
| elsif Nkind (N) in N_Aggregate | N_Extension_Aggregate then |
| |
| -- If the expression is an aggregate in an assignment, apply the |
| -- check to the LHS after the assignment, rather than create a |
| -- redundant temporary. This is only necessary in rare cases |
| -- of array types (including strings) initialized with an |
| -- aggregate with an "others" clause, either coming from source |
| -- or generated by an Initialize_Scalars pragma. |
| |
| if Nkind (Par) = N_Assignment_Statement then |
| Insert_Action_After (Par, |
| Make_Predicate_Check |
| (Typ, Duplicate_Subexpr (Name (Par)))); |
| return; |
| |
| -- Similarly, if the expression is an aggregate in an object |
| -- declaration, apply it to the object after the declaration. |
| |
| -- This is only necessary in cases of tagged extensions |
| -- initialized with an aggregate with an "others => <>" clause, |
| -- when the subtypes of LHS and RHS do not statically match or |
| -- when we know the object's type will be rewritten later. |
| -- The condition for the later is copied from the |
| -- Analyze_Object_Declaration procedure when it actually builds the |
| -- subtype. |
| |
| elsif Nkind (Par) = N_Object_Declaration then |
| if Subtypes_Statically_Match |
| (Etype (Defining_Identifier (Par)), Typ) |
| and then (Nkind (N) = N_Extension_Aggregate |
| or else (Is_Definite_Subtype (Typ) |
| and then Build_Default_Subtype_OK (Typ))) |
| then |
| Insert_Action_After (Par, |
| Make_Predicate_Check (Typ, |
| New_Occurrence_Of (Defining_Identifier (Par), Sloc (N)))); |
| return; |
| end if; |
| |
| end if; |
| end if; |
| |
| -- If the expression is not an entity it may have side effects, |
| -- and the following call will create an object declaration for |
| -- it. We disable checks during its analysis, to prevent an |
| -- infinite recursion. |
| |
| Insert_Action (N, |
| Make_Predicate_Check |
| (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks); |
| end Apply_Predicate_Check; |
| |
| ----------------------- |
| -- Apply_Range_Check -- |
| ----------------------- |
| |
| procedure Apply_Range_Check |
| (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 |
| -- 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; |
| |
| ------------------------------ |
| -- Apply_Scalar_Range_Check -- |
| ------------------------------ |
| |
| -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag |
| -- off if it is already set on. |
| |
| procedure Apply_Scalar_Range_Check |
| (Expr : Node_Id; |
| Target_Typ : Entity_Id; |
| Source_Typ : Entity_Id := Empty; |
| Fixed_Int : Boolean := False) |
| is |
| Parnt : constant Node_Id := Parent (Expr); |
| S_Typ : Entity_Id; |
| Arr : Node_Id := Empty; -- initialize to prevent warning |
| Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning |
| |
| Is_Subscr_Ref : Boolean; |
| -- Set true if Expr is a subscript |
| |
| Is_Unconstrained_Subscr_Ref : Boolean; |
| -- Set true if Expr is a subscript of an unconstrained array. In this |
| -- case we do not attempt to do an analysis of the value against the |
| -- range of the subscript, since we don't know the actual subtype. |
| |
| Int_Real : Boolean; |
| -- Set to True if Expr should be regarded as a real value even though |
| -- the type of Expr might be discrete. |
| |
| procedure Bad_Value (Warn : Boolean := False); |
| -- Procedure called if value is determined to be out of range. Warn is |
| -- True to force a warning instead of an error, even when SPARK_Mode is |
| -- On. |
| |
| --------------- |
| -- Bad_Value -- |
| --------------- |
| |
| procedure Bad_Value (Warn : Boolean := False) is |
| begin |
| Apply_Compile_Time_Constraint_Error |
| (Expr, "value not in range of}??", CE_Range_Check_Failed, |
| Ent => Target_Typ, |
| Typ => Target_Typ, |
| Warn => Warn); |
| end Bad_Value; |
| |
| -- Start of processing for Apply_Scalar_Range_Check |
| |
| begin |
| -- Return if check obviously not needed |
| |
| if |
| -- Not needed inside generic |
| |
| Inside_A_Generic |
| |
| -- Not needed if previous error |
| |
| or else Target_Typ = Any_Type |
| or else Nkind (Expr) = N_Error |
| |
| -- Not needed for non-scalar type |
| |
| or else not Is_Scalar_Type (Target_Typ) |
| |
| -- Not needed if we know node raises CE already |
| |
| or else Raises_Constraint_Error (Expr) |
| then |
| return; |
| end if; |
| |
| -- Now, see if checks are suppressed |
| |
| Is_Subscr_Ref := |
| Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component; |
| |
| if Is_Subscr_Ref then |
| Arr := Prefix (Parnt); |
| Arr_Typ := Get_Actual_Subtype_If_Available (Arr); |
| |
| if Is_Access_Type (Arr_Typ) then |
| Arr_Typ := Designated_Type (Arr_Typ); |
| end if; |
| end if; |
| |
| if not Do_Range_Check (Expr) then |
| |
| -- Subscript reference. Check for Index_Checks suppressed |
| |
| if Is_Subscr_Ref then |
| |
| -- Check array type and its base type |
| |
| if Index_Checks_Suppressed (Arr_Typ) |
| or else Index_Checks_Suppressed (Base_Type (Arr_Typ)) |
| then |
| return; |
| |
| -- Check array itself if it is an entity name |
| |
| elsif Is_Entity_Name (Arr) |
| and then Index_Checks_Suppressed (Entity (Arr)) |
| then |
| return; |
| |
| -- Check expression itself if it is an entity name |
| |
| elsif Is_Entity_Name (Expr) |
| and then Index_Checks_Suppressed (Entity (Expr)) |
| then |
| return; |
| end if; |
| |
| -- All other cases, check for Range_Checks suppressed |
| |
| else |
| -- Check target type and its base type |
| |
| if Range_Checks_Suppressed (Target_Typ) |
| or else Range_Checks_Suppressed (Base_Type (Target_Typ)) |
| then |
| return; |
| |
| -- Check expression itself if it is an entity name |
| |
| elsif Is_Entity_Name (Expr) |
| and then Range_Checks_Suppressed (Entity (Expr)) |
| then |
| return; |
| |
| -- If Expr is part of an assignment statement, then check left |
| -- side of assignment if it is an entity name. |
| |
| elsif Nkind (Parnt) = N_Assignment_Statement |
| and then Is_Entity_Name (Name (Parnt)) |
| and then Range_Checks_Suppressed (Entity (Name (Parnt))) |
| then |
| return; |
| end if; |
| end if; |
| end if; |
| |
| -- Do not set range checks if they are killed |
| |
| if Nkind (Expr) = N_Unchecked_Type_Conversion |
| and then Kill_Range_Check (Expr) |
| then |
| return; |
| end if; |
| |
| -- Do not set range checks for any values from System.Scalar_Values |
| -- since the whole idea of such values is to avoid checking them. |
| |
| if Is_Entity_Name (Expr) |
| and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values) |
| then |
| return; |
| end if; |
| |
| -- Now see if we need a check |
| |
| if No (Source_Typ) then |
| S_Typ := Etype (Expr); |
| else |
| S_Typ := Source_Typ; |
| end if; |
| |
| if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then |
| return; |
| end if; |
| |
| Is_Unconstrained_Subscr_Ref := |
| Is_Subscr_Ref and then not Is_Constrained (Arr_Typ); |
| |
| -- Special checks for floating-point type |
| |
| if Is_Floating_Point_Type (S_Typ) then |
| |
| -- Always do a range check if the source type includes infinities and |
| -- the target type does not include infinities. We do not do this if |
| -- range checks are killed. |
| -- If the expression is a literal and the bounds of the type are |
| -- static constants it may be possible to optimize the check. |
| |
| if Has_Infinities (S_Typ) |
| and then not Has_Infinities (Target_Typ) |
| then |
| -- If the expression is a literal and the bounds of the type are |
| -- static constants it may be possible to optimize the check. |
| |
| if Nkind (Expr) = N_Real_Literal then |
| declare |
| Tlo : constant Node_Id := Type_Low_Bound (Target_Typ); |
| Thi : constant Node_Id := Type_High_Bound (Target_Typ); |
| |
| begin |
| if Compile_Time_Known_Value (Tlo) |
| and then Compile_Time_Known_Value (Thi) |
| and then Expr_Value_R (Expr) >= Expr_Value_R (Tlo) |
| and then Expr_Value_R (Expr) <= Expr_Value_R (Thi) |
| then |
| return; |
| else |
| Enable_Range_Check (Expr); |
| end if; |
| end; |
| |
| else |
| Enable_Range_Check (Expr); |
| end if; |
| end if; |
| end if; |
| |
| -- Return if we know expression is definitely in the range of the target |
| -- type as determined by Determine_Range_To_Discrete. Right now we only |
| -- do this for discrete target types, i.e. neither for fixed-point nor |
| -- for floating-point types. But the additional less precise tests below |
| -- catch these cases. |
| |
| -- Note: skip this if we are given a source_typ, since the point of |
| -- supplying a Source_Typ is to stop us looking at the expression. |
| -- We could sharpen this test to be out parameters only ??? |
| |
| if Is_Discrete_Type (Target_Typ) |
| and then not Is_Unconstrained_Subscr_Ref |
| and then No (Source_Typ) |
| then |
| declare |
| Thi : constant Node_Id := Type_High_Bound (Target_Typ); |
| Tlo : constant Node_Id := Type_Low_Bound (Target_Typ); |
| |
| begin |
| if Compile_Time_Known_Value (Tlo) |
| and then Compile_Time_Known_Value (Thi) |
| then |
| declare |
| OK : Boolean := False; -- initialize to prevent warning |
| Hiv : constant Uint := Expr_Value (Thi); |
| Lov : constant Uint := Expr_Value (Tlo); |
| Hi : Uint := No_Uint; |
| Lo : Uint := No_Uint; |
| |
| begin |
| -- If range is null, we for sure have a constraint error (we |
| -- don't even need to look at the value involved, since all |
| -- possible values will raise CE). |
| |
| if Lov > Hiv then |
| |
| -- When SPARK_Mode is On, force a warning instead of |
| -- an error in that case, as this likely corresponds |
| -- to deactivated code. |
| |
| Bad_Value (Warn => SPARK_Mode = On); |
| |
| return; |
| end if; |
| |
| -- Otherwise determine range of value |
| |
| Determine_Range_To_Discrete |
| (Expr, OK, Lo, Hi, Fixed_Int, Assume_Valid => True); |
| |
| if OK then |
| |
| -- If definitely in range, all OK |
| |
| if Lo >= Lov and then Hi <= Hiv then |
| return; |
| |
| -- If definitely not in range, warn |
| |
| elsif Lov > Hi or else Hiv < Lo then |
| |
| -- Ignore out of range values for System.Priority in |
| -- CodePeer mode since the actual target compiler may |
| -- provide a wider range. |
| |
| if not CodePeer_Mode |
| or else not Is_RTE (Target_Typ, RE_Priority) |
| then |
| Bad_Value; |
| end if; |
| |
| return; |
| |
| -- Otherwise we don't know |
| |
| else |
| null; |
| end if; |
| end if; |
| end; |
| end if; |
| end; |
| end if; |
| |
| Int_Real := |
| Is_Floating_Point_Type (S_Typ) |
| or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int); |
| |
| -- Check if we can determine at compile time whether Expr is in the |
| -- range of the target type. Note that if S_Typ is within the bounds |
| -- of Target_Typ then this must be the case. This check is meaningful |
| -- only if this is not a conversion between integer and real types, |
| -- unless for a fixed-point type if Fixed_Int is set. |
| |
| if not Is_Unconstrained_Subscr_Ref |
| and then (Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ) |
| or else (Fixed_Int and then Is_Discrete_Type (Target_Typ))) |
| and then |
| (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int) |
| |
| -- Also check if the expression itself is in the range of the |
| -- target type if it is a known at compile time value. We skip |
| -- this test if S_Typ is set since for OUT and IN OUT parameters |
| -- the Expr itself is not relevant to the checking. |
| |
| or else |
| (No (Source_Typ) |
| and then Is_In_Range (Expr, Target_Typ, |
| Assume_Valid => True, |
| Fixed_Int => Fixed_Int, |
| Int_Real => Int_Real))) |
| then |
| return; |
| |
| elsif Is_Out_Of_Range (Expr, Target_Typ, |
| Assume_Valid => True, |
| Fixed_Int => Fixed_Int, |
| Int_Real => Int_Real) |
| then |
| Bad_Value; |
| return; |
| |
| -- Floating-point case |
| -- In the floating-point case, we only do range checks if the type is |
| -- constrained. We definitely do NOT want range checks for unconstrained |
| -- types, since we want to have infinities, except when |
| -- Check_Float_Overflow is set. |
| |
| elsif Is_Floating_Point_Type (S_Typ) then |
| if Is_Constrained (S_Typ) or else Check_Float_Overflow then |
| Enable_Range_Check (Expr); |
| end if; |
| |
| -- For all other cases we enable a range check unconditionally |
| |
| else |
| Enable_Range_Check (Expr); |
| return; |
| end if; |
| end Apply_Scalar_Range_Check; |
| |
| ---------------------------------- |
| -- Apply_Selected_Length_Checks -- |
| ---------------------------------- |
| |
| procedure Apply_Selected_Length_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 Length_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 |
| |
| -- Note: this means that we lose some useful warnings if the expander |
| -- is not active. |
| |
| if not Expander_Active then |
| return; |
| end if; |
| |
| R_Result := |
| Selected_Length_Checks (Expr, Target_Typ, Source_Typ, Empty); |
| |
| for J in 1 .. 2 loop |
| R_Cno := R_Result (J); |
| exit when No (R_Cno); |
| |
| -- A length check may mention an Itype which is attached to a |
| -- subsequent node. At the top level in a package this can cause |
| -- an order-of-elaboration problem, so we make sure that the itype |
| -- is referenced now. |
| |
| if Ekind (Current_Scope) = E_Package |
| and then Is_Compilation_Unit (Current_Scope) |
| then |
| Ensure_Defined (Target_Typ, Expr); |
| |
| if Present (Source_Typ) then |
| Ensure_Defined (Source_Typ, Expr); |
| |
| elsif Is_Itype (Etype (Expr)) then |
| Ensure_Defined (Etype (Expr), Expr); |
| end if; |
| end if; |
| |
| if Nkind (R_Cno) = N_Raise_Constraint_Error |
| and then Present (Condition (R_Cno)) |
| then |
| Cond := Condition (R_Cno); |
| |
| -- Case where node does not now have a dynamic check |
| |
| if not Has_Dynamic_Length_Check (Expr) then |
| |
| -- If checks are on, just insert the check |
| |
| if Checks_On then |
| Insert_Action (Expr, R_Cno); |
| |
| if not Do_Static then |
| Set_Has_Dynamic_Length_Check (Expr); |
| end if; |
| |
| -- If checks are off, then analyze the length check after |
| -- temporarily attaching it to the tree in case the relevant |
| -- condition can be evaluated at compile time. We still want a |
| -- compile time warning in this case. |
| |
| else |
| Set_Parent (R_Cno, Expr); |
| Analyze (R_Cno); |
| end if; |
| end if; |
| |
| -- Output a warning if the condition is known to be True |
| |
| if Is_Entity_Name (Cond) |
| and then Entity (Cond) = Standard_True |
| then |
| Apply_Compile_Time_Constraint_Error |
| (Expr, "wrong length for array of}??", |
| CE_Length_Check_Failed, |
| Ent => Target_Typ, |
| Typ => Target_Typ); |
| |
| -- 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 or else not Checks_On then |
| Remove_Warning_Messages (R_Cno); |
| Rewrite (R_Cno, Make_Null_Statement (Loc)); |
| end if; |
| |
| else |
| Install_Static_Check (R_Cno, Loc); |
| end if; |
| end loop; |
| end Apply_Selected_Length_Checks; |
| |
| ------------------------------- |
| -- Apply_Static_Length_Check -- |
| ------------------------------- |
| |
| procedure Apply_Static_Length_Check |
| (Expr : Node_Id; |
| Target_Typ : Entity_Id; |
| Source_Typ : Entity_Id := Empty) |
| is |
| begin |
| Apply_Selected_Length_Checks |
| (Expr, Target_Typ, Source_Typ, Do_Static => True); |
| end Apply_Static_Length_Check; |
| |
| ------------------------------------- |
| -- Apply_Subscript_Validity_Checks -- |
| ------------------------------------- |
| |
| procedure Apply_Subscript_Validity_Checks |
| (Expr : Node_Id; |
| No_Check_Needed : Dimension_Set := Empty_Dimension_Set) is |
| Sub : Node_Id; |
| |
| Dimension : Pos := 1; |
| begin |
| pragma Assert (Nkind (Expr) = N_Indexed_Component); |
| |
| -- Loop through subscripts |
| |
| Sub := First (Expressions (Expr)); |
| while Present (Sub) loop |
| |
| -- Check one subscript. Note that we do not worry about enumeration |
| -- type with holes, since we will convert the value to a Pos value |
| -- for the subscript, and that convert will do the necessary validity |
| -- check. |
| |
| if (No_Check_Needed = Empty_Dimension_Set) |
| or else not No_Check_Needed.Elements (Dimension) |
| then |
| Ensure_Valid (Sub, Holes_OK => True); |
| end if; |
| |
| -- Move to next subscript |
| |
| Next (Sub); |
| Dimension := Dimension + 1; |
| end loop; |
| end Apply_Subscript_Validity_Checks; |
| |
| ---------------------------------- |
| -- Apply_Type_Conversion_Checks -- |
| ---------------------------------- |
| |
| procedure Apply_Type_Conversion_Checks (N : Node_Id) is |
| Target_Type : constant Entity_Id := Etype (N); |
| Target_Base : constant Entity_Id := Base_Type (Target_Type); |
| Expr : constant Node_Id := Expression (N); |
| |
| Expr_Type : constant Entity_Id := Underlying_Type (Etype (Expr)); |
| -- Note: if Etype (Expr) is a private type without discriminants, its |
| -- full view might have discriminants with defaults, so we need the |
| -- full view here to retrieve the constraints. |
| |
| procedure Make_Discriminant_Constraint_Check |
| (Target_Type : Entity_Id; |
| Expr_Type : Entity_Id); |
| -- Generate a discriminant check based on the target type and expression |
| -- type for Expr. |
| |
| ---------------------------------------- |
| -- Make_Discriminant_Constraint_Check -- |
| ---------------------------------------- |
| |
| procedure Make_Discriminant_Constraint_Check |
| (Target_Type : Entity_Id; |
| Expr_Type : Entity_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Cond : Node_Id; |
| Constraint : Elmt_Id; |
| Discr_Value : Node_Id; |
| Discr : Entity_Id; |
| |
| New_Constraints : constant Elist_Id := New_Elmt_List; |
| Old_Constraints : constant Elist_Id := |
| Discriminant_Constraint (Expr_Type); |
| |
| begin |
| -- Build an actual discriminant constraint list using the stored |
| -- constraint, to verify that the expression of the parent type |
| -- satisfies the constraints imposed by the (unconstrained) derived |
| -- type. This applies to value conversions, not to view conversions |
| -- of tagged types. |
| |
| Constraint := First_Elmt (Stored_Constraint (Target_Type)); |
| while Present (Constraint) loop |
| Discr_Value := Node (Constraint); |
| |
| if Is_Entity_Name (Discr_Value) |
| and then Ekind (Entity (Discr_Value)) = E_Discriminant |
| then |
| Discr := Corresponding_Discriminant (Entity (Discr_Value)); |
| |
| if Present (Discr) |
| and then Scope (Discr) = Base_Type (Expr_Type) |
| then |
| -- Parent is constrained by new discriminant. Obtain |
| -- Value of original discriminant in expression. If the |
| -- new discriminant has been used to constrain more than |
| -- one of the stored discriminants, this will provide the |
| -- required consistency check. |
| |
| Append_Elmt |
| (Make_Selected_Component (Loc, |
| Prefix => |
| Duplicate_Subexpr_No_Checks |
| (Expr, Name_Req => True), |
| Selector_Name => |
| Make_Identifier (Loc, Chars (Discr))), |
| New_Constraints); |
| |
| else |
| -- Discriminant of more remote ancestor ??? |
| |
| return; |
| end if; |
| |
| -- Derived type definition has an explicit value for this |
| -- stored discriminant. |
| |
| else |
| Append_Elmt |
| (Duplicate_Subexpr_No_Checks (Discr_Value), |
| New_Constraints); |
| end if; |
| |
| Next_Elmt (Constraint); |
| end loop; |
| |
| -- Use the unconstrained expression type to retrieve the |
| -- discriminants of the parent, and apply momentarily the |
| -- discriminant constraint synthesized above. |
| |
| -- Note: We use Expr_Type instead of Target_Type since the number of |
| -- actual discriminants may be different due to the presence of |
| -- stored discriminants and cause Build_Discriminant_Checks to fail. |
| |
| Set_Discriminant_Constraint (Expr_Type, New_Constraints); |
| Cond := Build_Discriminant_Checks (Expr, Expr_Type); |
| Set_Discriminant_Constraint (Expr_Type, Old_Constraints); |
| |
| -- Conversion between access types requires that we check for null |
| -- before checking discriminants. |
| |
| if Is_Access_Type (Etype (Expr)) then |
| Cond := Make_And_Then (Loc, |
| Left_Opnd => |
| Make_Op_Ne (Loc, |
| Left_Opnd => |
| Duplicate_Subexpr_No_Checks |
| (Expr, Name_Req => True), |
| Right_Opnd => Make_Null (Loc)), |
| Right_Opnd => Cond); |
| end if; |
| |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => Cond, |
| Reason => CE_Discriminant_Check_Failed)); |
| end Make_Discriminant_Constraint_Check; |
| |
| -- Start of processing for Apply_Type_Conversion_Checks |
| |
| begin |
| if Inside_A_Generic then |
| return; |
| |
| -- Skip these checks if serious errors detected, there are some nasty |
| -- situations of incomplete trees that blow things up. |
| |
| elsif Serious_Errors_Detected > 0 then |
| return; |
| |
| -- Never generate discriminant checks for Unchecked_Union types |
| |
| elsif Present (Expr_Type) |
| and then Is_Unchecked_Union (Expr_Type) |
| then |
| return; |
| |
| -- Scalar type conversions of the form Target_Type (Expr) require a |
| -- range check if we cannot be sure that Expr is in the base type of |
| -- Target_Typ and also that Expr is in the range of Target_Typ. These |
| -- are not quite the same condition from an implementation point of |
| -- view, but clearly the second includes the first. |
| |
| elsif Is_Scalar_Type (Target_Type) then |
| declare |
| Conv_OK : constant Boolean := Conversion_OK (N); |
| -- If the Conversion_OK flag on the type conversion is set and no |
| -- floating-point type is involved in the type conversion then |
| -- fixed-point values must be read as integral values. |
| |
| Float_To_Int : constant Boolean := |
| Is_Floating_Point_Type (Expr_Type) |
| and then Is_Integer_Type (Target_Type); |
| |
| begin |
| if not Overflow_Checks_Suppressed (Target_Base) |
| and then not Overflow_Checks_Suppressed (Target_Type) |
| and then not |
| In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK) |
| and then not Float_To_Int |
| then |
| -- A small optimization: the attribute 'Pos applied to an |
| -- enumeration type has a known range, even though its type is |
| -- Universal_Integer. So in numeric conversions it is usually |
| -- within range of the target integer type. Use the static |
| -- bounds of the base types to check. Disable this optimization |
| -- in case of a descendant of a generic formal discrete type, |
| -- because we don't necessarily know the upper bound yet. |
| |
| if Nkind (Expr) = N_Attribute_Reference |
| and then Attribute_Name (Expr) = Name_Pos |
| and then Is_Enumeration_Type (Etype (Prefix (Expr))) |
| and then |
| not Is_Generic_Type (Root_Type (Etype (Prefix (Expr)))) |
| and then Is_Integer_Type (Target_Type) |
| then |
| declare |
| Enum_T : constant Entity_Id := |
| Root_Type (Etype (Prefix (Expr))); |
| Int_T : constant Entity_Id := Base_Type (Target_Type); |
| Last_I : constant Uint := |
| Intval (High_Bound (Scalar_Range (Int_T))); |
| Last_E : Uint; |
| |
| begin |
| -- Character types have no explicit literals, so we use |
| -- the known number of characters in the type. |
| |
| if Root_Type (Enum_T) = Standard_Character then |
| Last_E := UI_From_Int (255); |
| |
| elsif Enum_T = Standard_Wide_Character |
| or else Enum_T = Standard_Wide_Wide_Character |
| then |
| Last_E := UI_From_Int (65535); |
| |
| else |
| Last_E := |
| Enumeration_Pos |
| (Entity (High_Bound (Scalar_Range (Enum_T)))); |
| end if; |
| |
| if Last_E > Last_I then |
| Activate_Overflow_Check (N); |
| end if; |
| end; |
| else |
| Activate_Overflow_Check (N); |
| end if; |
| end if; |
| |
| if not Range_Checks_Suppressed (Target_Type) |
| and then not Range_Checks_Suppressed (Expr_Type) |
| then |
| if Float_To_Int |
| and then not GNATprove_Mode |
| then |
| Apply_Float_Conversion_Check (Expr, Target_Type); |
| else |
| -- Raw conversions involving fixed-point types are expanded |
| -- separately and do not need a Range_Check flag yet, except |
| -- in GNATprove_Mode where this expansion is not performed. |
| -- This does not apply to conversion where fixed-point types |
| -- are treated as integers, which are precisely generated by |
| -- this expansion. |
| |
| if GNATprove_Mode |
| or else Conv_OK |
| or else (not Is_Fixed_Point_Type (Expr_Type) |
| and then not Is_Fixed_Point_Type (Target_Type)) |
| then |
| Apply_Scalar_Range_Check |
| (Expr, Target_Type, Fixed_Int => Conv_OK); |
| |
| else |
| Set_Do_Range_Check (Expr, False); |
| end if; |
| |
| -- If the target type has predicates, we need to indicate |
| -- the need for a check, even if Determine_Range finds that |
| -- the value is within bounds. This may be the case e.g for |
| -- a division with a constant denominator. |
| |
| if Has_Predicates (Target_Type) then |
| Enable_Range_Check (Expr); |
| end if; |
| end if; |
| end if; |
| end; |
| |
| -- Generate discriminant constraint checks for access types on the |
| -- designated target type's stored constraints. |
| |
| -- Do we need to generate subtype predicate checks here as well ??? |
| |
| elsif Comes_From_Source (N) |
| and then Ekind (Target_Type) = E_General_Access_Type |
| |
| -- Check that both of the designated types have known discriminants, |
| -- and that such checks on the target type are not suppressed. |
| |
| and then Has_Discriminants (Directly_Designated_Type (Target_Type)) |
| and then Has_Discriminants (Directly_Designated_Type (Expr_Type)) |
| and then not Discriminant_Checks_Suppressed |
| (Directly_Designated_Type (Target_Type)) |
| |
| -- Verify the designated type of the target has stored constraints |
| |
| and then Present |
| (Stored_Constraint (Directly_Designated_Type (Target_Type))) |
| then |
| Make_Discriminant_Constraint_Check |
| (Target_Type => Directly_Designated_Type (Target_Type), |
| Expr_Type => Directly_Designated_Type (Expr_Type)); |
| |
| -- Create discriminant checks for the Target_Type's stored constraints |
| |
| elsif Comes_From_Source (N) |
| and then not Discriminant_Checks_Suppressed (Target_Type) |
| and then Is_Record_Type (Target_Type) |
| and then Is_Derived_Type (Target_Type) |
| and then not Is_Tagged_Type (Target_Type) |
| and then not Is_Constrained (Target_Type) |
| and then Present (Stored_Constraint (Target_Type)) |
| then |
| Make_Discriminant_Constraint_Check (Target_Type, Expr_Type); |
| |
| -- For arrays, checks are set now, but conversions are applied during |
| -- expansion, to take into accounts changes of representation. The |
| -- checks become range checks on the base type or length checks on the |
| -- subtype, depending on whether the target type is unconstrained or |
| -- constrained. Note that the range check is put on the expression of a |
| -- type conversion, while the length check is put on the type conversion |
| -- itself. |
| |
| elsif Is_Array_Type (Target_Type) then |
| if Is_Constrained (Target_Type) then |
| Set_Do_Length_Check (N); |
| else |
| Set_Do_Range_Check (Expr); |
| end if; |
| end if; |
| end Apply_Type_Conversion_Checks; |
| |
| ---------------------------------------------- |
| -- Apply_Universal_Integer_Attribute_Checks -- |
| ---------------------------------------------- |
| |
| procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Typ : constant Entity_Id := Etype (N); |
| |
| begin |
| if Inside_A_Generic then |
| return; |
| |
| -- Nothing to do if the result type is universal integer |
| |
| elsif Typ = Universal_Integer then |
| return; |
| |
| -- Nothing to do if checks are suppressed |
| |
| elsif Range_Checks_Suppressed (Typ) |
| and then Overflow_Checks_Suppressed (Typ) |
| then |
| return; |
| |
| -- Nothing to do if the attribute does not come from source. The |
| -- internal attributes we generate of this type do not need checks, |
| -- and furthermore the attempt to check them causes some circular |
| -- elaboration orders when dealing with packed types. |
| |
| elsif not Comes_From_Source (N) then |
| return; |
| |
| -- If the prefix is a selected component that depends on a discriminant |
| -- the check may improperly expose a discriminant instead of using |
| -- the bounds of the object itself. Set the type of the attribute to |
| -- the base type of the context, so that a check will be imposed when |
| -- needed (e.g. if the node appears as an index). |
| |
| elsif Nkind (Prefix (N)) = N_Selected_Component |
| and then Ekind (Typ) = E_Signed_Integer_Subtype |
| and then Depends_On_Discriminant (Scalar_Range (Typ)) |
| then |
| Set_Etype (N, Base_Type (Typ)); |
| |
| -- Otherwise, replace the attribute node with a type conversion node |
| -- whose expression is the attribute, retyped to universal integer, and |
| -- whose subtype mark is the target type. The call to analyze this |
| -- conversion will set range and overflow checks as required for proper |
| -- detection of an out of range value. |
| |
| else |
| Set_Etype (N, Universal_Integer); |
| Set_Analyzed (N, True); |
| |
| Rewrite (N, |
| Make_Type_Conversion (Loc, |
| Subtype_Mark => New_Occurrence_Of (Typ, Loc), |
| Expression => Relocate_Node (N))); |
| |
| Analyze_And_Resolve (N, Typ); |
| return; |
| end if; |
| end Apply_Universal_Integer_Attribute_Checks; |
| |
| ------------------------------------- |
| -- Atomic_Synchronization_Disabled -- |
| ------------------------------------- |
| |
| -- Note: internally Disable/Enable_Atomic_Synchronization is implemented |
| -- using a bogus check called Atomic_Synchronization. This is to make it |
| -- more convenient to get exactly the same semantics as [Un]Suppress. |
| |
| function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean is |
| begin |
| -- If debug flag d.e is set, always return False, i.e. all atomic sync |
| -- looks enabled, since it is never disabled. |
| |
| if Debug_Flag_Dot_E then |
| return False; |
| |
| -- If debug flag d.d is set then always return True, i.e. all atomic |
| -- sync looks disabled, since it always tests True. |
| |
| elsif Debug_Flag_Dot_D then |
| return True; |
| |
| -- If entity present, then check result for that entity |
| |
| elsif Present (E) and then Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Atomic_Synchronization); |
| |
| -- Otherwise result depends on current scope setting |
| |
| else |
| return Scope_Suppress.Suppress (Atomic_Synchronization); |
| end if; |
| end Atomic_Synchronization_Disabled; |
| |
| ------------------------------- |
| -- Build_Discriminant_Checks -- |
| ------------------------------- |
| |
| function Build_Discriminant_Checks |
| (N : Node_Id; |
| T_Typ : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Cond : Node_Id; |
| Disc : Elmt_Id; |
| Disc_Ent : Entity_Id; |
| Dref : Node_Id; |
| Dval : Node_Id; |
| |
| function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id; |
| |
| function Replace_Current_Instance |
| (N : Node_Id) return Traverse_Result; |
| -- Replace a reference to the current instance of the type with the |
| -- corresponding _init formal of the initialization procedure. Note: |
| -- this function relies on us currently being within the initialization |
| -- procedure. |
| |
| -------------------------------- |
| -- Aggregate_Discriminant_Val -- |
| -------------------------------- |
| |
| function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is |
| Assoc : Node_Id; |
| |
| begin |
| -- The aggregate has been normalized with named associations. We use |
| -- the Chars field to locate the discriminant to take into account |
| -- discriminants in derived types, which carry the same name as those |
| -- in the parent. |
| |
| Assoc := First (Component_Associations (N)); |
| while Present (Assoc) loop |
| if Chars (First (Choices (Assoc))) = Chars (Disc) then |
| return Expression (Assoc); |
| else |
| Next (Assoc); |
| end if; |
| end loop; |
| |
| -- Discriminant must have been found in the loop above |
| |
| raise Program_Error; |
| end Aggregate_Discriminant_Val; |
| |
| ------------------------------ |
| -- Replace_Current_Instance -- |
| ------------------------------ |
| |
| function Replace_Current_Instance |
| (N : Node_Id) return Traverse_Result is |
| begin |
| if Is_Entity_Name (N) |
| and then Etype (N) = Entity (N) |
| then |
| Rewrite (N, |
| New_Occurrence_Of (First_Formal (Current_Subprogram), Loc)); |
| end if; |
| |
| return OK; |
| end Replace_Current_Instance; |
| |
| procedure Search_And_Replace_Current_Instance is new |
| Traverse_Proc (Replace_Current_Instance); |
| |
| -- Start of processing for Build_Discriminant_Checks |
| |
| begin |
| -- Loop through discriminants evolving the condition |
| |
| Cond := Empty; |
| Disc := First_Elmt (Discriminant_Constraint (T_Typ)); |
| |
| -- For a fully private type, use the discriminants of the parent type |
| |
| if Is_Private_Type (T_Typ) |
| and then No (Full_View (T_Typ)) |
| then |
| Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ))); |
| else |
| Disc_Ent := First_Discriminant (T_Typ); |
| end if; |
| |
| while Present (Disc) loop |
| Dval := Node (Disc); |
| |
| if Nkind (Dval) = N_Identifier |
| and then Ekind (Entity (Dval)) = E_Discriminant |
| then |
| Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc); |
| else |
| Dval := Duplicate_Subexpr_No_Checks (Dval); |
| end if; |
| |
| -- Replace references to the current instance of the type with the |
| -- corresponding _init formal of the initialization procedure. |
| |
| if Within_Init_Proc then |
| Search_And_Replace_Current_Instance (Dval); |
| end if; |
| |
| -- If we have an Unchecked_Union node, we can infer the discriminants |
| -- of the node. |
| |
| if Is_Unchecked_Union (Base_Type (T_Typ)) then |
| Dref := New_Copy ( |
| Get_Discriminant_Value ( |
| First_Discriminant (T_Typ), |
| T_Typ, |
| Stored_Constraint (T_Typ))); |
| |
| elsif Nkind (N) = N_Aggregate then |
| Dref := |
| Duplicate_Subexpr_No_Checks |
| (Aggregate_Discriminant_Val (Disc_Ent)); |
| |
| elsif Is_Access_Type (Etype (N)) then |
| Dref := |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Explicit_Dereference (Loc, |
| Duplicate_Subexpr_No_Checks (N, Name_Req => True)), |
| Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent))); |
| |
| Set_Is_In_Discriminant_Check (Dref); |
| else |
| Dref := |
| Make_Selected_Component (Loc, |
| Prefix => |
| Duplicate_Subexpr_No_Checks (N, Name_Req => True), |
| Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent))); |
| |
| Set_Is_In_Discriminant_Check (Dref); |
| end if; |
| |
| Evolve_Or_Else (Cond, |
| Make_Op_Ne (Loc, |
| Left_Opnd => Dref, |
| Right_Opnd => Dval)); |
| |
| Next_Elmt (Disc); |
| Next_Discriminant (Disc_Ent); |
| end loop; |
| |
| return Cond; |
| end Build_Discriminant_Checks; |
| |
| ------------------ |
| -- Check_Needed -- |
| ------------------ |
| |
| function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean is |
| N : Node_Id; |
| P : Node_Id; |
| K : Node_Kind; |
| L : Node_Id; |
| R : Node_Id; |
| |
| function Left_Expression (Op : Node_Id) return Node_Id; |
| -- Return the relevant expression from the left operand of the given |
| -- short circuit form: this is LO itself, except if LO is a qualified |
| -- expression, a type conversion, or an expression with actions, in |
| -- which case this is Left_Expression (Expression (LO)). |
| |
| --------------------- |
| -- Left_Expression -- |
| --------------------- |
| |
| function Left_Expression (Op : Node_Id) return Node_Id is |
| LE : Node_Id := Left_Opnd (Op); |
| begin |
| while Nkind (LE) in N_Qualified_Expression |
| | N_Type_Conversion |
| | N_Expression_With_Actions |
| loop |
| LE := Expression (LE); |
| end loop; |
| |
| return LE; |
| end Left_Expression; |
| |
| -- Start of processing for Check_Needed |
| |
| begin |
| -- Always check if not simple entity |
| |
| if Nkind (Nod) not in N_Has_Entity |
| or else not Comes_From_Source (Nod) |
| then |
| return True; |
| end if; |
| |
| -- Look up tree for short circuit |
| |
| N := Nod; |
| loop |
| P := Parent (N); |
| K := Nkind (P); |
| |
| -- Done if out of subexpression (note that we allow generated stuff |
| -- such as itype declarations in this context, to keep the loop going |
| -- since we may well have generated such stuff in complex situations. |
| -- Also done if no parent (probably an error condition, but no point |
| -- in behaving nasty if we find it). |
| |
| if No (P) |
| or else (K not in N_Subexpr and then Comes_From_Source (P)) |
| then |
| return True; |
| |
| -- Or/Or Else case, where test is part of the right operand, or is |
| -- part of one of the actions associated with the right operand, and |
| -- the left operand is an equality test. |
| |
| elsif K = N_Op_Or then |
| exit when N = Right_Opnd (P) |
| and then Nkind (Left_Expression (P)) = N_Op_Eq; |
| |
| elsif K = N_Or_Else then |
| exit when (N = Right_Opnd (P) |
| or else |
| (Is_List_Member (N) |
| and then List_Containing (N) = Actions (P))) |
| and then Nkind (Left_Expression (P)) = N_Op_Eq; |
| |
| -- Similar test for the And/And then case, where the left operand |
| -- is an inequality test. |
| |
| elsif K = N_Op_And then |
| exit when N = Right_Opnd (P) |
| and then Nkind (Left_Expression (P)) = N_Op_Ne; |
| |
| elsif K = N_And_Then then |
| exit when (N = Right_Opnd (P) |
| or else |
| (Is_List_Member (N) |
| and then List_Containing (N) = Actions (P))) |
| and then Nkind (Left_Expression (P)) = N_Op_Ne; |
| end if; |
| |
| N := P; |
| end loop; |
| |
| -- If we fall through the loop, then we have a conditional with an |
| -- appropriate test as its left operand, so look further. |
| |
| L := Left_Expression (P); |
| |
| -- L is an "=" or "/=" operator: extract its operands |
| |
| R := Right_Opnd (L); |
| L := Left_Opnd (L); |
| |
| -- Left operand of test must match original variable |
| |
| if Nkind (L) not in N_Has_Entity or else Entity (L) /= Entity (Nod) then |
| return True; |
| end if; |
| |
| -- Right operand of test must be key value (zero or null) |
| |
| case Check is |
| when Access_Check => |
| if not Known_Null (R) then |
| return True; |
| end if; |
| |
| when Division_Check => |
| if not Compile_Time_Known_Value (R) |
| or else Expr_Value (R) /= Uint_0 |
| then |
| return True; |
| end if; |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| -- Here we have the optimizable case, warn if not short-circuited |
| |
| if K = N_Op_And or else K = N_Op_Or then |
| Error_Msg_Warn := SPARK_Mode /= On; |
| |
| case Check is |
| when Access_Check => |
| if GNATprove_Mode then |
| Error_Msg_N |
| ("Constraint_Error might have been raised (access check)", |
| Parent (Nod)); |
| else |
| Error_Msg_N |
| ("Constraint_Error may be raised (access check)??", |
| Parent (Nod)); |
| end if; |
| |
| when Division_Check => |
| if GNATprove_Mode then |
| Error_Msg_N |
| ("Constraint_Error might have been raised (zero divide)", |
| Parent (Nod)); |
| else |
| Error_Msg_N |
| ("Constraint_Error may be raised (zero divide)??", |
| Parent (Nod)); |
| end if; |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| if K = N_Op_And then |
| Error_Msg_N -- CODEFIX |
| ("use `AND THEN` instead of AND??", P); |
| else |
| Error_Msg_N -- CODEFIX |
| ("use `OR ELSE` instead of OR??", P); |
| end if; |
| |
| -- If not short-circuited, we need the check |
| |
| return True; |
| |
| -- If short-circuited, we can omit the check |
| |
| else |
| return False; |
| end if; |
| end Check_Needed; |
| |
| ----------------------------------- |
| -- Check_Valid_Lvalue_Subscripts -- |
| ----------------------------------- |
| |
| procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is |
| begin |
| -- Skip this if range checks are suppressed |
| |
| if Range_Checks_Suppressed (Etype (Expr)) then |
| return; |
| |
| -- Only do this check for expressions that come from source. We assume |
| -- that expander generated assignments explicitly include any necessary |
| -- checks. Note that this is not just an optimization, it avoids |
| -- infinite recursions. |
| |
| elsif not Comes_From_Source (Expr) then |
| return; |
| |
| -- For a selected component, check the prefix |
| |
| elsif Nkind (Expr) = N_Selected_Component then |
| Check_Valid_Lvalue_Subscripts (Prefix (Expr)); |
| return; |
| |
| -- Case of indexed component |
| |
| elsif Nkind (Expr) = N_Indexed_Component then |
| Apply_Subscript_Validity_Checks (Expr); |
| |
| -- Prefix may itself be or contain an indexed component, and these |
| -- subscripts need checking as well. |
| |
| Check_Valid_Lvalue_Subscripts (Prefix (Expr)); |
| end if; |
| end Check_Valid_Lvalue_Subscripts; |
| |
| ---------------------------------- |
| -- Null_Exclusion_Static_Checks -- |
| ---------------------------------- |
| |
| procedure Null_Exclusion_Static_Checks |
| (N : Node_Id; |
| Comp : Node_Id := Empty; |
| Array_Comp : Boolean := False) |
| is |
| Has_Null : constant Boolean := Has_Null_Exclusion (N); |
| Kind : constant Node_Kind := Nkind (N); |
| Error_Nod : Node_Id; |
| Expr : Node_Id; |
| Typ : Entity_Id; |
| |
| begin |
| pragma Assert |
| (Kind in N_Component_Declaration |
| | N_Discriminant_Specification |
| | N_Function_Specification |
| | N_Object_Declaration |
| | N_Parameter_Specification); |
| |
| if Kind = N_Function_Specification then |
| Typ := Etype (Defining_Entity (N)); |
| else |
| Typ := Etype (Defining_Identifier (N)); |
| end if; |
| |
| case Kind is |
| when N_Component_Declaration => |
| if Present (Access_Definition (Component_Definition (N))) then |
| Error_Nod := Component_Definition (N); |
| else |
| Error_Nod := Subtype_Indication (Component_Definition (N)); |
| end if; |
| |
| when N_Discriminant_Specification => |
| Error_Nod := Discriminant_Type (N); |
| |
| when N_Function_Specification => |
| Error_Nod := Result_Definition (N); |
| |
| when N_Object_Declaration => |
| Error_Nod := Object_Definition (N); |
| |
| when N_Parameter_Specification => |
| Error_Nod := Parameter_Type (N); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| if Has_Null then |
| |
| -- Enforce legality rule 3.10 (13): A null exclusion can only be |
| -- applied to an access [sub]type. |
| |
| if not Is_Access_Type (Typ) then |
| Error_Msg_N |
| ("`NOT NULL` allowed only for an access type", Error_Nod); |
| |
| -- Enforce legality rule RM 3.10(14/1): A null exclusion can only |
| -- be applied to a [sub]type that does not exclude null already. |
| |
| elsif Can_Never_Be_Null (Typ) and then Comes_From_Source (Typ) then |
| Error_Msg_NE |
| ("`NOT NULL` not allowed (& already excludes null)", |
| Error_Nod, Typ); |
| end if; |
| end if; |
| |
| -- Check that null-excluding objects are always initialized, except for |
| -- deferred constants, for which the expression will appear in the full |
| -- declaration. |
| |
| if Kind = N_Object_Declaration |
| and then No (Expression (N)) |
| and then not Constant_Present (N) |
| and then not No_Initialization (N) |
| then |
| if Present (Comp) then |
| |
| -- Specialize the warning message to indicate that we are dealing |
| -- with an uninitialized composite object that has a defaulted |
| -- null-excluding component. |
| |
| Error_Msg_Name_1 := Chars (Defining_Identifier (Comp)); |
| Error_Msg_Name_2 := Chars (Defining_Identifier (N)); |
| |
| Discard_Node |
| (Compile_Time_Constraint_Error |
| (N => N, |
| Msg => |
| "(Ada 2005) null-excluding component % of object % must " |
| & "be initialized??", |
| Ent => Defining_Identifier (Comp))); |
| |
| -- This is a case of an array with null-excluding components, so |
| -- indicate that in the warning. |
| |
| elsif Array_Comp then |
| Discard_Node |
| (Compile_Time_Constraint_Error |
| (N => N, |
| Msg => |
| "(Ada 2005) null-excluding array components must " |
| & "be initialized??", |
| Ent => Defining_Identifier (N))); |
| |
| -- Normal case of object of a null-excluding access type |
| |
| else |
| -- Add an expression that assigns null. This node is needed by |
| -- Apply_Compile_Time_Constraint_Error, which will replace this |
| -- with a Constraint_Error node. |
| |
| Set_Expression (N, Make_Null (Sloc (N))); |
| Set_Etype (Expression (N), Etype (Defining_Identifier (N))); |
| |
| Apply_Compile_Time_Constraint_Error |
| (N => Expression (N), |
| Msg => |
| "(Ada 2005) null-excluding objects must be initialized??", |
| Reason => CE_Null_Not_Allowed); |
| end if; |
| 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 an N_Constraint_Error node. |
| |
| if Kind /= N_Function_Specification then |
| Expr := Expression (N); |
| |
| if Present (Expr) and then Known_Null (Expr) then |
| case Kind is |
| when N_Component_Declaration |
| | N_Discriminant_Specification |
| => |
| Apply_Compile_Time_Constraint_Error |
| (N => Expr, |
| Msg => |
| "(Ada 2005) NULL not allowed in null-excluding " |
| & "components??", |
| Reason => CE_Null_Not_Allowed); |
| |
| when N_Object_Declaration => |
| Apply_Compile_Time_Constraint_Error |
| (N => Expr, |
| Msg => |
| "(Ada 2005) NULL not allowed in null-excluding " |
| & "objects??", |
| Reason => CE_Null_Not_Allowed); |
| |
| when N_Parameter_Specification => |
| Apply_Compile_Time_Constraint_Error |
| (N => Expr, |
| Msg => |
| "(Ada 2005) NULL not allowed in null-excluding " |
| & "formals??", |
| Reason => CE_Null_Not_Allowed); |
| |
| when others => |
| null; |
| end case; |
| end if; |
| end if; |
| end Null_Exclusion_Static_Checks; |
| |
| ------------------------------------- |
| -- Compute_Range_For_Arithmetic_Op -- |
| ------------------------------------- |
| |
| procedure Compute_Range_For_Arithmetic_Op |
| (Op : Node_Kind; |
| Lo_Left : Uint; |
| Hi_Left : Uint; |
| Lo_Right : Uint; |
| Hi_Right : Uint; |
| OK : out Boolean; |
| Lo : out Uint; |
| Hi : out Uint) |
| is |
| -- Use local variables for possible adjustments |
| |
| Llo : Uint renames Lo_Left; |
| Lhi : Uint renames Hi_Left; |
| Rlo : Uint := Lo_Right; |
| Rhi : Uint := Hi_Right; |
| |
| begin |
| -- We will compute a range for the result in almost all cases |
| |
| OK := True; |
| |
| case Op is |
| |
| -- Absolute value |
| |
| when N_Op_Abs => |
| Lo := Uint_0; |
| Hi := UI_Max (abs Rlo, abs Rhi); |
| |
| -- Addition |
| |
| when N_Op_Add => |
| Lo := Llo + Rlo; |
| Hi := Lhi + Rhi; |
| |
| -- Division |
| |
| when N_Op_Divide => |
| |
| -- If the right operand can only be zero, set 0..0 |
| |
| if Rlo = 0 and then Rhi = 0 then |
| Lo := Uint_0; |
| Hi := Uint_0; |
| |
| -- Possible bounds of division must come from dividing end |
| -- values of the input ranges (four possibilities), provided |
| -- zero is not included in the possible values of the right |
| -- operand. |
| |
| -- Otherwise, we just consider two intervals of values for |
| -- the right operand: the interval of negative values (up to |
| -- -1) and the interval of positive values (starting at 1). |
| -- Since division by 1 is the identity, and division by -1 |
| -- is negation, we get all possible bounds of division in that |
| -- case by considering: |
| -- - all values from the division of end values of input |
| -- ranges; |
| -- - the end values of the left operand; |
| -- - the negation of the end values of the left operand. |
| |
| else |
| declare |
| Mrk : constant Uintp.Save_Mark := Mark; |
| -- Mark so we can release the RR and Ev values |
| |
| Ev1 : Uint; |
| Ev2 : Uint; |
| Ev3 : Uint; |
| Ev4 : Uint; |
| |
| begin |
| -- Discard extreme values of zero for the divisor, since |
| -- they will simply result in an exception in any case. |
| |
| if Rlo = 0 then |
| Rlo := Uint_1; |
| elsif Rhi = 0 then |
| Rhi := -Uint_1; |
| end if; |
| |
| -- Compute possible bounds coming from dividing end |
| -- values of the input ranges. |
| |
| Ev1 := Llo / Rlo; |
| Ev2 := Llo / Rhi; |
| Ev3 := Lhi / Rlo; |
| Ev4 := Lhi / Rhi; |
| |
| Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4)); |
| Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4)); |
| |
| -- If the right operand can be both negative or positive, |
| -- include the end values of the left operand in the |
| -- extreme values, as well as their negation. |
| |
| if Rlo < 0 and then Rhi > 0 then |
| Ev1 := Llo; |
| Ev2 := -Llo; |
| Ev3 := Lhi; |
| Ev4 := -Lhi; |
| |
| Lo := UI_Min (Lo, |
| UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4))); |
| Hi := UI_Max (Hi, |
| UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4))); |
| end if; |
| |
| -- Release the RR and Ev values |
| |
| Release_And_Save (Mrk, Lo, Hi); |
| end; |
| end if; |
| |
| -- Exponentiation |
| |
| when N_Op_Expon => |
| |
| -- Discard negative values for the exponent, since they will |
| -- simply result in an exception in any case. |
| |
| if Rhi < 0 then |
| Rhi := Uint_0; |
| elsif Rlo < 0 then |
| Rlo := Uint_0; |
| end if; |
| |
| -- Estimate number of bits in result before we go computing |
| -- giant useless bounds. Basically the number of bits in the |
| -- result is the number of bits in the base multiplied by the |
| -- value of the exponent. If this is big enough that the result |
| -- definitely won't fit in Long_Long_Integer, return immediately |
| -- and avoid computing giant bounds. |
| |
| -- The comparison here is approximate, but conservative, it |
| -- only clicks on cases that are sure to exceed the bounds. |
| |
| if Num_Bits (UI_Max (abs Llo, abs Lhi)) * Rhi + 1 > 100 then |
| Lo := No_Uint; |
| Hi := No_Uint; |
| OK := False; |
| return; |
| |
| -- If right operand is zero then result is 1 |
| |
| elsif Rhi = 0 then |
| Lo := Uint_1; |
| Hi := Uint_1; |
| |
| else |
| -- High bound comes either from exponentiation of largest |
| -- positive value to largest exponent value, or from |
| -- the exponentiation of most negative value to an |
| -- even exponent. |
| |
| declare |
| Hi1, Hi2 : Uint; |
| |
| begin |
| if Lhi > 0 then |
| Hi1 := Lhi ** Rhi; |
| else |
| Hi1 := Uint_0; |
| end if; |
| |
| if Llo < 0 then |
| if Rhi mod 2 = 0 then |
| Hi2 := Llo ** Rhi; |
| else |
| Hi2 := Llo ** (Rhi - 1); |
| end if; |
| else |
| Hi2 := Uint_0; |
| end if; |
| |
| Hi := UI_Max (Hi1, Hi2); |
| end; |
| |
| -- Result can only be negative if base can be negative |
| |
| if Llo < 0 then |
| if Rhi mod 2 = 0 then |
| Lo := Llo ** (Rhi - 1); |
| else |
| Lo := Llo ** Rhi; |
| end if; |
| |
| -- Otherwise low bound is minimum ** minimum |
| |
| else |
| Lo := Llo ** Rlo; |
| end if; |
| end if; |
| |
| -- Negation |
| |
| when N_Op_Minus => |
| Lo := -Rhi; |
| Hi := -Rlo; |
| |
| -- Mod |
| |
| when N_Op_Mod => |
| declare |
| Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1; |
| -- This is the maximum absolute value of the result |
| |
| begin |
| Lo := Uint_0; |
| Hi := Uint_0; |
| |
| -- The result depends only on the sign and magnitude of |
| -- the right operand, it does not depend on the sign or |
| -- magnitude of the left operand. |
| |
| if Rlo < 0 then |
| Lo := -Maxabs; |
| end if; |
| |
| if Rhi > 0 then |
| Hi := Maxabs; |
| end if; |
| end; |
| |
| -- Multiplication |
| |
| when N_Op_Multiply => |
| |
| -- Possible bounds of multiplication must come from multiplying |
| -- end values of the input ranges (four possibilities). |
| |
| declare |
| Mrk : constant Uintp.Save_Mark := Mark; |
| -- Mark so we can release the Ev values |
| |
| Ev1 : constant Uint := Llo * Rlo; |
| Ev2 : constant Uint := Llo * Rhi; |
| Ev3 : constant Uint := Lhi * Rlo; |
| Ev4 : constant Uint := Lhi * Rhi; |
| |
| begin |
| Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4)); |
| Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4)); |
| |
| -- Release the Ev values |
| |
| Release_And_Save (Mrk, Lo, Hi); |
| end; |
| |
| -- Plus operator (affirmation) |
| |
| when N_Op_Plus => |
| Lo := Rlo; |
| Hi := Rhi; |
| |
| -- Remainder |
| |
| when N_Op_Rem => |
| declare |
| Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1; |
| -- This is the maximum absolute value of the result. Note |
| -- that the result range does not depend on the sign of the |
| -- right operand. |
| |
| begin |
| Lo := Uint_0; |
| Hi := Uint_0; |
| |
| -- Case of left operand negative, which results in a range |
| -- of -Maxabs .. 0 for those negative values. If there are |
| -- no negative values then Lo value of result is always 0. |
| |
| if Llo < 0 then |
| Lo := -Maxabs; |
| end if; |
| |
| -- Case of left operand positive |
| |
| if Lhi > 0 then |
| Hi := Maxabs; |
| end if; |
| end; |
| |
| -- Subtract |
| |
| when N_Op_Subtract => |
| Lo := Llo - Rhi; |
| Hi := Lhi - Rlo; |
| |
| -- Nothing else should be possible |
| |
| when others => |
| raise Program_Error; |
| end case; |
| end Compute_Range_For_Arithmetic_Op; |
| |
| ---------------------------------- |
| -- Conditional_Statements_Begin -- |
| ---------------------------------- |
| |
| procedure Conditional_Statements_Begin is |
| begin |
| Saved_Checks_TOS := Saved_Checks_TOS + 1; |
| |
| -- If stack overflows, kill all checks, that way we know to simply reset |
| -- the number of saved checks to zero on return. This should never occur |
| -- in practice. |
| |
| if Saved_Checks_TOS > Saved_Checks_Stack'Last then |
| Kill_All_Checks; |
| |
| -- In the normal case, we just make a new stack entry saving the current |
| -- number of saved checks for a later restore. |
| |
| else |
| Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks; |
| |
| if Debug_Flag_CC then |
| w ("Conditional_Statements_Begin: Num_Saved_Checks = ", |
| Num_Saved_Checks); |
| end if; |
| end if; |
| end Conditional_Statements_Begin; |
| |
| -------------------------------- |
| -- Conditional_Statements_End -- |
| -------------------------------- |
| |
| procedure Conditional_Statements_End is |
| begin |
| pragma Assert (Saved_Checks_TOS > 0); |
| |
| -- If the saved checks stack overflowed, then we killed all checks, so |
| -- setting the number of saved checks back to zero is correct. This |
| -- should never occur in practice. |
| |
| if Saved_Checks_TOS > Saved_Checks_Stack'Last then |
| Num_Saved_Checks := 0; |
| |
| -- In the normal case, restore the number of saved checks from the top |
| -- stack entry. |
| |
| else |
| Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS); |
| |
| if Debug_Flag_CC then |
| w ("Conditional_Statements_End: Num_Saved_Checks = ", |
| Num_Saved_Checks); |
| end if; |
| end if; |
| |
| Saved_Checks_TOS := Saved_Checks_TOS - 1; |
| end Conditional_Statements_End; |
| |
| ------------------------- |
| -- Convert_From_Bignum -- |
| ------------------------- |
| |
| function Convert_From_Bignum (N : Node_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| begin |
| pragma Assert (Is_RTE (Etype (N), RE_Bignum)); |
| |
| -- Construct call From Bignum |
| |
| return |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_From_Bignum), Loc), |
| Parameter_Associations => New_List (Relocate_Node (N))); |
| end Convert_From_Bignum; |
| |
| ----------------------- |
| -- Convert_To_Bignum -- |
| ----------------------- |
| |
| function Convert_To_Bignum (N : Node_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| begin |
| -- Nothing to do if Bignum already except call Relocate_Node |
| |
| if Is_RTE (Etype (N), RE_Bignum) then |
| return Relocate_Node (N); |
| |
| -- Otherwise construct call to To_Bignum, converting the operand to the |
| -- required Long_Long_Integer form. |
| |
| else |
| pragma Assert (Is_Signed_Integer_Type (Etype (N))); |
| return |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_To_Bignum), Loc), |
| Parameter_Associations => New_List ( |
| Convert_To (Standard_Long_Long_Integer, Relocate_Node (N)))); |
| end if; |
| end Convert_To_Bignum; |
| |
| --------------------- |
| -- Determine_Range -- |
| --------------------- |
| |
| Cache_Size : constant := 2 ** 10; |
| type Cache_Index is range 0 .. Cache_Size - 1; |
| -- Determine size of below cache (power of 2 is more efficient) |
| |
| Determine_Range_Cache_N : array (Cache_Index) of Node_Id; |
| Determine_Range_Cache_O : array (Cache_Index) of Node_Id; |
| Determine_Range_Cache_V : array (Cache_Index) of Boolean; |
| Determine_Range_Cache_Lo : array (Cache_Index) of Uint; |
| Determine_Range_Cache_Hi : array (Cache_Index) of Uint; |
| Determine_Range_Cache_Lo_R : array (Cache_Index) of Ureal; |
| Determine_Range_Cache_Hi_R : array (Cache_Index) of Ureal; |
| -- The above arrays are used to implement a small direct cache for |
| -- Determine_Range and Determine_Range_R calls. Because of the way these |
| -- subprograms recursively traces subexpressions, and because overflow |
| -- checking calls the routine on the way up the tree, a quadratic behavior |
| -- can otherwise be encountered in large expressions. The cache entry for |
| -- node N is stored in the (N mod Cache_Size) entry, and can be validated |
| -- by checking the actual node value stored there. The Range_Cache_O array |
| -- records the setting of Original_Node (N) so that the cache entry does |
| -- not become stale when the node N is rewritten. The Range_Cache_V array |
| -- records the setting of Assume_Valid for the cache entry. |
| |
| procedure Determine_Range |
| (N : Node_Id; |
| OK : out Boolean; |
| Lo : out Uint; |
| Hi : out Uint; |
| Assume_Valid : Boolean := False) |
| is |
| Kind : constant Node_Kind := Nkind (N); |
| -- Kind of node |
| |
| function Half_Address_Space return Uint; |
| -- The size of half the total addressable memory space in storage units |
| -- (minus one, so that the size fits in a signed integer whose size is |
| -- System_Address_Size, which helps in various cases). |
| |
| ------------------------ |
| -- Half_Address_Space -- |
| ------------------------ |
| |
| function Half_Address_Space return Uint is |
| begin |
| return Uint_2 ** (System_Address_Size - 1) - 1; |
| end Half_Address_Space; |
| |
| -- Local variables |
| |
| Typ : Entity_Id := Etype (N); |
| -- Type to use, may get reset to base type for possibly invalid entity |
| |
| Lo_Left : Uint := No_Uint; |
| Hi_Left : Uint := No_Uint; |
| -- Lo and Hi bounds of left operand |
| |
| Lo_Right : Uint := No_Uint; |
| Hi_Right : Uint := No_Uint; |
| -- Lo and Hi bounds of right (or only) operand |
| |
| Bound : Node_Id; |
| -- Temp variable used to hold a bound node |
| |
| Hbound : Uint; |
| -- High bound of base type of expression |
| |
| Lor : Uint; |
| Hir : Uint; |
| -- Refined values for low and high bounds, after tightening |
| |
| OK1 : Boolean; |
| -- Used in lower level calls to indicate if call succeeded |
| |
| Cindex : Cache_Index; |
| -- Used to search cache |
| |
| Btyp : Entity_Id; |
| -- Base type |
| |
| -- Start of processing for Determine_Range |
| |
| begin |
| -- Prevent junk warnings by initializing range variables |
| |
| Lo := No_Uint; |
| Hi := No_Uint; |
| Lor := No_Uint; |
| Hir := No_Uint; |
| |
| -- For temporary constants internally generated to remove side effects |
| -- we must use the corresponding expression to determine the range of |
| -- the expression. But note that the expander can also generate |
| -- constants in other cases, including deferred constants. |
| |
| if Is_Entity_Name (N) |
| and then Nkind (Parent (Entity (N))) = N_Object_Declaration |
| and then Ekind (Entity (N)) = E_Constant |
| and then Is_Internal_Name (Chars (Entity (N))) |
| then |
| if Present (Expression (Parent (Entity (N)))) then |
| Determine_Range |
| (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid); |
| |
| elsif Present (Full_View (Entity (N))) then |
| Determine_Range |
| (Expression (Parent (Full_View (Entity (N)))), |
| OK, Lo, Hi, Assume_Valid); |
| |
| else |
| OK := False; |
| end if; |
| return; |
| end if; |
| |
| -- If type is not defined, we can't determine its range |
| |
| if No (Typ) |
| |
| -- We don't deal with anything except discrete types |
| |
| or else not Is_Discrete_Type (Typ) |
| |
| -- Don't deal with enumerated types with non-standard representation |
| |
| or else (Is_Enumeration_Type (Typ) |
| and then Present (Enum_Pos_To_Rep |
| (Implementation_Base_Type (Typ)))) |
| |
| -- Ignore type for which an error has been posted, since range in |
| -- this case may well be a bogosity deriving from the error. Also |
| -- ignore if error posted on the reference node. |
| |
| or else Error_Posted (N) or else Error_Posted (Typ) |
| then |
| OK := False; |
| return; |
| end if; |
| |
| -- For all other cases, we can determine the range |
| |
| OK := True; |
| |
| -- If value is compile time known, then the possible range is the one |
| -- value that we know this expression definitely has. |
| |
| if Compile_Time_Known_Value (N) then |
| Lo := Expr_Value (N); |
| Hi := Lo; |
| return; |
| end if; |
| |
| -- Return if already in the cache |
| |
| Cindex := Cache_Index (N mod Cache_Size); |
| |
| if Determine_Range_Cache_N (Cindex) = N |
| and then |
| Determine_Range_Cache_O (Cindex) = Original_Node (N) |
| and then |
| Determine_Range_Cache_V (Cindex) = Assume_Valid |
| then |
| Lo := Determine_Range_Cache_Lo (Cindex); |
| Hi := Determine_Range_Cache_Hi (Cindex); |
| return; |
| end if; |
| |
| -- Otherwise, start by finding the bounds of the type of the expression, |
| -- the value cannot be outside this range (if it is, then we have an |
| -- overflow situation, which is a separate check, we are talking here |
| -- only about the expression value). |
| |
| -- First a check, never try to find the bounds of a generic type, since |
| -- these bounds are always junk values, and it is only valid to look at |
| -- the bounds in an instance. |
| |
| if Is_Generic_Type (Typ) then |
| OK := False; |
| return; |
| end if; |
| |
| -- First step, change to use base type unless we know the value is valid |
| |
| if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N))) |
| or else Assume_No_Invalid_Values |
| or else Assume_Valid |
| then |
| -- If this is a known valid constant with a nonstatic value, it may |
| -- have inherited a narrower subtype from its initial value; use this |
| -- saved subtype (see sem_ch3.adb). |
| |
| if Is_Entity_Name (N) |
| and then Ekind (Entity (N)) = E_Constant |
| and then Present (Actual_Subtype (Entity (N))) |
| then |
| Typ := Actual_Subtype (Entity (N)); |
| end if; |
| |
| else |
| Typ := Underlying_Type (Base_Type (Typ)); |
| end if; |
| |
| -- Retrieve the base type. Handle the case where the base type is a |
| -- private enumeration type. |
| |
| Btyp := Base_Type (Typ); |
| |
| if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then |
| Btyp := Full_View (Btyp); |
| end if; |
| |
| -- We use the actual bound unless it is dynamic, in which case use the |
| -- corresponding base type bound if possible. If we can't get a bound |
| -- then we figure we can't determine the range (a peculiar case, that |
| -- perhaps cannot happen, but there is no point in bombing in this |
| -- optimization circuit). |
| |
| -- First the low bound |
| |
| Bound := Type_Low_Bound (Typ); |
| |
| if Compile_Time_Known_Value (Bound) then |
| Lo := Expr_Value (Bound); |
| |
| elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then |
| Lo := Expr_Value (Type_Low_Bound (Btyp)); |
| |
| else |
| OK := False; |
| return; |
| end if; |
| |
| -- Now the high bound |
| |
| Bound := Type_High_Bound (Typ); |
| |
| -- We need the high bound of the base type later on, and this should |
| -- always be compile time known. Again, it is not clear that this |
| -- can ever be false, but no point in bombing. |
| |
| if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then |
| Hbound := Expr_Value (Type_High_Bound (Btyp)); |
| Hi := Hbound; |
| |
| else |
| OK := False; |
| return; |
| end if; |
| |
| -- If we have a static subtype, then that may have a tighter bound so |
| -- use the upper bound of the subtype instead in this case. |
| |
| if Compile_Time_Known_Value (Bound) then |
| Hi := Expr_Value (Bound); |
| end if; |
| |
| -- We may be able to refine this value in certain situations. If any |
| -- refinement is possible, then Lor and Hir are set to possibly tighter |
| -- bounds, and OK1 is set to True. |
| |
| case Kind is |
| |
| -- Unary operation case |
| |
| when N_Op_Abs |
| | N_Op_Minus |
| | N_Op_Plus |
| => |
| Determine_Range |
| (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid); |
| |
| if OK1 then |
| Compute_Range_For_Arithmetic_Op |
| (Kind, Lo_Left, Hi_Left, Lo_Right, Hi_Right, OK1, Lor, Hir); |
| end if; |
| |
| -- Binary operation case |
| |
| when N_Op_Add |
| | N_Op_Divide |
| | N_Op_Expon |
| | N_Op_Mod |
| | N_Op_Multiply |
| | N_Op_Rem |
| | N_Op_Subtract |
| => |
| Determine_Range |
| (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid); |
| |
| if OK1 then |
| Determine_Range |
| (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid); |
| end if; |
| |
| if OK1 then |
| Compute_Range_For_Arithmetic_Op |
| (Kind, Lo_Left, Hi_Left, Lo_Right, Hi_Right, OK1, Lor, Hir); |
| end if; |
| |
| -- Attribute reference cases |
| |
| when N_Attribute_Reference => |
| case Get_Attribute_Id (Attribute_Name (N)) is |
| |
| -- For Min/Max attributes, we can refine the range using the |
| -- possible range of values of the attribute expressions. |
| |
| when Attribute_Min |
| | Attribute_Max |
| => |
| Determine_Range |
| (First (Expressions (N)), |
| OK1, Lo_Left, Hi_Left, Assume_Valid); |
| |
| if OK1 then |
| Determine_Range |
| (Next (First (Expressions (N))), |
| OK1, Lo_Right, Hi_Right, Assume_Valid); |
| end if; |
| |
| if OK1 then |
| Lor := UI_Min (Lo_Left, Lo_Right); |
| Hir := UI_Max (Hi_Left, Hi_Right); |
| end if; |
| |
| -- For Pos/Val attributes, we can refine the range using the |
| -- possible range of values of the attribute expression. |
| |
| when Attribute_Pos |
| | Attribute_Val |
| => |
| Determine_Range |
| (First (Expressions (N)), OK1, Lor, Hir, Assume_Valid); |
| |
| -- For Length and Range_Length attributes, use the bounds of |
| -- the (corresponding index) type to refine the range. |
| |
| when Attribute_Length |
| | Attribute_Range_Length |
| => |
| declare |
| Ptyp : Entity_Id; |
| Ityp : Entity_Id; |
| |
| LL, LU : Uint; |
| UL, UU : Uint; |
| |
| begin |
| Ptyp := Etype (Prefix (N)); |
| if Is_Access_Type (Ptyp) then |
| Ptyp := Designated_Type (Ptyp); |
| end if; |
| |
| -- For string literal, we know exact value |
| |
| if Ekind (Ptyp) = E_String_Literal_Subtype then |
| OK := True; |
| Lo := String_Literal_Length (Ptyp); |
| Hi := String_Literal_Length (Ptyp); |
| return; |
| end if; |
| |
| if Is_Array_Type (Ptyp) then |
| Ityp := Get_Index_Subtype (N); |
| else |
| Ityp := Ptyp; |
| end if; |
| |
| -- If the (index) type is a formal type or derived from |
| -- one, the bounds are not static. |
| |
| if Is_Generic_Type (Root_Type (Ityp)) then |
| OK := False; |
| return; |
| end if; |
| |
| Determine_Range |
| (Type_Low_Bound (Ityp), OK1, LL, LU, Assume_Valid); |
| |
| if OK1 then |
| Determine_Range |
| (Type_High_Bound (Ityp), OK1, UL, UU, Assume_Valid); |
| |
| if OK1 then |
| -- The maximum value for Length is the biggest |
| -- possible gap between the values of the bounds. |
| -- But of course, this value cannot be negative. |
| |
| Hir := UI_Max (Uint_0, UU - LL + 1); |
| |
| -- For a constrained array, the minimum value for |
| -- Length is taken from the actual value of the |
| -- bounds, since the index will be exactly of this |
| -- subtype. |
| |
| if Is_Constrained (Ptyp) then |
| Lor := UI_Max (Uint_0, UL - LU + 1); |
| |
| -- For an unconstrained array, the minimum value |
| -- for length is always zero. |
| |
| else |
| Lor := Uint_0; |
| end if; |
| end if; |
| end if; |
| |
| -- Small optimization: the maximum size in storage units |
| -- an object can have with GNAT is half of the address |
| -- space, so we can bound the length of an array declared |
| -- in Interfaces (or its children) because its component |
| -- size is at least the storage unit and it is meant to |
| -- be used to interface actual array objects. |
| |
| if Is_Array_Type (Ptyp) then |
| declare |
| S : constant Entity_Id := Scope (Base_Type (Ptyp)); |
| begin |
| if Is_RTU (S, Interfaces) |
| or else (S /= Standard_Standard |
| and then Is_RTU (Scope (S), Interfaces)) |
| then |
| Hir := UI_Min (Hir, Half_Address_Space); |
| end if; |
| end; |
| end if; |
| end; |
| |
| -- The maximum default alignment is quite low, but GNAT accepts |
| -- alignment clauses that are fairly large, but not as large as |
| -- the maximum size of objects, see below. |
| |
| when Attribute_Alignment => |
| Lor := Uint_0; |
| Hir := Half_Address_Space; |
| OK1 := True; |
| |
| -- The attribute should have been folded if a component clause |
| -- was specified, so we assume there is none. |
| |
| when Attribute_Bit |
| | Attribute_First_Bit |
| => |
| Lor := Uint_0; |
| Hir := UI_From_Int (System_Storage_Unit - 1); |
| OK1 := True; |
| |
| -- Likewise about the component clause. Note that Last_Bit |
| -- yields -1 for a field of size 0 if First_Bit is 0. |
| |
| when Attribute_Last_Bit => |
| Lor := Uint_Minus_1; |
| Hir := Hi; |
| OK1 := True; |
| |
| -- Likewise about the component clause for Position. The |
| -- maximum size in storage units that an object can have |
| -- with GNAT is half of the address space. |
| |
| when Attribute_Max_Size_In_Storage_Elements |
| | Attribute_Position |
| => |
| Lor := Uint_0; |
| Hir := Half_Address_Space; |
| OK1 := True; |
| |
| -- These attributes yield a nonnegative value (we do not set |
| -- the maximum value because it is too large to be useful). |
| |
| when Attribute_Bit_Position |
| | Attribute_Component_Size |
| | Attribute_Object_Size |
| | Attribute_Size |
| | Attribute_Value_Size |
| => |
| Lor := Uint_0; |
| Hir := Hi; |
| OK1 := True; |
| |
| -- The maximum size is the sum of twice the size of the largest |
| -- integer for every dimension, rounded up to the next multiple |
| -- of the maximum alignment, but we add instead of rounding. |
| |
| when Attribute_Descriptor_Size => |
| declare |
| Max_Align : constant Pos := |
| Maximum_Alignment * System_Storage_Unit; |
| Max_Size : constant Uint := |
| 2 * Esize (Universal_Integer); |
| Ndims : constant Pos := |
| Number_Dimensions (Etype (Prefix (N))); |
| begin |
| Lor := Uint_0; |
| Hir := Max_Size * Ndims + Max_Align; |
| OK1 := True; |
| end; |
| |
| -- No special handling for other attributes for now |
| |
| when others => |
| OK1 := False; |
| |
| end case; |
| |
| when N_Type_Conversion => |
| -- For a type conversion, we can try to refine the range using the |
| -- converted value. |
| |
| Determine_Range_To_Discrete |
| (Expression (N), OK1, Lor, Hir, Conversion_OK (N), Assume_Valid); |
| |
| -- Nothing special to do for all other expression kinds |
| |
| when others => |
| OK1 := False; |
| Lor := No_Uint; |
| Hir := No_Uint; |
| end case; |
| |
| -- At this stage, if OK1 is true, then we know that the actual result of |
| -- the computed expression is in the range Lor .. Hir. We can use this |
| -- to restrict the possible range of results. |
| |
| if OK1 then |
| |
| -- If the refined value of the low bound is greater than the type |
| -- low bound, then reset it to the more restrictive value. However, |
| -- we do NOT do this for the case of a modular type where the |
| -- possible upper bound on the value is above the base type high |
| -- bound, because that means the result could wrap. |
| -- Same applies for the lower bound if it is negative. |
| |
| if Is_Modular_Integer_Type (Typ) then |
| if Lor > Lo and then Hir <= Hbound then |
| Lo := Lor; |
| end if; |
| |
| if Hir < Hi and then Lor >= Uint_0 then |
| Hi := Hir; |
| end if; |
| |
| else |
| if Lor > Hi or else Hir < Lo then |
| |
| -- If the ranges are disjoint, return the computed range. |
| |
| -- The current range-constraining logic would require returning |
| -- the base type's bounds. However, this would miss an |
| -- opportunity to warn about out-of-range values for some cases |
| -- (e.g. when type's upper bound is equal to base type upper |
| -- bound). |
| |
| -- The alternative of always returning the computed values, |
| -- even when ranges are intersecting, has unwanted effects |
| -- (mainly useless constraint checks are inserted) in the |
| -- Enable_Overflow_Check and Apply_Scalar_Range_Check as these |
| -- bounds have a special interpretation. |
| |
| Lo := Lor; |
| Hi := Hir; |
| else |
| |
| -- If the ranges Lor .. Hir and Lo .. Hi intersect, try to |
| -- refine the returned range. |
| |
| if Lor > Lo then |
| Lo := Lor; |
| end if; |
| |
| if Hir < Hi then |
| Hi := Hir; |
| end if; |
| end if; |
| end if; |
| end if; |
| |
| -- Set cache entry for future call and we are all done |
| |
| Determine_Range_Cache_N (Cindex) := N; |
| Determine_Range_Cache_O (Cindex) := Original_Node (N); |
| Determine_Range_Cache_V (Cindex) := Assume_Valid; |
| Determine_Range_Cache_Lo (Cindex) := Lo; |
| Determine_Range_Cache_Hi (Cindex) := Hi; |
| return; |
| |
| -- If any exception occurs, it means that we have some bug in the compiler, |
| -- possibly triggered by a previous error, or by some unforeseen peculiar |
| -- occurrence. However, this is only an optimization attempt, so there is |
| -- really no point in crashing the compiler. Instead we just decide, too |
| -- bad, we can't figure out a range in this case after all. |
| |
| exception |
| when others => |
| |
| -- Debug flag K disables this behavior (useful for debugging) |
| |
| if Debug_Flag_K then |
| raise; |
| else |
| OK := False; |
| Lo := No_Uint; |
| Hi := No_Uint; |
| return; |
| end if; |
| end Determine_Range; |
| |
| ----------------------- |
| -- Determine_Range_R -- |
| ----------------------- |
| |
| procedure Determine_Range_R |
| (N : Node_Id; |
| OK : out Boolean; |
| Lo : out Ureal; |
| Hi : out Ureal; |
| Assume_Valid : Boolean := False) |
| is |
| Typ : Entity_Id := Etype (N); |
| -- Type to use, may get reset to base type for possibly invalid entity |
| |
| Lo_Left : Ureal; |
| Hi_Left : Ureal; |
| -- Lo and Hi bounds of left operand |
| |
| Lo_Right : Ureal := No_Ureal; |
| Hi_Right : Ureal := No_Ureal; |
| -- Lo and Hi bounds of right (or only) operand |
| |
| Bound : Node_Id; |
| -- Temp variable used to hold a bound node |
| |
| Hbound : Ureal; |
| -- High bound of base type of expression |
| |
| Lor : Ureal; |
| Hir : Ureal; |
| -- Refined values for low and high bounds, after tightening |
| |
| OK1 : Boolean; |
| -- Used in lower level calls to indicate if call succeeded |
| |
| Cindex : Cache_Index; |
| -- Used to search cache |
| |
| Btyp : Entity_Id; |
| -- Base type |
| |
| function OK_Operands return Boolean; |
| -- Used for binary operators. Determines the ranges of the left and |
| -- right operands, and if they are both OK, returns True, and puts |
| -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left. |
| |
| function Round_Machine (B : Ureal) return Ureal; |
| -- B is a real bound. Round it to the nearest machine number. |
| |
| ----------------- |
| -- OK_Operands -- |
| ----------------- |
| |
| function OK_Operands return Boolean is |
| begin |
| Determine_Range_R |
| (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid); |
| |
| if not OK1 then |
| return False; |
| end if; |
| |
| Determine_Range_R |
| (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid); |
| return OK1; |
| end OK_Operands; |
| |
| ------------------- |
| -- Round_Machine -- |
| ------------------- |
| |
| function Round_Machine (B : Ureal) return Ureal is |
| begin |
| return Machine_Number (Typ, B, N); |
| end Round_Machine; |
| |
| -- Start of processing for Determine_Range_R |
| |
| begin |
| -- Prevent junk warnings by initializing range variables |
| |
| Lo := No_Ureal; |
| Hi := No_Ureal; |
| Lor := No_Ureal; |
| Hir := No_Ureal; |
| |
| -- For temporary constants internally generated to remove side effects |
| -- we must use the corresponding expression to determine the range of |
| -- the expression. But note that the expander can also generate |
| -- constants in other cases, including deferred constants. |
| |
| if Is_Entity_Name (N) |
| and then Nkind (Parent (Entity (N))) = N_Object_Declaration |
| and then Ekind (Entity (N)) = E_Constant |
| and then Is_Internal_Name (Chars (Entity (N))) |
| then |
| if Present (Expression (Parent (Entity (N)))) then |
| Determine_Range_R |
| (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid); |
| |
| elsif Present (Full_View (Entity (N))) then |
| Determine_Range_R |
| (Expression (Parent (Full_View (Entity (N)))), |
| OK, Lo, Hi, Assume_Valid); |
| |
| else |
| OK := False; |
| end if; |
| |
| return; |
| end if; |
| |
| -- If type is not defined, we can't determine its range |
| |
| pragma Warnings (Off, "condition can only be True if invalid"); |
| -- Otherwise the compiler warns on the check of Float_Rep below, because |
| -- there is only one value (see types.ads). |
| |
| if No (Typ) |
| |
| -- We don't deal with anything except IEEE floating-point types |
| |
| or else not Is_Floating_Point_Type (Typ) |
| or else Float_Rep (Typ) /= IEEE_Binary |
| |
| -- Ignore type for which an error has been posted, since range in |
| -- this case may well be a bogosity deriving from the error. Also |
| -- ignore if error posted on the reference node. |
| |
| or else Error_Posted (N) or else Error_Posted (Typ) |
| then |
| pragma Warnings (On, "condition can only be True if invalid"); |
| OK := False; |
| return; |
| end if; |
| |
| -- For all other cases, we can determine the range |
| |
| OK := True; |
| |
| -- If value is compile time known, then the possible range is the one |
| -- value that we know this expression definitely has. |
| |
| if Compile_Time_Known_Value (N) then |
| Lo := Expr_Value_R (N); |
| Hi := Lo; |
| return; |
| end if; |
| |
| -- Return if already in the cache |
| |
| Cindex := Cache_Index (N mod Cache_Size); |
| |
| if Determine_Range_Cache_N (Cindex) = N |
| and then |
| Determine_Range_Cache_O (Cindex) = Original_Node (N) |
| and then |
| Determine_Range_Cache_V (Cindex) = Assume_Valid |
| then |
| Lo := Determine_Range_Cache_Lo_R (Cindex); |
| Hi := Determine_Range_Cache_Hi_R (Cindex); |
| return; |
| end if; |
| |
| -- Otherwise, start by finding the bounds of the type of the expression, |
| -- the value cannot be outside this range (if it is, then we have an |
| -- overflow situation, which is a separate check, we are talking here |
| -- only about the expression value). |
| |
| -- First a check, never try to find the bounds of a generic type, since |
| -- these bounds are always junk values, and it is only valid to look at |
| -- the bounds in an instance. |
| |
| if Is_Generic_Type (Typ) then |
| OK := False; |
| return; |
| end if; |
| |
| -- First step, change to use base type unless we know the value is valid |
| |
| if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N))) |
| or else Assume_No_Invalid_Values |
| or else Assume_Valid |
| then |
| null; |
| else |
| Typ := Underlying_Type (Base_Type (Typ)); |
| end if; |
| |
| -- Retrieve the base type. Handle the case where the base type is a |
| -- private type. |
| |
| Btyp := Base_Type (Typ); |
| |
| if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then |
| Btyp := Full_View (Btyp); |
| end if; |
| |
| -- We use the actual bound unless it is dynamic, in which case use the |
| -- corresponding base type bound if possible. If we can't get a bound |
| -- then we figure we can't determine the range (a peculiar case, that |
| -- perhaps cannot happen, but there is no point in bombing in this |
| -- optimization circuit). |
| |
| -- First the low bound |
| |
| Bound := Type_Low_Bound (Typ); |
| |
| if Compile_Time_Known_Value (Bound) then |
| Lo := Expr_Value_R (Bound); |
| |
| elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then |
| Lo := Expr_Value_R (Type_Low_Bound (Btyp)); |
| |
| else |
| OK := False; |
| return; |
| end if; |
| |
| -- Now the high bound |
| |
| Bound := Type_High_Bound (Typ); |
| |
| -- We need the high bound of the base type later on, and this should |
| -- always be compile time known. Again, it is not clear that this |
| -- can ever be false, but no point in bombing. |
| |
| if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then |
| Hbound := Expr_Value_R (Type_High_Bound (Btyp)); |
| Hi := Hbound; |
| |
| else |
| OK := False; |
| return; |
| end if; |
| |
| -- If we have a static subtype, then that may have a tighter bound so |
| -- use the upper bound of the subtype instead in this case. |
| |
| if Compile_Time_Known_Value (Bound) then |
| Hi := Expr_Value_R (Bound); |
| end if; |
| |
| -- We may be able to refine this value in certain situations. If any |
| -- refinement is possible, then Lor and Hir are set to possibly tighter |
| -- bounds, and OK1 is set to True. |
| |
| case Nkind (N) is |
| |
| -- For unary plus, result is limited by range of operand |
| |
| when N_Op_Plus => |
| Determine_Range_R |
| (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid); |
| |
| -- For unary minus, determine range of operand, and negate it |
| |
| when N_Op_Minus => |
| Determine_Range_R |
| (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid); |
| |
| if OK1 then |
| Lor := -Hi_Right; |
| Hir := -Lo_Right; |
| end if; |
| |
| -- For binary addition, get range of each operand and do the |
| -- addition to get the result range. |
| |
| when N_Op_Add => |
| if OK_Operands then |
| Lor := Round_Machine (Lo_Left + Lo_Right); |
| Hir := Round_Machine (Hi_Left + Hi_Right); |
| end if; |
| |
| -- For binary subtraction, get range of each operand and do the worst |
| -- case subtraction to get the result range. |
| |
| when N_Op_Subtract => |
| if OK_Operands then |
| Lor := Round_Machine (Lo_Left - Hi_Right); |
| Hir := Round_Machine (Hi_Left - Lo_Right); |
| end if; |
| |
| -- For multiplication, get range of each operand and do the |
| -- four multiplications to get the result range. |
| |
| when N_Op_Multiply => |
| if OK_Operands then |
| declare |
| M1 : constant Ureal := Round_Machine (Lo_Left * Lo_Right); |
| M2 : constant Ureal := Round_Machine (Lo_Left * Hi_Right); |
| M3 : constant Ureal := Round_Machine (Hi_Left * Lo_Right); |
| M4 : constant Ureal := Round_Machine (Hi_Left * Hi_Right); |
| |
| begin |
| Lor := UR_Min (UR_Min (M1, M2), UR_Min (M3, M4)); |
| Hir := UR_Max (UR_Max (M1, M2), UR_Max (M3, M4)); |
| end; |
| end if; |
| |
| -- For division, consider separately the cases where the right |
| -- operand is positive or negative. Otherwise, the right operand |
| -- can be arbitrarily close to zero, so the result is likely to |
| -- be unbounded in one direction, do not attempt to compute it. |
| |
| when N_Op_Divide => |
| if OK_Operands then |
| |
| -- Right operand is positive |
| |
| if Lo_Right > Ureal_0 then |
| |
| -- If the low bound of the left operand is negative, obtain |
| -- the overall low bound by dividing it by the smallest |
| -- value of the right operand, and otherwise by the largest |
| -- value of the right operand. |
| |
| if Lo_Left < Ureal_0 then |
| Lor := Round_Machine (Lo_Left / Lo_Right); |
| else |
| Lor := Round_Machine (Lo_Left / Hi_Right); |
| end if; |
| |
| -- If the high bound of the left operand is negative, obtain |
| -- the overall high bound by dividing it by the largest |
| -- value of the right operand, and otherwise by the |
| -- smallest value of the right operand. |
| |
| if Hi_Left < Ureal_0 then |
| Hir := Round_Machine (Hi_Left / Hi_Right); |
| else |
| Hir := Round_Machine (Hi_Left / Lo_Right); |
| end if; |
| |
| -- Right operand is negative |
| |
| elsif Hi_Right < Ureal_0 then |
| |
| -- If the low bound of the left operand is negative, obtain |
| -- the overall low bound by dividing it by the largest |
| -- value of the right operand, and otherwise by the smallest |
| -- value of the right operand. |
| |
| if Lo_Left < Ureal_0 then |
| Lor := Round_Machine (Lo_Left / Hi_Right); |
| else |
| Lor := Round_Machine (Lo_Left / Lo_Right); |
| end if; |
| |
| -- If the high bound of the left operand is negative, obtain |
| -- the overall high bound by dividing it by the smallest |
| -- value of the right operand, and otherwise by the |
| -- largest value of the right operand. |
| |
| if Hi_Left < Ureal_0 then |
| Hir := Round_Machine (Hi_Left / Lo_Right); |
| else |
| Hir := Round_Machine (Hi_Left / Hi_Right); |
| end if; |
| |
| else |
| OK1 := False; |
| end if; |
| end if; |
| |
| when N_Type_Conversion => |
| |
| -- For type conversion from one floating-point type to another, we |
| -- can refine the range using the converted value. |
| |
| if Is_Floating_Point_Type (Etype (Expression (N))) then |
| Determine_Range_R (Expression (N), OK1, Lor, Hir, Assume_Valid); |
| |
| -- When converting an integer to a floating-point type, determine |
| -- the range in integer first, and then convert the bounds. |
| |
| elsif Is_Discrete_Type (Etype (Expression (N))) then |
| declare |
| Hir_Int : Uint; |
| Lor_Int : Uint; |
| |
| begin |
| Determine_Range |
| (Expression (N), OK1, Lor_Int, Hir_Int, Assume_Valid); |
| |
| if OK1 then |
| Lor := Round_Machine (UR_From_Uint (Lor_Int)); |
| Hir := Round_Machine (UR_From_Uint (Hir_Int)); |
| end if; |
| end; |
| |
| else |
| OK1 := False; |
| end if; |
| |
| -- Nothing special to do for all other expression kinds |
| |
| when others => |
| OK1 := False; |
| Lor := No_Ureal; |
| Hir := No_Ureal; |
| end case; |
| |
| -- At this stage, if OK1 is true, then we know that the actual result of |
| -- the computed expression is in the range Lor .. Hir. We can use this |
| -- to restrict the possible range of results. |
| |
| if OK1 then |
| |
| -- If the refined value of the low bound is greater than the type |
| -- low bound, then reset it to the more restrictive value. |
| |
| if Lor > Lo then |
| Lo := Lor; |
| end if; |
| |
| -- Similarly, if the refined value of the high bound is less than the |
| -- value so far, then reset it to the more restrictive value. |
| |
| if Hir < Hi then |
| Hi := Hir; |
| end if; |
| end if; |
| |
| -- Set cache entry for future call and we are all done |
| |
| Determine_Range_Cache_N (Cindex) := N; |
| Determine_Range_Cache_O (Cindex) := Original_Node (N); |
| Determine_Range_Cache_V (Cindex) := Assume_Valid; |
| Determine_Range_Cache_Lo_R (Cindex) := Lo; |
| Determine_Range_Cache_Hi_R (Cindex) := Hi; |
| return; |
| |
| -- If any exception occurs, it means that we have some bug in the compiler, |
| -- possibly triggered by a previous error, or by some unforeseen peculiar |
| -- occurrence. However, this is only an optimization attempt, so there is |
| -- really no point in crashing the compiler. Instead we just decide, too |
| -- bad, we can't figure out a range in this case after all. |
| |
| exception |
| when others => |
| |
| -- Debug flag K disables this behavior (useful for debugging) |
| |
| if Debug_Flag_K then |
| raise; |
| else |
| OK := False; |
| Lo := No_Ureal; |
| Hi := No_Ureal; |
| return; |
| end if; |
| end Determine_Range_R; |
| |
| --------------------------------- |
| -- Determine_Range_To_Discrete -- |
| --------------------------------- |
| |
| procedure Determine_Range_To_Discrete |
| (N : Node_Id; |
| OK : out Boolean; |
| Lo : out Uint; |
| Hi : out Uint; |
| Fixed_Int : Boolean := False; |
| Assume_Valid : Boolean := False) |
| is |
| Typ : constant Entity_Id := Etype (N); |
| |
| begin |
| -- For a discrete type, simply defer to Determine_Range |
| |
| if Is_Discrete_Type (Typ) then |
| Determine_Range (N, OK, Lo, Hi, Assume_Valid); |
| |
| -- For a fixed point type treated as an integer, we can determine the |
| -- range using the Corresponding_Integer_Value of the bounds of the |
| -- type or base type. This is done by the calls to Expr_Value below. |
| |
| elsif Is_Fixed_Point_Type (Typ) and then Fixed_Int then |
| declare |
| Btyp, Ftyp : Entity_Id; |
| Bound : Node_Id; |
| |
| begin |
| if Assume_Valid then |
| Ftyp := Typ; |
| else |
| Ftyp := Underlying_Type (Base_Type (Typ)); |
| end if; |
| |
| Btyp := Base_Type (Ftyp); |
| |
| -- First the low bound |
| |
| Bound := Type_Low_Bound (Ftyp); |
| |
| if Compile_Time_Known_Value (Bound) then |
| Lo := Expr_Value (Bound); |
| else |
| Lo := Expr_Value (Type_Low_Bound (Btyp)); |
| end if; |
| |
| -- Then the high bound |
| |
| Bound := Type_High_Bound (Ftyp); |
| |
| if Compile_Time_Known_Value (Bound) then |
| Hi := Expr_Value (Bound); |
| else |
| Hi := Expr_Value (Type_High_Bound (Btyp)); |
| end if; |
| |
| OK := True; |
| end; |
| |
| -- For a floating-point type, we can determine the range in real first, |
| -- and then convert the bounds using UR_To_Uint, which correctly rounds |
| -- away from zero when half way between two integers, as required by |
| -- normal Ada 95 rounding semantics. But this is only possible because |
| -- GNATprove's analysis rules out the possibility of a NaN or infinite. |
| |
| elsif GNATprove_Mode and then Is_Floating_Point_Type (Typ) then |
| declare |
| Lo_Real, Hi_Real : Ureal; |
| |
| begin |
| Determine_Range_R (N, OK, Lo_Real, Hi_Real, Assume_Valid); |
| |
| if OK then |
| Lo := UR_To_Uint (Lo_Real); |
| Hi := UR_To_Uint (Hi_Real); |
| else |
| Lo := No_Uint; |
| Hi := No_Uint; |
| end if; |
| end; |
| |
| else |
| Lo := No_Uint; |
| Hi := No_Uint; |
| OK := False; |
| end if; |
| end Determine_Range_To_Discrete; |
| |
| ------------------------------------ |
| -- Discriminant_Checks_Suppressed -- |
| ------------------------------------ |
| |
| function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if Present (E) then |
| if Is_Unchecked_Union (E) then |
| return True; |
| elsif Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Discriminant_Check); |
| end if; |
| end if; |
| |
| return Scope_Suppress.Suppress (Discriminant_Check); |
| end Discriminant_Checks_Suppressed; |
| |
| -------------------------------- |
| -- Division_Checks_Suppressed -- |
| -------------------------------- |
| |
| function Division_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if Present (E) and then Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Division_Check); |
| else |
| return Scope_Suppress.Suppress (Division_Check); |
| end if; |
| end Division_Checks_Suppressed; |
| |
| -------------------------------------- |
| -- Duplicated_Tag_Checks_Suppressed -- |
| -------------------------------------- |
| |
| function Duplicated_Tag_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if Present (E) and then Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Duplicated_Tag_Check); |
| else |
| return Scope_Suppress.Suppress (Duplicated_Tag_Check); |
| end if; |
| end Duplicated_Tag_Checks_Suppressed; |
| |
| ----------------------------------- |
| -- Elaboration_Checks_Suppressed -- |
| ----------------------------------- |
| |
| function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| -- The complication in this routine is that if we are in the dynamic |
| -- model of elaboration, we also check All_Checks, since All_Checks |
| -- does not set Elaboration_Check explicitly. |
| |
| if Present (E) then |
| if Kill_Elaboration_Checks (E) then |
| return True; |
| |
| elsif Checks_May_Be_Suppressed (E) then |
| if Is_Check_Suppressed (E, Elaboration_Check) then |
| return True; |
| |
| elsif Dynamic_Elaboration_Checks then |
| return Is_Check_Suppressed (E, All_Checks); |
| |
| else |
| return False; |
| end if; |
| end if; |
| end if; |
| |
| if Scope_Suppress.Suppress (Elaboration_Check) then |
| return True; |
| |
| elsif Dynamic_Elaboration_Checks then |
| return Scope_Suppress.Suppress (All_Checks); |
| |
| else |
| return False; |
| end if; |
| end Elaboration_Checks_Suppressed; |
| |
| --------------------------- |
| -- Enable_Overflow_Check -- |
| --------------------------- |
| |
| procedure Enable_Overflow_Check (N : Node_Id) is |
| Typ : constant Entity_Id := Base_Type (Etype (N)); |
| Mode : constant Overflow_Mode_Type := Overflow_Check_Mode; |
| Chk : Nat; |
| OK : Boolean; |
| Ent : Entity_Id; |
| Ofs : Uint; |
| Lo : Uint; |
| Hi : Uint; |
| |
| Do_Ovflow_Check : Boolean; |
| |
| begin |
| if Debug_Flag_CC then |
| w ("Enable_Overflow_Check for node ", Int (N)); |
| Write_Str (" Source location = "); |
| wl (Sloc (N)); |
| pg (Union_Id (N)); |
| end if; |
| |
| -- No check if overflow checks suppressed for type of node |
| |
| if Overflow_Checks_Suppressed (Etype (N)) then |
| return; |
| |
| -- Nothing to do for unsigned integer types, which do not overflow |
| |
| elsif Is_Modular_Integer_Type (Typ) then |
| return; |
| end if; |
| |
| -- This is the point at which processing for STRICT mode diverges |
| -- from processing for MINIMIZED/ELIMINATED modes. This divergence is |
| -- probably more extreme that it needs to be, but what is going on here |
| -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted |
| -- to leave the processing for STRICT mode untouched. There were |
| -- two reasons for this. First it avoided any incompatible change of |
| -- behavior. Second, it guaranteed that STRICT mode continued to be |
| -- legacy reliable. |
| |
| -- The big difference is that in STRICT mode there is a fair amount of |
| -- circuitry to try to avoid setting the Do_Overflow_Check flag if we |
| -- know that no check is needed. We skip all that in the two new modes, |
| -- since really overflow checking happens over a whole subtree, and we |
| -- do the corresponding optimizations later on when applying the checks. |
| |
| if Mode in Minimized_Or_Eliminated then |
| if not (Overflow_Checks_Suppressed (Etype (N))) |
| and then not (Is_Entity_Name (N) |
| and then Overflow_Checks_Suppressed (Entity (N))) |
| then |
| Activate_Overflow_Check (N); |
| end if; |
| |
| if Debug_Flag_CC then |
| w ("Minimized/Eliminated mode"); |
| end if; |
| |
| return; |
| end if; |
| |
| -- Remainder of processing is for STRICT case, and is unchanged from |
| -- earlier versions preceding the addition of MINIMIZED/ELIMINATED. |
| |
| -- 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. |
| |
| if Nkind (N) /= N_Type_Conversion then |
| Determine_Range (N, OK, Lo, Hi, Assume_Valid => True); |
| |
| -- 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 |
| -- type, because it either can't tell anything more precise, or |
| -- does not think it is worth the effort to be more precise. |
| |
| -- 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). |
| |
| -- c) The alternative is a lot of special casing in this routine |
| -- which would partially duplicate Determine_Range processing. |
| |
| if OK then |
| Do_Ovflow_Check := True; |
| |
| -- Note that the following checks are quite deliberately > and < |
| -- rather than >= and <= as explained above. |
| |
| if Lo > Expr_Value (Type_Low_Bound (Typ)) |
| and then |
| Hi < Expr_Value (Type_High_Bound (Typ)) |
| then |
| Do_Ovflow_Check := False; |
| |
| -- Despite the comments above, it is worth dealing specially with |
| -- division. The only case where integer division can overflow is |
| -- (largest negative number) / (-1). So we will do an extra range |
| -- analysis to see if this is possible. |
| |
| elsif Nkind (N) = N_Op_Divide then |
| Determine_Range |
| (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True); |
| |
| if OK and then Lo > Expr_Value (Type_Low_Bound (Typ)) then |
| Do_Ovflow_Check := False; |
| |
| else |
| Determine_Range |
| (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); |
| |
| if OK and then (Lo > Uint_Minus_1 |
| or else |
| Hi < Uint_Minus_1) |
| then |
| Do_Ovflow_Check := False; |
| end if; |
| end if; |
| |
| -- Likewise for Abs/Minus, the only case where the operation can |
| -- overflow is when the operand is the largest negative number. |
| |
| elsif Nkind (N) in N_Op_Abs | N_Op_Minus then |
| Determine_Range |
| (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); |
| |
| if OK and then Lo > Expr_Value (Type_Low_Bound (Typ)) then |
| Do_Ovflow_Check := False; |
| end if; |
| end if; |
| |
| -- If no overflow check required, we are done |
| |
| if not Do_Ovflow_Check then |
| if Debug_Flag_CC then |
| w ("No overflow check required"); |
| end if; |
| |
| return; |
| end if; |
| end if; |
| end if; |
| |
| -- If not in optimizing mode, set flag and we are done. We are also done |
| -- (and just set the flag) if the type is not a discrete type, since it |
| -- is not worth the effort to eliminate checks for other than discrete |
| -- types. In addition, we take this same path if we have stored the |
| -- maximum number of checks possible already (a very unlikely situation, |
| -- but we do not want to blow up). |
| |
| if Optimization_Level = 0 |
| or else not Is_Discrete_Type (Etype (N)) |
| or else Num_Saved_Checks = Saved_Checks'Last |
| then |
| Activate_Overflow_Check (N); |
| |
| if Debug_Flag_CC then |
| w ("Optimization off"); |
| end if; |
| |
| return; |
| end if; |
| |
| -- Otherwise evaluate and check the expression |
| |
| Find_Check |
| (Expr => N, |
| Check_Type => 'O', |
| Target_Type => Empty, |
| Entry_OK => OK, |
| Check_Num => Chk, |
| Ent => Ent, |
| Ofs => Ofs); |
| |
| if Debug_Flag_CC then |
| w ("Called Find_Check"); |
| w (" OK = ", OK); |
| |
| if OK then |
| w (" Check_Num = ", Chk); |
| w (" Ent = ", Int (Ent)); |
| Write_Str (" Ofs = "); |
| pid (Ofs); |
| end if; |
| end if; |
| |
| -- If check is not of form to optimize, then set flag and we are done |
| |
| if not OK then |
| Activate_Overflow_Check (N); |
| return; |
| end if; |
| |
| -- If check is already performed, then return without setting flag |
| |
| if Chk /= 0 then |
| if Debug_Flag_CC then |
| w ("Check suppressed!"); |
| end if; |
| |
| return; |
| end if; |
| |
| -- Here we will make a new entry for the new check |
| |
| Activate_Overflow_Check (N); |
| Num_Saved_Checks := Num_Saved_Checks + 1; |
| Saved_Checks (Num_Saved_Checks) := |
| (Killed => False, |
| Entity => Ent, |
| Offset => Ofs, |
| Check_Type => 'O', |
| Target_Type => Empty); |
| |
| if Debug_Flag_CC then |
| w ("Make new entry, check number = ", Num_Saved_Checks); |
| w (" Entity = ", Int (Ent)); |
| Write_Str (" Offset = "); |
| pid (Ofs); |
| w (" Check_Type = O"); |
| w (" Target_Type = Empty"); |
| end if; |
| |
| -- If we get an exception, then something went wrong, probably because of |
| -- an error in the structure of the tree due to an incorrect program. Or |
| -- it may be a bug in the optimization circuit. In either case the safest |
| -- thing is simply to set the check flag unconditionally. |
| |
| exception |
| when others => |
| Activate_Overflow_Check (N); |
| |
| if Debug_Flag_CC then |
| w (" exception occurred, overflow flag set"); |
| end if; |
| |
| return; |
| end Enable_Overflow_Check; |
| |
| ------------------------ |
| -- Enable_Range_Check -- |
| ------------------------ |
| |
| procedure Enable_Range_Check (N : Node_Id) is |
| Chk : Nat; |
| OK : Boolean; |
| Ent : Entity_Id; |
| Ofs : Uint; |
| Ttyp : Entity_Id; |
| P : Node_Id; |
| |
| begin |
| -- Return if unchecked type conversion with range check killed. In this |
| -- case we never set the flag (that's what Kill_Range_Check is about). |
| |
| if Nkind (N) = N_Unchecked_Type_Conversion |
| and then Kill_Range_Check (N) |
| then |
| return; |
| end if; |
| |
| -- Do not set range check flag if parent is assignment statement or |
| -- object declaration with Suppress_Assignment_Checks flag set. |
| |
| if Nkind (Parent (N)) in N_Assignment_Statement | N_Object_Declaration |
| and then Suppress_Assignment_Checks (Parent (N)) |
| then |
| return; |
| end if; |
| |
| -- Check for various cases where we should suppress the range check |
| |
| -- No check if range checks suppressed for type of node |
| |
| if Present (Etype (N)) and then Range_Checks_Suppressed (Etype (N)) then |
| return; |
| |
| -- No check if node is an entity name, and range checks are suppressed |
| -- for this entity, or for the type of this entity. |
| |
| elsif Is_Entity_Name (N) |
| and then (Range_Checks_Suppressed (Entity (N)) |
| or else Range_Checks_Suppressed (Etype (Entity (N)))) |
| then |
| return; |
| |
| -- No checks if index of array, and index checks are suppressed for |
| -- the array object or the type of the array. |
| |
| elsif Nkind (Parent (N)) = N_Indexed_Component then |
| declare |
| Pref : constant Node_Id := Prefix (Parent (N)); |
| begin |
| if Is_Entity_Name (Pref) |
| and then Index_Checks_Suppressed (Entity (Pref)) |
| then |
| return; |
| elsif Index_Checks_Suppressed (Etype (Pref)) then |
| return; |
| end if; |
| end; |
| end if; |
| |
| -- Debug trace output |
| |
| if Debug_Flag_CC then |
| w ("Enable_Range_Check for node ", Int (N)); |
| Write_Str (" Source location = "); |
| wl (Sloc (N)); |
| pg (Union_Id (N)); |
| end if; |
| |
| -- If not in optimizing mode, set flag and we are done. We are also done |
| -- (and just set the flag) if the type is not a discrete type, since it |
| -- is not worth the effort to eliminate checks for other than discrete |
| -- types. In addition, we take this same path if we have stored the |
| -- maximum number of checks possible already (a very unlikely situation, |
| -- but we do not want to blow up). |
| |
| if Optimization_Level = 0 |
| or else No (Etype (N)) |
| or else not Is_Discrete_Type (Etype (N)) |
| or else Num_Saved_Checks = Saved_Checks'Last |
| then |
| Activate_Range_Check (N); |
| |
| if Debug_Flag_CC then |
| w ("Optimization off"); |
| end if; |
| |
| return; |
| end if; |
| |
| -- Otherwise find out the target type |
| |
| P := Parent (N); |
| |
| -- For assignment, use left side subtype |
| |
| if Nkind (P) = N_Assignment_Statement |
| and then Expression (P) = N |
| then |
| Ttyp := Etype (Name (P)); |
| |
| -- For indexed component, use subscript subtype |
| |
| elsif Nkind (P) = N_Indexed_Component then |
| declare |
| Atyp : Entity_Id; |
| Indx : Node_Id; |
| Subs : Node_Id; |
| |
| begin |
| Atyp := Etype (Prefix (P)); |
| |
| if Is_Access_Type (Atyp) then |
| Atyp := Designated_Type (Atyp); |
| |
| -- If the prefix is an access to an unconstrained array, |
| -- perform check unconditionally: it depends on the bounds of |
| -- an object and we cannot currently recognize whether the test |
| -- may be redundant. |
| |
| if not Is_Constrained (Atyp) then |
| Activate_Range_Check (N); |
| return; |
| end if; |
| |
| -- Ditto if prefix is simply an unconstrained array. We used |
| -- to think this case was OK, if the prefix was not an explicit |
| -- dereference, but we have now seen a case where this is not |
| -- true, so it is safer to just suppress the optimization in this |
| -- case. The back end is getting better at eliminating redundant |
| -- checks in any case, so the loss won't be important. |
| |
| elsif Is_Array_Type (Atyp) |
| and then not Is_Constrained (Atyp) |
| then |
| Activate_Range_Check (N); |
| return; |
| end if; |
| |
| Indx := First_Index (Atyp); |
| Subs := First (Expressions (P)); |
| loop |
| if Subs = N then |
| Ttyp := Etype (Indx); |
| exit; |
| end if; |
| |
| Next_Index (Indx); |
| Next (Subs); |
| end loop; |
| end; |
| |
| -- For now, ignore all other cases, they are not so interesting |
| |
| else |
| if Debug_Flag_CC then |
| w (" target type not found, flag set"); |
| end if; |
| |
| Activate_Range_Check (N); |
| return; |
| end if; |
| |
| -- Evaluate and check the expression |
| |
| Find_Check |
| (Expr => N, |
| Check_Type => 'R', |
| Target_Type => Ttyp, |
| Entry_OK => OK, |
| Check_Num => Chk, |
| Ent => Ent, |
| Ofs => Ofs); |
| |
| if Debug_Flag_CC then |
| w ("Called Find_Check"); |
| w ("Target_Typ = ", Int (Ttyp)); |
| w (" OK = ", OK); |
| |
| if OK then |
| w (" Check_Num = ", Chk); |
| w (" Ent = ", Int (Ent)); |
| Write_Str (" Ofs = "); |
| pid (Ofs); |
| end if; |
| end if; |
| |
| -- If check is not of form to optimize, then set flag and we are done |
| |
| if not OK then |
| if Debug_Flag_CC then |
| w (" expression not of optimizable type, flag set"); |
| end if; |
| |
| Activate_Range_Check (N); |
| return; |
| end if; |
| |
| -- If check is already performed, then return without setting flag |
| |
| if Chk /= 0 then |
| if Debug_Flag_CC then |
| w ("Check suppressed!"); |
| end if; |
| |
| return; |
| end if; |
| |
| -- Here we will make a new entry for the new check |
| |
| Activate_Range_Check (N); |
| Num_Saved_Checks := Num_Saved_Checks + 1; |
| Saved_Checks (Num_Saved_Checks) := |
| (Killed => False, |
| Entity => Ent, |
| Offset => Ofs, |
| Check_Type => 'R', |
| Target_Type => Ttyp); |
| |
| if Debug_Flag_CC then |
| w ("Make new entry, check number = ", Num_Saved_Checks); |
| w (" Entity = ", Int (Ent)); |
| Write_Str (" Offset = "); |
| pid (Ofs); |
| w (" Check_Type = R"); |
| w (" Target_Type = ", Int (Ttyp)); |
| pg (Union_Id (Ttyp)); |
| end if; |
| |
| -- If we get an exception, then something went wrong, probably because of |
| -- an error in the structure of the tree due to an incorrect program. Or |
| -- it may be a bug in the optimization circuit. In either case the safest |
| -- thing is simply to set the check flag unconditionally. |
| |
| exception |
| when others => |
| Activate_Range_Check (N); |
| |
| if Debug_Flag_CC then |
| w (" exception occurred, range flag set"); |
| end if; |
| |
| return; |
| end Enable_Range_Check; |
| |
| ------------------ |
| -- Ensure_Valid -- |
| ------------------ |
| |
| procedure Ensure_Valid |
| (Expr : Node_Id; |
| Holes_OK : Boolean := False; |
| Related_Id : Entity_Id := Empty; |
| Is_Low_Bound : Boolean := False; |
| Is_High_Bound : Boolean := False) |
| is |
| Typ : constant Entity_Id := Etype (Expr); |
| |
| begin |
| -- Ignore call if we are not doing any validity checking |
| |
| if not Validity_Checks_On then |
| return; |
| |
| -- Ignore call if range or validity checks suppressed on entity or type |
| |
| elsif Range_Or_Validity_Checks_Suppressed (Expr) then |
| return; |
| |
| -- No check required if expression is from the expander, we assume the |
| -- expander will generate whatever checks are needed. Note that this is |
| -- not just an optimization, it avoids infinite recursions. |
| |
| -- Unchecked conversions must be checked, unless they are initialized |
| -- scalar values, as in a component assignment in an init proc. |
| |
| -- In addition, we force a check if Force_Validity_Checks is set |
| |
| elsif not Comes_From_Source (Expr) |
| and then not |
| (Nkind (Expr) = N_Identifier |
| and then Present (Renamed_Entity_Or_Object (Entity (Expr))) |
| and then |
| Comes_From_Source (Renamed_Entity_Or_Object (Entity (Expr)))) |
| and then not Force_Validity_Checks |
| and then (Nkind (Expr) /= N_Unchecked_Type_Conversion |
| or else Kill_Range_Check (Expr)) |
| then |
| return; |
| |
| -- No check required if expression is known to have valid value |
| |
| elsif Expr_Known_Valid (Expr) then |
| return; |
| |
| -- No check needed within a generated predicate function. Validity |
| -- of input value will have been checked earlier. |
| |
| elsif Ekind (Current_Scope) = E_Function |
| and then Is_Predicate_Function (Current_Scope) |
| then |
| return; |
| |
| -- Ignore case of enumeration with holes where the flag is set not to |
| -- worry about holes, since no special validity check is needed |
| |
| elsif Is_Enumeration_Type (Typ) |
| and then Has_Non_Standard_Rep (Typ) |
| and then Holes_OK |
| then |
| return; |
| |
| -- No check required on the left-hand side of an assignment |
| |
| elsif Nkind (Parent (Expr)) = N_Assignment_Statement |
| and then Expr = Name (Parent (Expr)) |
| then |
| return; |
| |
| -- No check on a universal real constant. The context will eventually |
| -- convert it to a machine number for some target type, or report an |
| -- illegality. |
| |
| elsif Nkind (Expr) = N_Real_Literal |
| and then Etype (Expr) = Universal_Real |
| then |
| return; |
| |
| -- If the expression denotes a component of a packed boolean array, |
| -- no possible check applies. We ignore the old ACATS chestnuts that |
| -- involve Boolean range True..True. |
| |
| -- Note: validity checks are generated for expressions that yield a |
| -- scalar type, when it is possible to create a value that is outside of |
| -- the type. If this is a one-bit boolean no such value exists. This is |
| -- an optimization, and it also prevents compiler blowing up during the |
| -- elaboration of improperly expanded packed array references. |
| |
| elsif Nkind (Expr) = N_Indexed_Component |
| and then Is_Bit_Packed_Array (Etype (Prefix (Expr))) |
| and then Root_Type (Etype (Expr)) = Standard_Boolean |
| then |
| return; |
| |
| -- For an expression with actions, we want to insert the validity check |
| -- on the final Expression. |
| |
| elsif Nkind (Expr) = N_Expression_With_Actions then |
| Ensure_Valid (Expression (Expr)); |
| return; |
| |
| -- An annoying special case. If this is an out parameter of a scalar |
| -- type, then the value is not going to be accessed, therefore it is |
| -- inappropriate to do any validity check at the call site. Likewise |
| -- if the parameter is passed by reference. |
| |
| else |
| -- Only need to worry about scalar types |
| |
| if Is_Scalar_Type (Typ) then |
| declare |
| P : Node_Id; |
| N : Node_Id; |
| E : Entity_Id; |
| F : Entity_Id; |
| A : Node_Id; |
| L : List_Id; |
| |
| begin |
| -- Find actual argument (which may be a parameter association) |
| -- and the parent of the actual argument (the call statement) |
| |
| N := Expr; |
| P := Parent (Expr); |
| |
| if Nkind (P) = N_Parameter_Association then |
| N := P; |
| P := Parent (N); |
| end if; |
| |
| -- If this is an indirect or dispatching call, get signature |
| -- from the subprogram type. |
| |
| if Nkind (P) in N_Entry_Call_Statement |
| | N_Function_Call |
| | N_Procedure_Call_Statement |
| then |
| E := Get_Called_Entity (P); |
| L := Parameter_Associations (P); |
| |
| -- Only need to worry if there are indeed actuals, and if |
| -- this could be a subprogram call, otherwise we cannot get |
| -- a match (either we are not an argument, or the mode of |
| -- the formal is not OUT). This test also filters out the |
| -- generic case. |
| |
| if Is_Non_Empty_List (L) and then Is_Subprogram (E) then |
| |
| -- This is the loop through parameters, looking for an |
| -- OUT parameter for which we are the argument. |
| |
| F := First_Formal (E); |
| A := First (L); |
| while Present (F) loop |
| if A = N |
| and then (Ekind (F) = E_Out_Parameter |
| or else Mechanism (F) = By_Reference) |
| then |
| return; |
| end if; |
| |
| Next_Formal (F); |
| Next (A); |
| end loop; |
| end if; |
| end if; |
| end; |
| end if; |
| end if; |
| |
| -- If this is a boolean expression, only its elementary operands need |
| -- checking: if they are valid, a boolean or short-circuit operation |
| -- with them will be valid as well. |
| |
| if Base_Type (Typ) = Standard_Boolean |
| and then |
| (Nkind (Expr) in N_Op or else Nkind (Expr) in N_Short_Circuit) |
| then |
| return; |
| end if; |
| |
| -- If we fall through, a validity check is required |
| |
| Insert_Valid_Check (Expr, Related_Id, Is_Low_Bound, Is_High_Bound); |
| |
| if Is_Entity_Name (Expr) |
| and then Safe_To_Capture_Value (Expr, Entity (Expr)) |
| then |
| Set_Is_Known_Valid (Entity (Expr)); |
| end if; |
| end Ensure_Valid; |
| |
| ---------------------- |
| -- Expr_Known_Valid -- |
| ---------------------- |
| |
| function Expr_Known_Valid (Expr : Node_Id) return Boolean is |
| Typ : constant Entity_Id := Etype (Expr); |
| |
| begin |
| -- Non-scalar types are always considered valid, since they never give |
| -- rise to the issues of erroneous or bounded error behavior that are |
| -- the concern. In formal reference manual terms the notion of validity |
| -- only applies to scalar types. Note that even when packed arrays are |
| -- represented using modular types, they are still arrays semantically, |
| -- so they are also always valid (in particular, the unused bits can be |
| -- random rubbish without affecting the validity of the array value). |
| |
| if not Is_Scalar_Type (Typ) or else Is_Packed_Array_Impl_Type (Typ) then |
| return True; |
| |
| -- If no validity checking, then everything is considered valid |
| |
| elsif not Validity_Checks_On then |
| return True; |
| |
| -- Floating-point types are considered valid unless floating-point |
| -- validity checks have been specifically turned on. |
| |
| elsif Is_Floating_Point_Type (Typ) |
| and then not Validity_Check_Floating_Point |
| then |
| return True; |
| |
| -- If the expression is the value of an object that is known to be |
| -- valid, then clearly the expression value itself is valid. |
| |
| elsif Is_Entity_Name (Expr) |
| and then Is_Known_Valid (Entity (Expr)) |
| |
| -- Exclude volatile variables |
| |
| and then not Treat_As_Volatile (Entity (Expr)) |
| then |
| return True; |
| |
| -- References to discriminants are always considered valid. The value |
| -- of a discriminant gets checked when the object is built. Within the |
| -- record, we consider it valid, and it is important to do so, since |
| -- otherwise we can try to generate bogus validity checks which |
| -- reference discriminants out of scope. Discriminants of concurrent |
| -- types are excluded for the same reason. |
| |
| elsif Is_Entity_Name (Expr) |
| and then Denotes_Discriminant (Expr, Check_Concurrent => True) |
| then |
| return True; |
| |
| -- If the type is one for which all values are known valid, then we are |
| -- sure that the value is valid except in the slightly odd case where |
| -- the expression is a reference to a variable whose size has been |
| -- explicitly set to a value greater than the object size. |
| |
| elsif Is_Known_Valid (Typ) then |
| if Is_Entity_Name (Expr) |
| and then Ekind (Entity (Expr)) = E_Variable |
| and then Known_Esize (Entity (Expr)) |
| and then Esize (Entity (Expr)) > Esize (Typ) |
| then |
| return False; |
| else |
| return True; |
| end if; |
| |
| -- Integer and character literals always have valid values, where |
| -- appropriate these will be range checked in any case. |
| |
| elsif Nkind (Expr) in N_Integer_Literal | N_Character_Literal then |
| return True; |
| |
| -- If we have a type conversion or a qualification of a known valid |
| -- value, then the result will always be valid. |
| |
| elsif Nkind (Expr) in N_Type_Conversion | N_Qualified_Expression then |
| return Expr_Known_Valid (Expression (Expr)); |
| |
| -- Case of expression is a non-floating-point operator. In this case we |
| -- can assume the result is valid the generated code for the operator |
| -- will include whatever checks are needed (e.g. range checks) to ensure |
| -- validity. This assumption does not hold for the floating-point case, |
| -- since floating-point operators can generate Infinite or NaN results |
| -- which are considered invalid. |
| |
| -- Historical note: in older versions, the exemption of floating-point |
| -- types from this assumption was done only in cases where the parent |
| -- was an assignment, function call or parameter association. Presumably |
| -- the idea was that in other contexts, the result would be checked |
| -- elsewhere, but this list of cases was missing tests (at least the |
| -- N_Object_Declaration case, as shown by a reported missing validity |
| -- check), and it is not clear why function calls but not procedure |
| -- calls were tested for. It really seems more accurate and much |
| -- safer to recognize that expressions which are the result of a |
| -- floating-point operator can never be assumed to be valid. |
| |
| elsif Nkind (Expr) in N_Op and then not Is_Floating_Point_Type (Typ) then |
| return True; |
| |
| -- The result of a membership test is always valid, since it is true or |
| -- false, there are no other possibilities. |
| |
| elsif Nkind (Expr) in N_Membership_Test then |
| return True; |
| |
| -- For all other cases, we do not know the expression is valid |
| |
| else |
| return False; |
| end if; |
| end Expr_Known_Valid; |
| |
| ---------------- |
| -- Find_Check -- |
| ---------------- |
| |
| procedure Find_Check |
| (Expr : Node_Id; |
| Check_Type : Character; |
| Target_Type : Entity_Id; |
| Entry_OK : out Boolean; |
| Check_Num : out Nat; |
| Ent : out Entity_Id; |
| Ofs : out Uint) |
| is |
| function Within_Range_Of |
| (Target_Type : Entity_Id; |
| Check_Type : Entity_Id) return Boolean; |
| -- Given a requirement for checking a range against Target_Type, and |
| -- and a range Check_Type against which a check has already been made, |
| -- determines if the check against check type is sufficient to ensure |
| -- that no check against Target_Type is required. |
| |
| --------------------- |
| -- Within_Range_Of -- |
| --------------------- |
| |
| function Within_Range_Of |
| (Target_Type : Entity_Id; |
| Check_Type : Entity_Id) return Boolean |
| is |
| begin |
| if Target_Type = Check_Type then |
| return True; |
| |
| else |
| declare |
| Tlo : constant Node_Id := Type_Low_Bound (Target_Type); |
| Thi : constant Node_Id := Type_High_Bound (Target_Type); |
| Clo : constant Node_Id := Type_Low_Bound (Check_Type); |
| Chi : constant Node_Id := Type_High_Bound (Check_Type); |
| |
| begin |
| if (Tlo = Clo |
| or else (Compile_Time_Known_Value (Tlo) |
| and then |
| Compile_Time_Known_Value (Clo) |
| and then |
| Expr_Value (Clo) >= Expr_Value (Tlo))) |
| and then |
| (Thi = Chi |
| or else (Compile_Time_Known_Value (Thi) |
| and then |
| Compile_Time_Known_Value (Chi) |
| and then |
| Expr_Value (Chi) <= Expr_Value (Clo))) |
| then |
| return True; |
| else |
| return False; |
| end if; |
| end; |
| end if; |
| end Within_Range_Of; |
| |
| -- Start of processing for Find_Check |
| |
| begin |
| -- Establish default, in case no entry is found |
| |
| Check_Num := 0; |
| |
| -- Case of expression is simple entity reference |
| |
| if Is_Entity_Name (Expr) then |
| Ent := Entity (Expr); |
| Ofs := Uint_0; |
| |
| -- Case of expression is entity + known constant |
| |
| elsif Nkind (Expr) = N_Op_Add |
| and then Compile_Time_Known_Value (Right_Opnd (Expr)) |
| and then Is_Entity_Name (Left_Opnd (Expr)) |
| then |
| Ent := Entity (Left_Opnd (Expr)); |
| Ofs := Expr_Value (Right_Opnd (Expr)); |
| |
| -- Case of expression is entity - known constant |
| |
| elsif Nkind (Expr) = N_Op_Subtract |
| and then Compile_Time_Known_Value (Right_Opnd (Expr)) |
| and then Is_Entity_Name (Left_Opnd (Expr)) |
| then |
| Ent := Entity (Left_Opnd (Expr)); |
| Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr))); |
| |
| -- Any other expression is not of the right form |
| |
| else |
| Ent := Empty; |
| Ofs := Uint_0; |
| Entry_OK := False; |
| return; |
| end if; |
| |
| -- Come here with expression of appropriate form, check if entity is an |
| -- appropriate one for our purposes. |
| |
| if (Ekind (Ent) = E_Variable |
| or else Is_Constant_Object (Ent)) |
| and then not Is_Library_Level_Entity (Ent) |
| then |
| Entry_OK := True; |
| else |
| Entry_OK := False; |
| return; |
| end if; |
| |
| -- See if there is matching check already |
| |
| for J in reverse 1 .. Num_Saved_Checks loop |
| declare |
| SC : Saved_Check renames Saved_Checks (J); |
| begin |
| if SC.Killed = False |
| and then SC.Entity = Ent |
| and then SC.Offset = Ofs |
| and then SC.Check_Type = Check_Type |
| and then Within_Range_Of (Target_Type, SC.Target_Type) |
| then |
| Check_Num := J; |
| return; |
| end if; |
| end; |
| end loop; |
| |
| -- If we fall through entry was not found |
| |
| return; |
| end Find_Check; |
| |
| --------------------------------- |
| -- Generate_Discriminant_Check -- |
| --------------------------------- |
| |
| procedure Generate_Discriminant_Check (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Pref : constant Node_Id := Prefix (N); |
| Sel : constant Node_Id := Selector_Name (N); |
| |
| Orig_Comp : constant Entity_Id := |
| Original_Record_Component (Entity (Sel)); |
| -- The original component to be checked |
| |
| Discr_Fct : constant Entity_Id := |
| Discriminant_Checking_Func (Orig_Comp); |
| -- The discriminant checking function |
| |
| Discr : Entity_Id; |
| -- One discriminant to be checked in the type |
| |
| Real_Discr : Entity_Id; |
| -- Actual discriminant in the call |
| |
| Pref_Type : Entity_Id; |
| -- Type of relevant prefix (ignoring private/access stuff) |
| |
| Args : List_Id; |
| -- List of arguments for function call |
| |
| Formal : Entity_Id; |
| -- Keep track of the formal corresponding to the actual we build for |
| -- each discriminant, in order to be able to perform the necessary type |
| -- conversions. |
| |
| Scomp : Node_Id; |
| -- Selected component reference for checking function argument |
| |
| begin |
| Pref_Type := Etype (Pref); |
| |
| -- Force evaluation of the prefix, so that it does not get evaluated |
| -- twice (once for the check, once for the actual reference). Such a |
| -- double evaluation is always a potential source of inefficiency, and |
| -- is functionally incorrect in the volatile case, or when the prefix |
| -- may have side effects. A nonvolatile entity or a component of a |
| -- nonvolatile entity requires no evaluation. |
| |
| if Is_Entity_Name (Pref) then |
| if Treat_As_Volatile (Entity (Pref)) then |
| Force_Evaluation (Pref, Name_Req => True); |
| end if; |
| |
| elsif Treat_As_Volatile (Etype (Pref)) then |
| Force_Evaluation (Pref, Name_Req => True); |
| |
| elsif Nkind (Pref) = N_Selected_Component |
| and then Is_Entity_Name (Prefix (Pref)) |
| then |
| null; |
| |
| else |
| Force_Evaluation (Pref, Name_Req => True); |
| end if; |
| |
| -- For a tagged type, use the scope of the original component to |
| -- obtain the type, because ??? |
| |
| if Is_Tagged_Type (Scope (Orig_Comp)) then |
| Pref_Type := Scope (Orig_Comp); |
| |
| -- For an untagged derived type, use the discriminants of the parent |
| -- which have been renamed in the derivation, possibly by a one-to-many |
| -- discriminant constraint. For untagged type, initially get the Etype |
| -- of the prefix |
| |
| else |
| if Is_Derived_Type (Pref_Type) |
| and then Number_Discriminants (Pref_Type) /= |
| Number_Discriminants (Etype (Base_Type (Pref_Type))) |
| then |
| Pref_Type := Etype (Base_Type (Pref_Type)); |
| end if; |
| end if; |
| |
| -- We definitely should have a checking function, This routine should |
| -- not be called if no discriminant checking function is present. |
| |
| pragma Assert (Present (Discr_Fct)); |
| |
| -- Create the list of the actual parameters for the call. This list |
| -- is the list of the discriminant fields of the record expression to |
| -- be discriminant checked. |
| |
| Args := New_List; |
| Formal := First_Formal (Discr_Fct); |
| Discr := First_Discriminant (Pref_Type); |
| while Present (Discr) loop |
| |
| -- If we have a corresponding discriminant field, and a parent |
| -- subtype is present, then we want to use the corresponding |
| -- discriminant since this is the one with the useful value. |
| |
| if Present (Corresponding_Discriminant (Discr)) |
| and then Ekind (Pref_Type) = E_Record_Type |
| and then Present (Parent_Subtype (Pref_Type)) |
| then |
| Real_Discr := Corresponding_Discriminant (Discr); |
| else |
| Real_Discr := Discr; |
| end if; |
| |
| -- Construct the reference to the discriminant |
| |
| Scomp := |
| Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To (Pref_Type, |
| Duplicate_Subexpr (Pref)), |
| Selector_Name => New_Occurrence_Of (Real_Discr, Loc)); |
| |
| -- Manually analyze and resolve this selected component. We really |
| -- want it just as it appears above, and do not want the expander |
| -- playing discriminal games etc with this reference. Then we append |
| -- the argument to the list we are gathering. |
| |
| Set_Etype (Scomp, Etype (Real_Discr)); |
| Set_Analyzed (Scomp, True); |
| Append_To (Args, Convert_To (Etype (Formal), Scomp)); |
| |
| Next_Formal_With_Extras (Formal); |
| Next_Discriminant (Discr); |
| end loop; |
| |
| -- Now build and insert the call |
| |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (Discr_Fct, Loc), |
| Parameter_Associations => Args), |
| Reason => CE_Discriminant_Check_Failed)); |
| end Generate_Discriminant_Check; |
| |
| --------------------------- |
| -- Generate_Index_Checks -- |
| --------------------------- |
| |
| procedure Generate_Index_Checks |
| (N : Node_Id; |
| Checks_Generated : out Dimension_Set) |
| is |
| |
| function Entity_Of_Prefix return Entity_Id; |
| -- Returns the entity of the prefix of N (or Empty if not found) |
| |
| ---------------------- |
| -- Entity_Of_Prefix -- |
| ---------------------- |
| |
| function Entity_Of_Prefix return Entity_Id is |
| P : Node_Id; |
| |
| begin |
| P := Prefix (N); |
| while not Is_Entity_Name (P) loop |
| if Nkind (P) not in N_Selected_Component | N_Indexed_Component then |
| return Empty; |
| end if; |
| |
| P := Prefix (P); |
| end loop; |
| |
| return Entity (P); |
| end Entity_Of_Prefix; |
| |
| -- Local variables |
| |
| Loc : constant Source_Ptr := Sloc (N); |
| A : constant Node_Id := Prefix (N); |
| A_Ent : constant Entity_Id := Entity_Of_Prefix; |
| Sub : Node_Id; |
| |
| -- Start of processing for Generate_Index_Checks |
| |
| begin |
| Checks_Generated.Elements := (others => False); |
| |
| -- Ignore call if the prefix is not an array since we have a serious |
| -- error in the sources. Ignore it also if index checks are suppressed |
| -- for array object or type. |
| |
| if not Is_Array_Type (Etype (A)) |
| or else (Present (A_Ent) and then Index_Checks_Suppressed (A_Ent)) |
| 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 |
| -- a condition of the form: |
| |
| -- Base_Type (Sub) not in Array'Range (Subscript) |
| |
| -- Note that the reason we generate the conversion to the base type here |
| -- is that we definitely want the range check to take place, even if it |
| -- looks like the subtype is OK. Optimization considerations that allow |
| -- us to omit the check have already been taken into account in the |
| -- setting of the Do_Range_Check flag earlier on. |
| |
| Sub := First (Expressions (N)); |
| |
| -- Handle string literals |
| |
| if Ekind (Etype (A)) = E_String_Literal_Subtype then |
| if Do_Range_Check (Sub) then |
| Set_Do_Range_Check (Sub, False); |
| |
| -- For string literals we obtain the bounds of the string from the |
| -- associated subtype. |
| |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Not_In (Loc, |
| Left_Opnd => |
| Convert_To (Base_Type (Etype (Sub)), |
| Duplicate_Subexpr_Move_Checks (Sub)), |
| Right_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Etype (A), Loc), |
| Attribute_Name => Name_Range)), |
| Reason => CE_Index_Check_Failed)); |
| |
| Checks_Generated.Elements (1) := True; |
| end if; |
| |
| -- General case |
| |
| else |
| declare |
| A_Idx : Node_Id; |
| A_Range : Node_Id; |
| Ind : Pos; |
| Num : List_Id; |
| Range_N : Node_Id; |
| |
| begin |
| A_Idx := First_Index (Etype (A)); |
| Ind := 1; |
| while Present (Sub) loop |
| if Do_Range_Check (Sub) then |
| Set_Do_Range_Check (Sub, False); |
| |
| -- Force evaluation except for the case of a simple name of |
| -- a nonvolatile entity. |
| |
| if not Is_Entity_Name (Sub) |
| or else Treat_As_Volatile (Entity (Sub)) |
| then |
| Force_Evaluation (Sub); |
| end if; |
| |
| if Nkind (A_Idx) = N_Range then |
| A_Range := A_Idx; |
| |
| elsif Nkind (A_Idx) in N_Identifier | N_Expanded_Name then |
| A_Range := Scalar_Range (Entity (A_Idx)); |
| |
| if Nkind (A_Range) = N_Subtype_Indication then |
| A_Range := Range_Expression (Constraint (A_Range)); |
| end if; |
| |
| else pragma Assert (Nkind (A_Idx) = N_Subtype_Indication); |
| A_Range := Range_Expression (Constraint (A_Idx)); |
| end if; |
| |
| -- For array objects with constant bounds we can generate |
| -- the index check using the bounds of the type of the index |
| |
| if Present (A_Ent) |
| and then Ekind (A_Ent) = E_Variable |
| and then Is_Constant_Bound (Low_Bound (A_Range)) |
| and then Is_Constant_Bound (High_Bound (A_Range)) |
| then |
| Range_N := |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Etype (A_Idx), Loc), |
| Attribute_Name => Name_Range); |
| |
| -- For arrays with non-constant bounds we cannot generate |
| -- the index check using the bounds of the type of the index |
| -- since it may reference discriminants of some enclosing |
| -- type. We obtain the bounds directly from the prefix |
| -- object. |
| |
| else |
| if Ind = 1 then |
| Num := No_List; |
| else |
| Num := New_List (Make_Integer_Literal (Loc, Ind)); |
| end if; |
| |
| Range_N := |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Duplicate_Subexpr_Move_Checks (A, Name_Req => True), |
| Attribute_Name => Name_Range, |
| Expressions => Num); |
| end if; |
| |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Not_In (Loc, |
| Left_Opnd => |
| Convert_To (Base_Type (Etype (Sub)), |
| Duplicate_Subexpr_Move_Checks (Sub)), |
| Right_Opnd => Range_N), |
| Reason => CE_Index_Check_Failed)); |
| |
| Checks_Generated.Elements (Ind) := True; |
| end if; |
| |
| Next_Index (A_Idx); |
| Ind := Ind + 1; |
| Next (Sub); |
| end loop; |
| end; |
| end if; |
| end Generate_Index_Checks; |
| |
| -------------------------- |
| -- Generate_Range_Check -- |
| -------------------------- |
| |
| procedure Generate_Range_Check |
| (N : Node_Id; |
| Target_Type : Entity_Id; |
| Reason : RT_Exception_Code) |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Source_Type : constant Entity_Id := Etype (N); |
| Source_Base_Type : constant Entity_Id := Base_Type (Source_Type); |
| Target_Base_Type : constant Entity_Id := Base_Type (Target_Type); |
| |
| procedure Convert_And_Check_Range (Suppress : Check_Id); |
| -- Convert N to the target base type and save the result in a temporary. |
| -- The action is analyzed using the default checks as modified by the |
| -- given Suppress argument. Then check the converted value against the |
| -- range of the target subtype. |
| |
| function Is_Single_Attribute_Reference (N : Node_Id) return Boolean; |
| -- Return True if N is an expression that contains a single attribute |
| -- reference, possibly as operand among only integer literal operands. |
| |
| ----------------------------- |
| -- Convert_And_Check_Range -- |
| ----------------------------- |
| |
| procedure Convert_And_Check_Range (Suppress : Check_Id) is |
| Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); |
| Conv_N : Node_Id; |
| |
| begin |
| -- For enumeration types with non-standard representation this is a |
| -- direct conversion from the enumeration type to the target integer |
| -- type, which is treated by the back end as a normal integer type |
| -- conversion, treating the enumeration type as an integer, which is |
| -- exactly what we want. We set Conversion_OK to make sure that the |
| -- analyzer does not complain about what otherwise might be an |
| -- illegal conversion. |
| |
| if Is_Enumeration_Type (Source_Base_Type) |
| and then Present (Enum_Pos_To_Rep (Source_Base_Type)) |
| and then Is_Integer_Type (Target_Base_Type) |
| then |
| Conv_N := OK_Convert_To (Target_Base_Type, Duplicate_Subexpr (N)); |
| else |
| Conv_N := Convert_To (Target_Base_Type, Duplicate_Subexpr (N)); |
| end if; |
| |
| -- We make a temporary to hold the value of the conversion to the |
| -- target base type, and then do the test against this temporary. |
| -- N itself is replaced by an occurrence of Tnn and followed by |
| -- the explicit range check. |
| |
| -- Tnn : constant Target_Base_Type := Target_Base_Type (N); |
| -- [constraint_error when Tnn not in Target_Type] |
| -- Tnn |
| |
| Insert_Actions (N, New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Tnn, |
| Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc), |
| Constant_Present => True, |
| Expression => Conv_N), |
| |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Not_In (Loc, |
| Left_Opnd => New_Occurrence_Of (Tnn, Loc), |
| Right_Opnd => New_Occurrence_Of (Target_Type, Loc)), |
| Reason => Reason)), |
| Suppress => Suppress); |
| |
| Rewrite (N, New_Occurrence_Of (Tnn, Loc)); |
| |
| -- Set the type of N, because the declaration for Tnn might not |
| -- be analyzed yet, as is the case if N appears within a record |
| -- declaration, as a discriminant constraint or expression. |
| |
| Set_Etype (N, Target_Base_Type); |
| end Convert_And_Check_Range; |
| |
| ------------------------------------- |
| -- Is_Single_Attribute_Reference -- |
| ------------------------------------- |
| |
| function Is_Single_Attribute_Reference (N : Node_Id) return Boolean is |
| begin |
| if Nkind (N) = N_Attribute_Reference then |
| return True; |
| |
| elsif Nkind (N) in N_Binary_Op then |
| if Nkind (Right_Opnd (N)) = N_Integer_Literal then |
| return Is_Single_Attribute_Reference (Left_Opnd (N)); |
| |
| elsif Nkind (Left_Opnd (N)) = N_Integer_Literal then |
| return Is_Single_Attribute_Reference (Right_Opnd (N)); |
| |
| else |
| return False; |
| end if; |
| |
| else |
| return False; |
| end if; |
| end Is_Single_Attribute_Reference; |
| |
| -- Start of processing for Generate_Range_Check |
| |
| begin |
| -- First special case, if the source type is already within the range |
| -- of the target type, then no check is needed (probably we should have |
| -- stopped Do_Range_Check from being set in the first place, but better |
| -- late than never in preventing junk code and junk flag settings). |
| |
| if In_Subrange_Of (Source_Type, Target_Type) |
| |
| -- We do NOT apply this if the source node is a literal, since in this |
| -- case the literal has already been labeled as having the subtype of |
| -- the target. |
| |
| and then not |
| (Nkind (N) in |
| N_Integer_Literal | N_Real_Literal | N_Character_Literal |
| or else |
| (Is_Entity_Name (N) |
| and then Ekind (Entity (N)) = E_Enumeration_Literal)) |
| then |
| Set_Do_Range_Check (N, False); |
| return; |
| end if; |
| |
| -- Here a check is needed. If the expander is not active (which is also |
| -- the case in GNATprove mode), then simply set the Do_Range_Check flag |
| -- and we are done. We just want to see the range check flag set, we do |
| -- not want to generate the explicit range check code. |
| |
| if not Expander_Active then |
| Set_Do_Range_Check (N); |
| return; |
| end if; |
| |
| -- Here we will generate an explicit range check, so we don't want to |
| -- set the Do_Range check flag, since the range check is taken care of |
| -- by the code we will generate. |
| |
| Set_Do_Range_Check (N, False); |
| |
| -- Force evaluation of the node, so that it does not get evaluated twice |
| -- (once for the check, once for the actual reference). Such a double |
| -- evaluation is always a potential source of inefficiency, and is |
| -- functionally incorrect in the volatile case. |
| |
| -- We skip the evaluation of attribute references because, after these |
| -- runtime checks are generated, the expander may need to rewrite this |
| -- node (for example, see Attribute_Max_Size_In_Storage_Elements in |
| -- Expand_N_Attribute_Reference) and, in many cases, their return type |
| -- is universal integer, which is a very large type for a temporary. |
| |
| if not Is_Single_Attribute_Reference (N) |
| and then (not Is_Entity_Name (N) |
| or else Treat_As_Volatile (Entity (N))) |
| then |
| Force_Evaluation (N, Mode => Strict); |
| end if; |
| |
| -- The easiest case is when Source_Base_Type and Target_Base_Type are |
| -- the same since in this case we can simply do a direct check of the |
| -- value of N against the bounds of Target_Type. |
| |
| -- [constraint_error when N not in Target_Type] |
| |
| -- Note: this is by far the most common case, for example all cases of |
| -- checks on the RHS of assignments are in this category, but not all |
| -- cases are like this. Notably conversions can involve two types. |
| |
| if Source_Base_Type = Target_Base_Type then |
| |
| -- Insert the explicit range check. Note that we suppress checks for |
| -- this code, since we don't want a recursive range check popping up. |
| |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Not_In (Loc, |
| Left_Opnd => Duplicate_Subexpr (N), |
| Right_Opnd => New_Occurrence_Of (Target_Type, Loc)), |
| Reason => Reason), |
| Suppress => All_Checks); |
| |
| -- Next test for the case where the target type is within the bounds |
| -- of the base type of the source type, since in this case we can |
| -- simply convert the bounds of the target type to this base type |
| -- to do the test. |
| |
| -- [constraint_error when N not in |
| -- Source_Base_Type (Target_Type'First) |
| -- .. |
| -- Source_Base_Type(Target_Type'Last))] |
| |
| -- 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 the explicit range check. Note that we suppress checks for |
| -- this code, since we don't want a recursive range check popping up. |
| |
| if Is_Discrete_Type (Source_Base_Type) |
| and then |
| Is_Discrete_Type (Target_Base_Type) |
| then |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Not_In (Loc, |
| Left_Opnd => Duplicate_Subexpr (N), |
| |
| Right_Opnd => |
| Make_Range (Loc, |
| Low_Bound => |
| Unchecked_Convert_To (Source_Base_Type, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Target_Type, Loc), |
| Attribute_Name => Name_First)), |
| |
| High_Bound => |
| Unchecked_Convert_To (Source_Base_Type, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Target_Type, Loc), |
| Attribute_Name => Name_Last)))), |
| Reason => Reason), |
| Suppress => All_Checks); |
| |
| -- For conversions involving at least one type that is not discrete, |
| -- first convert to the target base type and then generate the range |
| -- check. This avoids problems with values that are close to a bound |
| -- of the target type that would fail a range check when done in a |
| -- larger source type before converting but pass if converted with |
| -- rounding and then checked (such as in float-to-float conversions). |
| |
| -- Note that overflow checks are not suppressed for this code because |
| -- we do not know whether the source type is in range of the target |
| -- base type (unlike in the next case below). |
| |
| else |
| Convert_And_Check_Range (Suppress => Range_Check); |
| end if; |
| |
| -- Note that at this stage we know that the Target_Base_Type is not in |
| -- the range of the Source_Base_Type (since even the Target_Type itself |
| -- is not in this range). It could still be the case that Source_Type is |
| -- in range of the target base type since we have not checked that case. |
| |
| -- If that is the case, we can freely convert the source to the target, |
| -- and then test the target result against the bounds. Note that checks |
| -- are suppressed for this code, since we don't want a recursive range |
| -- check popping up. |
| |
| elsif In_Subrange_Of (Source_Type, Target_Base_Type) then |
| Convert_And_Check_Range (Suppress => All_Checks); |
| |
| -- At this stage, we know that we have two scalar types, which are |
| -- directly convertible, and where neither scalar type has a base |
| -- range that is in the range of the other scalar type. |
| |
| -- The only way this can happen is with a signed and unsigned type. |
| -- So test for these two cases: |
| |
| else |
| -- Case of the source is unsigned and the target is signed |
| |
| if Is_Unsigned_Type (Source_Base_Type) |
| and then not Is_Unsigned_Type (Target_Base_Type) |
| then |
| -- If the source is unsigned and the target is signed, then we |
| -- know that the source is not shorter than the target (otherwise |
| -- the source base type would be in the target base type range). |
| |
| -- In other words, the unsigned type is either the same size as |
| -- the target, or it is larger. It cannot be smaller. |
| |
| pragma Assert |
| (Esize (Source_Base_Type) >= Esize (Target_Base_Type)); |
| |
| -- We only need to check the low bound if the low bound of the |
| -- target type is non-negative. If the low bound of the target |
| -- type is negative, then we know that we will fit fine. |
| |
| -- If the high bound of the target type is negative, then we |
| -- know we have a constraint error, since we can't possibly |
| -- have a negative source. |
| |
| -- With these two checks out of the way, we can do the check |
| -- using the source type safely |
| |
| -- This is definitely the most annoying case. |
| |
| -- [constraint_error |
| -- when (Target_Type'First >= 0 |
| -- and then |
| -- N < Source_Base_Type (Target_Type'First)) |
| -- or else Target_Type'Last < 0 |
| -- or else N > Source_Base_Type (Target_Type'Last)]; |
| |
| -- We turn off all checks since we know that the conversions |
| -- will work fine, given the guards for negative values. |
| |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Or_Else (Loc, |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_And_Then (Loc, |
| Left_Opnd => Make_Op_Ge (Loc, |
| Left_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Target_Type, Loc), |
| Attribute_Name => Name_First), |
| Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), |
| |
| Right_Opnd => |
| Make_Op_Lt (Loc, |
| Left_Opnd => Duplicate_Subexpr (N), |
| Right_Opnd => |
| Convert_To (Source_Base_Type, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Target_Type, Loc), |
| Attribute_Name => Name_First)))), |
| |
| Right_Opnd => |
| Make_Op_Lt (Loc, |
| Left_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Target_Type, Loc), |
| Attribute_Name => Name_Last), |
| Right_Opnd => Make_Integer_Literal (Loc, Uint_0))), |
| |
| Right_Opnd => |
| Make_Op_Gt (Loc, |
| Left_Opnd => Duplicate_Subexpr (N), |
| Right_Opnd => |
| Convert_To (Source_Base_Type, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Target_Type, Loc), |
| Attribute_Name => Name_Last)))), |
| |
| Reason => Reason), |
| Suppress => All_Checks); |
| |
| -- Only remaining possibility is that the source is signed and |
| -- the target is unsigned. |
| |
| else |
| pragma Assert (not Is_Unsigned_Type (Source_Base_Type) |
| and then Is_Unsigned_Type (Target_Base_Type)); |
| |
| -- If the source is signed and the target is unsigned, then we |
| -- know that the target is not shorter than the source (otherwise |
| -- the target base type would be in the source base type range). |
| |
| -- In other words, the unsigned type is either the same size as |
| -- the target, or it is larger. It cannot be smaller. |
| |
| -- Clearly we have an error if the source value is negative since |
| -- no unsigned type can have negative values. If the source type |
| -- is non-negative, then the check can be done using the target |
| -- type. |
| |
| -- Tnn : constant Target_Base_Type (N) := Target_Type; |
| |
| -- [constraint_error |
| -- when N < 0 or else Tnn not in Target_Type]; |
| |
| -- We turn off all checks for the conversion of N to the target |
| -- base type, since we generate the explicit check to ensure that |
| -- the value is non-negative |
| |
| declare |
| Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); |
| |
| begin |
| Insert_Actions (N, New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Tnn, |
| Object_Definition => |
| New_Occurrence_Of (Target_Base_Type, Loc), |
| Constant_Present => True, |
| Expression => |
| Unchecked_Convert_To |
| (Target_Base_Type, Duplicate_Subexpr (N))), |
| |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Lt (Loc, |
| Left_Opnd => Duplicate_Subexpr (N), |
| Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), |
| |
| Right_Opnd => |
| Make_Not_In (Loc, |
| Left_Opnd => New_Occurrence_Of (Tnn, Loc), |
| Right_Opnd => |
| New_Occurrence_Of (Target_Type, Loc))), |
| |
| Reason => Reason)), |
| Suppress => All_Checks); |
| |
| -- Set the Etype explicitly, because Insert_Actions may have |
| -- placed the declaration in the freeze list for an enclosing |
| -- construct, and thus it is not analyzed yet. |
| |
| Set_Etype (Tnn, Target_Base_Type); |
| Rewrite (N, New_Occurrence_Of (Tnn, Loc)); |
| end; |
| end if; |
| end if; |
| end Generate_Range_Check; |
| |
| ------------------ |
| -- Get_Check_Id -- |
| ------------------ |
| |
| function Get_Check_Id (N : Name_Id) return Check_Id is |
| begin |
| -- For standard check name, we can do a direct computation |
| |
| if N in First_Check_Name .. Last_Check_Name then |
| return Check_Id (N - (First_Check_Name - 1)); |
| |
| -- For non-standard names added by pragma Check_Name, search table |
| |
| else |
| for J in All_Checks + 1 .. Check_Names.Last loop |
| if Check_Names.Table (J) = N then |
| return J; |
| end if; |
| end loop; |
| end if; |
| |
| -- No matching name found |
| |
| return No_Check_Id; |
| end Get_Check_Id; |
| |
| --------------------- |
| -- Get_Discriminal -- |
| --------------------- |
| |
| function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (E); |
| D : Entity_Id; |
| Sc : Entity_Id; |
| |
| begin |
| -- The bound can be a bona fide parameter of a protected operation, |
| -- rather than a prival encoded as an in-parameter. |
| |
| if No (Discriminal_Link (Entity (Bound))) then |
| return Bound; |
| end if; |
| |
| -- Climb the scope stack looking for an enclosing protected type. If |
| -- we run out of scopes, return the bound itself. |
| |
| Sc := Scope (E); |
| while Present (Sc) loop |
| if Sc = Standard_Standard then |
| return Bound; |
| elsif Ekind (Sc) = E_Protected_Type then |
| exit; |
| end if; |
| |
| Sc := Scope (Sc); |
| end loop; |
| |
| D := First_Discriminant (Sc); |
| while Present (D) loop |
| if Chars (D) = Chars (Bound) then |
| return New_Occurrence_Of (Discriminal (D), Loc); |
| end if; |
| |
| Next_Discriminant (D); |
| end loop; |
| |
| return Bound; |
| end Get_Discriminal; |
| |
| ---------------------- |
| -- Get_Range_Checks -- |
| ---------------------- |
| |
| function Get_Range_Checks |
| (Expr : Node_Id; |
| Target_Typ : Entity_Id; |
| Source_Typ : Entity_Id := Empty; |
| Warn_Node : Node_Id := Empty) return Check_Result |
| is |
| begin |
| return |
| Selected_Range_Checks (Expr, Target_Typ, Source_Typ, Warn_Node); |
| end Get_Range_Checks; |
| |
| ------------------ |
| -- Guard_Access -- |
| ------------------ |
| |
| function Guard_Access |
| (Cond : Node_Id; |
| Loc : Source_Ptr; |
| Expr : Node_Id) return Node_Id |
| is |
| begin |
| if Nkind (Cond) = N_Or_Else then |
| Set_Paren_Count (Cond, 1); |
| end if; |
| |
| if Nkind (Expr) = N_Allocator then |
| return Cond; |
| |
| else |
| return |
| Make_And_Then (Loc, |
| Left_Opnd => |
| Make_Op_Ne (Loc, |
| Left_Opnd => Duplicate_Subexpr_No_Checks (Expr), |
| Right_Opnd => Make_Null (Loc)), |
| Right_Opnd => Cond); |
| end if; |
| end Guard_Access; |
| |
| ----------------------------- |
| -- Index_Checks_Suppressed -- |
| ----------------------------- |
| |
| function Index_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if Present (E) and then Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Index_Check); |
| else |
| return Scope_Suppress.Suppress (Index_Check); |
| end if; |
| end Index_Checks_Suppressed; |
| |
| ---------------- |
| -- Initialize -- |
| ---------------- |
| |
| procedure Initialize is |
| begin |
| for J in Determine_Range_Cache_N'Range loop |
| Determine_Range_Cache_N (J) := Empty; |
| end loop; |
| |
| Check_Names.Init; |
| |
| for J in Int range 1 .. All_Checks loop |
| Check_Names.Append (Name_Id (Int (First_Check_Name) + J - 1)); |
| end loop; |
| end Initialize; |
| |
| ------------------------- |
| -- Insert_Range_Checks -- |
| ------------------------- |
| |
| procedure Insert_Range_Checks |
| (Checks : Check_Result; |
| Node : Node_Id; |
| Suppress_Typ : Entity_Id; |
| Static_Sloc : Source_Ptr; |
| Do_Before : Boolean := False) |
| is |
| Checks_On : constant Boolean := |
| not Index_Checks_Suppressed (Suppress_Typ) |
| or else |
| not Range_Checks_Suppressed (Suppress_Typ); |
| |
| Check_Node : Node_Id; |
| |
| begin |
| -- For now we just return if Checks_On is false, however this should be |
| -- enhanced to check for an always True value in the condition and to |
| -- generate a compilation warning. |
| |
| if not Expander_Active or not Checks_On then |
| return; |
| end if; |
| |
| for J in 1 .. 2 loop |
| exit when No (Checks (J)); |
| |
| if Nkind (Checks (J)) = N_Raise_Constraint_Error |
| and then Present (Condition (Checks (J))) |
| then |
| Check_Node := Checks (J); |
| else |
| Check_Node := |
| Make_Raise_Constraint_Error (Static_Sloc, |
| Reason => CE_Range_Check_Failed); |
| end if; |
| |
| Mark_Rewrite_Insertion (Check_Node); |
| |
| if Do_Before then |
| Insert_Before_And_Analyze (Node, Check_Node); |
| else |
| Insert_After_And_Analyze (Node, Check_Node); |
| end if; |
| end loop; |
| end Insert_Range_Checks; |
| |
| ------------------------ |
| -- Insert_Valid_Check -- |
| ------------------------ |
| |
| procedure Insert_Valid_Check |
| (Expr : Node_Id; |
| Related_Id : Entity_Id := Empty; |
| Is_Low_Bound : Boolean := False; |
| Is_High_Bound : Boolean := False) |
| is |
| Loc : constant Source_Ptr := Sloc (Expr); |
| Typ : Entity_Id := Etype (Expr); |
| Exp : Node_Id; |
| |
| begin |
| -- Do not insert if checks off, or if not checking validity or if |
| -- expression is known to be valid. |
| |
| if not Validity_Checks_On |
| or else Range_Or_Validity_Checks_Suppressed (Expr) |
| or else Expr_Known_Valid (Expr) |
| then |
| return; |
| |
| -- Do not insert checks within a predicate function. This will arise |
| -- if the current unit and the predicate function are being compiled |
| -- with validity checks enabled. |
| |
| elsif Present (Predicate_Function (Typ)) |
| and then Current_Scope = Predicate_Function (Typ) |
| then |
| return; |
| |
| -- If the expression is a packed component of a modular type of the |
| -- right size, the data is always valid. |
| |
| elsif Nkind (Expr) = N_Selected_Component |
| and then Present (Component_Clause (Entity (Selector_Name (Expr)))) |
| and then Is_Modular_Integer_Type (Typ) |
| and then Modulus (Typ) = 2 ** Esize (Entity (Selector_Name (Expr))) |
| then |
| return; |
| |
| -- Do not generate a validity check when inside a generic unit as this |
| -- is an expansion activity. |
| |
| elsif Inside_A_Generic then |
| return; |
| end if; |
| |
| -- Entities declared in Lock_free protected types must be treated as |
| -- volatile, and we must inhibit validity checks to prevent improper |
| -- constant folding. |
| |
| if Is_Entity_Name (Expr) |
| and then Is_Subprogram (Scope (Entity (Expr))) |
| and then Present (Protected_Subprogram (Scope (Entity (Expr)))) |
| and then Uses_Lock_Free |
| (Scope (Protected_Subprogram (Scope (Entity (Expr))))) |
| then |
| return; |
| end if; |
| |
| -- If we have a checked conversion, then validity check applies to |
| -- the expression inside the conversion, not the result, since if |
| -- the expression inside is valid, then so is the conversion result. |
| |
| Exp := Expr; |
| while Nkind (Exp) = N_Type_Conversion loop |
| Exp := Expression (Exp); |
| end loop; |
| Typ := Etype (Exp); |
| |
| -- Do not generate a check for a variable which already validates the |
| -- value of an assignable object. |
| |
| if Is_Validation_Variable_Reference (Exp) then |
| return; |
| end if; |
| |
| declare |
| CE : Node_Id; |
| PV : Node_Id; |
| Var_Id : Entity_Id; |
| |
| begin |
| -- If the expression denotes an assignable object, capture its value |
| -- in a variable and replace the original expression by the variable. |
| -- This approach has several effects: |
| |
| -- 1) The evaluation of the object results in only one read in the |
| -- case where the object is atomic or volatile. |
| |
| -- Var ... := Object; -- read |
| |
| -- 2) The captured value is the one verified by attribute 'Valid. |
| -- As a result the object is not evaluated again, which would |
| -- result in an unwanted read in the case where the object is |
| -- atomic or volatile. |
| |
| -- if not Var'Valid then -- OK, no read of Object |
| |
| -- if not Object'Valid then -- Wrong, extra read of Object |
| |
| -- 3) The captured value replaces the original object reference. |
| -- As a result the object is not evaluated again, in the same |
| -- vein as 2). |
| |
| -- ... Var ... -- OK, no read of Object |
| |
| -- ... Object ... -- Wrong, extra read of Object |
| |
| -- 4) The use of a variable to capture the value of the object |
| -- allows the propagation of any changes back to the original |
| -- object. |
| |
| -- procedure Call (Val : in out ...); |
| |
| -- Var : ... := Object; -- read Object |
| -- if not Var'Valid then -- validity check |
| -- Call (Var); -- modify Var |
| -- Object := Var; -- update Object |
| |
| if Is_Variable (Exp) then |
| Var_Id := Make_Temporary (Loc, 'T', Exp); |
| |
| -- Because we could be dealing with a transient scope which would |
| -- cause our object declaration to remain unanalyzed we must do |
| -- some manual decoration. |
| |
| Mutate_Ekind (Var_Id, E_Variable); |
| Set_Etype (Var_Id, Typ); |
| |
| Insert_Action (Exp, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Var_Id, |
| Object_Definition => New_Occurrence_Of (Typ, Loc), |
| Expression => New_Copy_Tree (Exp)), |
| Suppress => Validity_Check); |
| |
| Set_Validated_Object (Var_Id, New_Copy_Tree (Exp)); |
| |
| Rewrite (Exp, New_Occurrence_Of (Var_Id, Loc)); |
| |
| -- Move the Do_Range_Check flag over to the new Exp so it doesn't |
| -- get lost and doesn't leak elsewhere. |
| |
| if Do_Range_Check (Validated_Object (Var_Id)) then |
| Set_Do_Range_Check (Exp); |
| Set_Do_Range_Check (Validated_Object (Var_Id), False); |
| end if; |
| |
| -- In case of a type conversion, an expansion of the expr may be |
| -- needed (eg. fixed-point as actual). |
| |
| if Exp /= Expr then |
| pragma Assert (Nkind (Expr) = N_Type_Conversion); |
| Analyze_And_Resolve (Expr); |
| end if; |
| |
| PV := New_Occurrence_Of (Var_Id, Loc); |
| |
| -- Otherwise the expression does not denote a variable. Force its |
| -- evaluation by capturing its value in a constant. Generate: |
| |
| -- Temp : constant ... := Exp; |
| |
| else |
| Force_Evaluation |
| (Exp => Exp, |
| Related_Id => Related_Id, |
| Is_Low_Bound => Is_Low_Bound, |
| Is_High_Bound => Is_High_Bound); |
| |
| PV := New_Copy_Tree (Exp); |
| end if; |
| |
| -- A rather specialized test. 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. If the prefix is an access value, |
| -- the dereference will be added later. |
| |
| -- 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 Is_Array_Type (Etype (Prefix (PV))) |
| and then Present (Packed_Array_Impl_Type (Etype (Prefix (PV)))) |
| then |
| Set_Analyzed (PV, False); |
| end if; |
| |
| -- Build the raise CE node to check for validity. We build a type |
| -- qualification for the prefix, since it may not be of the form of |
| -- a name, and we don't care in this context! |
| |
| CE := |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Op_Not (Loc, |
| Right_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => PV, |
| Attribute_Name => Name_Valid)), |
| 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 |
| -- expression is an actual in a call, it has not been expanded, |
| -- waiting for the proper point at which to do it. The same happens |
| -- with renamings, so that we have to force the expansion now. This |
| -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb |
| -- and exp_ch6.adb. |
| |
| if Is_Entity_Name (Exp) |
| and then Nkind (Parent (Entity (Exp))) = |
| N_Object_Renaming_Declaration |
| then |
| declare |
| Old_Exp : constant Node_Id := Name (Parent (Entity (Exp))); |
| begin |
| if Nkind (Old_Exp) = N_Indexed_Component |
| and then Is_Bit_Packed_Array (Etype (Prefix (Old_Exp))) |
| then |
| Expand_Packed_Element_Reference (Old_Exp); |
| end if; |
| end; |
| end if; |
| end; |
| end Insert_Valid_Check; |
| |
| ------------------------------------- |
| -- Is_Signed_Integer_Arithmetic_Op -- |
| ------------------------------------- |
| |
| function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean is |
| begin |
| case Nkind (N) is |
| when N_Op_Abs |
| | N_Op_Add |
| | N_Op_Divide |
| | N_Op_Expon |
| | N_Op_Minus |
| | N_Op_Mod |
| | N_Op_Multiply |
| | N_Op_Plus |
| | N_Op_Rem |
| | N_Op_Subtract |
| => |
| return Is_Signed_Integer_Type (Etype (N)); |
| |
| when N_Case_Expression |
| | N_If_Expression |
| => |
| return Is_Signed_Integer_Type (Etype (N)); |
| |
| when others => |
| return False; |
| end case; |
| end Is_Signed_Integer_Arithmetic_Op; |
| |
| ---------------------------------- |
| -- Install_Null_Excluding_Check -- |
| ---------------------------------- |
| |
| procedure Install_Null_Excluding_Check (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (Parent (N)); |
| Typ : constant Entity_Id := Etype (N); |
| |
| procedure Mark_Non_Null; |
| -- After installation of check, if the node in question is an entity |
| -- name, then mark this entity as non-null if possible. |
| |
| ------------------- |
| -- Mark_Non_Null -- |
| ------------------- |
| |
| procedure Mark_Non_Null is |
| begin |
| -- Only case of interest is if node N is an entity name |
| |
| if Is_Entity_Name (N) then |
| |
| -- For sure, we want to clear an indication that this is known to |
| -- be null, since if we get past this check, it definitely is not. |
| |
| Set_Is_Known_Null (Entity (N), False); |
| |
| -- We can mark the entity as known to be non-null if it is safe to |
| -- capture the value. |
| |
| if Safe_To_Capture_Value (N, Entity (N)) then |
| Set_Is_Known_Non_Null (Entity (N)); |
| end if; |
| end if; |
| end Mark_Non_Null; |
| |
| -- Start of processing for Install_Null_Excluding_Check |
| |
| begin |
| -- No need to add null-excluding checks when the tree may not be fully |
| -- decorated. |
| |
| if Serious_Errors_Detected > 0 then |
| return; |
| end if; |
| |
| pragma Assert (Is_Access_Type (Typ)); |
| |
| -- No check inside a generic, check will be emitted in instance |
| |
| if Inside_A_Generic then |
| return; |
| end if; |
| |
| -- No check needed if known to be non-null |
| |
| if Known_Non_Null (N) then |
| return; |
| end if; |
| |
| -- If known to be null, here is where we generate a compile time check |
| |
| if Known_Null (N) then |
| |
| -- Avoid generating warning message inside init procs. In SPARK mode |
| -- we can go ahead and call Apply_Compile_Time_Constraint_Error |
| -- since it will be turned into an error in any case. |
| |
| if (not Inside_Init_Proc or else SPARK_Mode = On) |
| |
| -- Do not emit the warning within a conditional expression, |
| -- where the expression might not be evaluated, and the warning |
| -- appear as extraneous noise. |
| |
| and then not Within_Case_Or_If_Expression (N) |
| then |
| Apply_Compile_Time_Constraint_Error |
| (N, "null value not allowed here??", CE_Access_Check_Failed); |
| |
| -- Remaining cases, where we silently insert the raise |
| |
| else |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Reason => CE_Access_Check_Failed)); |
| end if; |
| |
| Mark_Non_Null; |
| return; |
| end if; |
| |
| -- If entity is never assigned, for sure a warning is appropriate |
| |
| if Is_Entity_Name (N) then |
| Check_Unset_Reference (N); |
| end if; |
| |
| -- No check needed if checks are suppressed on the range. Note that we |
| -- don't set Is_Known_Non_Null in this case (we could legitimately do |
| -- so, since the program is erroneous, but we don't like to casually |
| -- propagate such conclusions from erroneosity). |
| |
| if Access_Checks_Suppressed (Typ) then |
| return; |
| end if; |
| |
| -- No check needed for access to concurrent record types generated by |
| -- the expander. This is not just an optimization (though it does indeed |
| -- remove junk checks). It also avoids generation of junk warnings. |
| |
| if Nkind (N) in N_Has_Chars |
| and then Chars (N) = Name_uObject |
| and then Is_Concurrent_Record_Type |
| (Directly_Designated_Type (Etype (N))) |
| then |
| return; |
| end if; |
| |
| -- No check needed in interface thunks since the runtime check is |
| -- already performed at the caller side. |
| |
| if Is_Thunk (Current_Scope) then |
| return; |
| end if; |
| |
| -- In GNATprove mode, we do not apply the check |
| |
| if GNATprove_Mode then |
| return; |
| end if; |
| |
| -- Otherwise install access check |
| |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => Duplicate_Subexpr_Move_Checks (N), |
| Right_Opnd => Make_Null (Loc)), |
| Reason => CE_Access_Check_Failed)); |
| |
| Mark_Non_Null; |
| end Install_Null_Excluding_Check; |
| |
| ----------------------------------------- |
| -- Install_Primitive_Elaboration_Check -- |
| ----------------------------------------- |
| |
| procedure Install_Primitive_Elaboration_Check (Subp_Body : Node_Id) is |
| function Within_Compilation_Unit_Instance |
| (Subp_Id : Entity_Id) return Boolean; |
| -- Determine whether subprogram Subp_Id appears within an instance which |
| -- acts as a compilation unit. |
| |
| -------------------------------------- |
| -- Within_Compilation_Unit_Instance -- |
| -------------------------------------- |
| |
| function Within_Compilation_Unit_Instance |
| (Subp_Id : Entity_Id) return Boolean |
| is |
| Pack : Entity_Id; |
| |
| begin |
| -- Examine the scope chain looking for a compilation-unit-level |
| -- instance. |
| |
| Pack := Scope (Subp_Id); |
| while Present (Pack) and then Pack /= Standard_Standard loop |
| if Ekind (Pack) = E_Package |
| and then Is_Generic_Instance (Pack) |
| and then Nkind (Parent (Unit_Declaration_Node (Pack))) = |
| N_Compilation_Unit |
| then |
| return True; |
| end if; |
| |
| Pack := Scope (Pack); |
| end loop; |
| |
| return False; |
| end Within_Compilation_Unit_Instance; |
| |
| -- Local declarations |
| |
| Context : constant Node_Id := Parent (Subp_Body); |
| Loc : constant Source_Ptr := Sloc (Subp_Body); |
| Subp_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Body); |
| Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); |
| |
| Decls : List_Id; |
| Flag_Id : Entity_Id; |
| Set_Ins : Node_Id; |
| Set_Stmt : Node_Id; |
| Tag_Typ : Entity_Id; |
| |
| -- Start of processing for Install_Primitive_Elaboration_Check |
| |
| begin |
| -- Do not generate an elaboration check in compilation modes where |
| -- expansion is not desirable. |
| |
| if GNATprove_Mode then |
| return; |
| |
| -- Do not generate an elaboration check if all checks have been |
| -- suppressed. |
| |
| elsif Suppress_Checks then |
| return; |
| |
| -- Do not generate an elaboration check if the related subprogram is |
| -- not subject to elaboration checks. |
| |
| elsif Elaboration_Checks_Suppressed (Subp_Id) then |
| return; |
| |
| -- Do not generate an elaboration check if such code is not desirable |
| |
| elsif Restriction_Active (No_Elaboration_Code) then |
| return; |
| |
| -- If pragma Pure or Preelaborate applies, then these elaboration checks |
| -- cannot fail, so do not generate them. |
| |
| elsif In_Preelaborated_Unit then |
| return; |
| |
| -- Do not generate an elaboration check if exceptions cannot be used, |
| -- caught, or propagated. |
| |
| elsif not Exceptions_OK then |
| return; |
| |
| -- Do not consider subprograms that are compilation units, because they |
| -- cannot be the target of a dispatching call. |
| |
| elsif Nkind (Context) = N_Compilation_Unit then |
| return; |
| |
| -- Do not consider anything other than nonabstract library-level source |
| -- primitives. |
| |
| elsif not |
| (Comes_From_Source (Subp_Id) |
| and then Is_Library_Level_Entity (Subp_Id) |
| and then Is_Primitive (Subp_Id) |
| and then not Is_Abstract_Subprogram (Subp_Id)) |
| then |
| return; |
| |
| -- Do not consider inlined primitives, because once the body is inlined |
| -- the reference to the elaboration flag will be out of place and will |
| -- result in an undefined symbol. |
| |
| elsif Is_Inlined (Subp_Id) or else Has_Pragma_Inline (Subp_Id) then |
| return; |
| |
| -- Do not generate a duplicate elaboration check. This happens only in |
| -- the case of primitives completed by an expression function, as the |
| -- corresponding body is apparently analyzed and expanded twice. |
| |
| elsif Analyzed (Subp_Body) then |
| return; |
| |
| -- Do not consider primitives that occur within an instance that is a |
| -- compilation unit. Such an instance defines its spec and body out of |
| -- order (body is first) within the tree, which causes the reference to |
| -- the elaboration flag to appear as an undefined symbol. |
| |
| elsif Within_Compilation_Unit_Instance (Subp_Id) then |
| return; |
| end if; |
| |
| Tag_Typ := Find_Dispatching_Type (Subp_Id); |
| |
| -- Only tagged primitives may be the target of a dispatching call |
| |
| if No (Tag_Typ) then |
| return; |
| |
| -- Do not consider finalization-related primitives, because they may |
| -- need to be called while elaboration is taking place. |
| |
| elsif Is_Controlled (Tag_Typ) |
| and then |
| Chars (Subp_Id) in Name_Adjust | Name_Finalize | Name_Initialize |
| then |
| return; |
| end if; |
| |
| -- Create the declaration of the elaboration flag. The name carries a |
| -- unique counter in case of name overloading. |
| |
| Flag_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (Subp_Id), 'E', -1)); |
| Set_Is_Frozen (Flag_Id); |
| |
| -- Insert the declaration of the elaboration flag in front of the |
| -- primitive spec and analyze it in the proper context. |
| |
| Push_Scope (Scope (Subp_Id)); |
| |
| -- Generate: |
| -- E : Boolean := False; |
| |
| Insert_Action (Subp_Decl, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Flag_Id, |
| Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => New_Occurrence_Of (Standard_False, Loc))); |
| Pop_Scope; |
| |
| -- Prevent the compiler from optimizing the elaboration check by killing |
| -- the current value of the flag and the associated assignment. |
| |
| Set_Current_Value (Flag_Id, Empty); |
| Set_Last_Assignment (Flag_Id, Empty); |
| |
| -- Add a check at the top of the body declarations to ensure that the |
| -- elaboration flag has been set. |
| |
| Decls := Declarations (Subp_Body); |
| |
| if No (Decls) then |
| Decls := New_List; |
| Set_Declarations (Subp_Body, Decls); |
| end if; |
| |
| -- Generate: |
| -- if not F then |
| -- raise Program_Error with "access before elaboration"; |
| -- end if; |
| |
| Prepend_To (Decls, |
| Make_Raise_Program_Error (Loc, |
| Condition => |
| Make_Op_Not (Loc, |
| Right_Opnd => New_Occurrence_Of (Flag_Id, Loc)), |
| Reason => PE_Access_Before_Elaboration)); |
| |
| Analyze (First (Decls)); |
| |
| -- Set the elaboration flag once the body has been elaborated. Insert |
| -- the statement after the subprogram stub when the primitive body is |
| -- a subunit. |
| |
| if Nkind (Context) = N_Subunit then |
| Set_Ins := Corresponding_Stub (Context); |
| else |
| Set_Ins := Subp_Body; |
| end if; |
| |
| -- Generate: |
| -- E := True; |
| |
| Set_Stmt := |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Flag_Id, Loc), |
| Expression => New_Occurrence_Of (Standard_True, Loc)); |
| |
| -- Mark the assignment statement as elaboration code. This allows the |
| -- early call region mechanism (see Sem_Elab) to properly ignore such |
| -- assignments even though they are non-preelaborable code. |
| |
| Set_Is_Elaboration_Code (Set_Stmt); |
| |
| Insert_After_And_Analyze (Set_Ins, Set_Stmt); |
| end Install_Primitive_Elaboration_Check; |
| |
| -------------------------- |
| -- Install_Static_Check -- |
| -------------------------- |
| |
| procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is |
| Stat : constant Boolean := Is_OK_Static_Expression (R_Cno); |
| Typ : constant Entity_Id := Etype (R_Cno); |
| |
| begin |
| Rewrite (R_Cno, |
| Make_Raise_Constraint_Error (Loc, |
| Reason => CE_Range_Check_Failed)); |
| Set_Analyzed (R_Cno); |
| Set_Etype (R_Cno, Typ); |
| Set_Raises_Constraint_Error (R_Cno); |
| Set_Is_Static_Expression (R_Cno, Stat); |
| |
| -- Now deal with possible local raise handling |
| |
| Possible_Local_Raise (R_Cno, Standard_Constraint_Error); |
| end Install_Static_Check; |
| |
| ------------------------- |
| -- Is_Check_Suppressed -- |
| ------------------------- |
| |
| function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is |
| Ptr : Suppress_Stack_Entry_Ptr; |
| |
| begin |
| -- First search the local entity suppress stack. We search this from the |
| -- top of the stack down so that we get the innermost entry that applies |
| -- to this case if there are nested entries. |
| |
| Ptr := Local_Suppress_Stack_Top; |
| while Ptr /= null loop |
| if (Ptr.Entity = Empty or else Ptr.Entity = E) |
| and then (Ptr.Check = All_Checks or else Ptr.Check = C) |
| then |
| return Ptr.Suppress; |
| end if; |
| |
| Ptr := Ptr.Prev; |
| end loop; |
| |
| -- Now search the global entity suppress table for a matching entry. |
| -- We also search this from the top down so that if there are multiple |
| -- pragmas for the same entity, the last one applies (not clear what |
| -- or whether the RM specifies this handling, but it seems reasonable). |
| |
| Ptr := Global_Suppress_Stack_Top; |
| while Ptr /= null loop |
| if (Ptr.Entity = Empty or else Ptr.Entity = E) |
| and then (Ptr.Check = All_Checks or else Ptr.Check = C) |
| then |
| return Ptr.Suppress; |
| end if; |
| |
| Ptr := Ptr.Prev; |
| end loop; |
| |
| -- If we did not find a matching entry, then use the normal scope |
| -- suppress value after all (actually this will be the global setting |
| -- since it clearly was not overridden at any point). For a predefined |
| -- check, we test the specific flag. For a user defined check, we check |
| -- the All_Checks flag. The Overflow flag requires special handling to |
| -- deal with the General vs Assertion case. |
| |
| if C = Overflow_Check then |
| return Overflow_Checks_Suppressed (Empty); |
| |
| elsif C in Predefined_Check_Id then |
| return Scope_Suppress.Suppress (C); |
| |
| else |
| return Scope_Suppress.Suppress (All_Checks); |
| end if; |
| end Is_Check_Suppressed; |
| |
| --------------------- |
| -- Kill_All_Checks -- |
| --------------------- |
| |
| procedure Kill_All_Checks is |
| begin |
| if Debug_Flag_CC then |
| w ("Kill_All_Checks"); |
| end if; |
| |
| -- We reset the number of saved checks to zero, and also modify all |
| -- stack entries for statement ranges to indicate that the number of |
| -- checks at each level is now zero. |
| |
| Num_Saved_Checks := 0; |
| |
| -- Note: the Int'Min here avoids any possibility of J being out of |
| -- range when called from e.g. Conditional_Statements_Begin. |
| |
| for J in 1 .. Int'Min (Saved_Checks_TOS, Saved_Checks_Stack'Last) loop |
| Saved_Checks_Stack (J) := 0; |
| end loop; |
| end Kill_All_Checks; |
| |
| ----------------- |
| -- Kill_Checks -- |
| ----------------- |
| |
| procedure Kill_Checks (V : Entity_Id) is |
| begin |
| if Debug_Flag_CC then |
| w ("Kill_Checks for entity", Int (V)); |
| end if; |
| |
| for J in 1 .. Num_Saved_Checks loop |
| if Saved_Checks (J).Entity = V then |
| if Debug_Flag_CC then |
| w (" Checks killed for saved check ", J); |
| end if; |
| |
| Saved_Checks (J).Killed := True; |
| end if; |
| end loop; |
| end Kill_Checks; |
| |
| ------------------------------ |
| -- Length_Checks_Suppressed -- |
| ------------------------------ |
| |
| function Length_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if Present (E) and then Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Length_Check); |
| else |
| return Scope_Suppress.Suppress (Length_Check); |
| end if; |
| end Length_Checks_Suppressed; |
| |
| ----------------------- |
| -- Make_Bignum_Block -- |
| ----------------------- |
| |
| function Make_Bignum_Block (Loc : Source_Ptr) return Node_Id is |
| M : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uM); |
| begin |
| return |
| Make_Block_Statement (Loc, |
| Declarations => |
| New_List (Build_SS_Mark_Call (Loc, M)), |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Build_SS_Release_Call (Loc, M)))); |
| end Make_Bignum_Block; |
| |
| ---------------------------------- |
| -- Minimize_Eliminate_Overflows -- |
| ---------------------------------- |
| |
| -- This is a recursive routine that is called at the top of an expression |
| -- tree to properly process overflow checking for a whole subtree by making |
| -- recursive calls to process operands. This processing may involve the use |
| -- of bignum or long long integer arithmetic, which will change the types |
| -- of operands and results. That's why we can't do this bottom up (since |
| -- it would interfere with semantic analysis). |
| |
| -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then |
| -- the operator expansion routines, as well as the expansion routines for |
| -- if/case expression, do nothing (for the moment) except call the routine |
| -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That |
| -- routine does nothing for non top-level nodes, so at the point where the |
| -- call is made for the top level node, the entire expression subtree has |
| -- not been expanded, or processed for overflow. All that has to happen as |
| -- a result of the top level call to this routine. |
| |
| -- As noted above, the overflow processing works by making recursive calls |
| -- for the operands, and figuring out what to do, based on the processing |
| -- of these operands (e.g. if a bignum operand appears, the parent op has |
| -- to be done in bignum mode), and the determined ranges of the operands. |
| |
| -- After possible rewriting of a constituent subexpression node, a call is |
| -- made to either reexpand the node (if nothing has changed) or reanalyze |
| -- the node (if it has been modified by the overflow check processing). The |
| -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid |
| -- a recursive call into the whole overflow apparatus, an important rule |
| -- for this call is that the overflow handling mode must be temporarily set |
| -- to STRICT. |
| |
| procedure Minimize_Eliminate_Overflows |
| (N : Node_Id; |
| Lo : out Uint; |
| Hi : out Uint; |
| Top_Level : Boolean) |
| is |
| Rtyp : constant Entity_Id := Etype (N); |
| pragma Assert (Is_Signed_Integer_Type (Rtyp)); |
| -- Result type, must be a signed integer type |
| |
| Check_Mode : constant Overflow_Mode_Type := Overflow_Check_Mode; |
| pragma Assert (Check_Mode in Minimized_Or_Eliminated); |
| |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| Rlo, Rhi : Uint; |
| -- Ranges of values for right operand (operator case) |
| |
| Llo : Uint := No_Uint; -- initialize to prevent warning |
| Lhi : Uint := No_Uint; -- initialize to prevent warning |
| -- Ranges of values for left operand (operator case) |
| |
| LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); |
| -- Operands and results are of this type when we convert |
| |
| LLLo : constant Uint := Intval (Type_Low_Bound (LLIB)); |
| LLHi : constant Uint := Intval (Type_High_Bound (LLIB)); |
| -- Bounds of Long_Long_Integer |
| |
| Binary : constant Boolean := Nkind (N) in N_Binary_Op; |
| -- Indicates binary operator case |
| |
| OK : Boolean; |
| -- Used in call to Determine_Range |
| |
| Bignum_Operands : Boolean; |
| -- Set True if one or more operands is already of type Bignum, meaning |
| -- that for sure (regardless of Top_Level setting) we are committed to |
| -- doing the operation in Bignum mode (or in the case of a case or if |
| -- expression, converting all the dependent expressions to Bignum). |
| |
| Long_Long_Integer_Operands : Boolean; |
| -- Set True if one or more operands is already of type Long_Long_Integer |
| -- which means that if the result is known to be in the result type |
| -- range, then we must convert such operands back to the result type. |
| |
| procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False); |
| -- This is called when we have modified the node and we therefore need |
| -- to reanalyze it. It is important that we reset the mode to STRICT for |
| -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode |
| -- we would reenter this routine recursively which would not be good. |
| -- The argument Suppress is set True if we also want to suppress |
| -- overflow checking for the reexpansion (this is set when we know |
| -- overflow is not possible). Typ is the type for the reanalysis. |
| |
| procedure Reexpand (Suppress : Boolean := False); |
| -- This is like Reanalyze, but does not do the Analyze step, it only |
| -- does a reexpansion. We do this reexpansion in STRICT mode, so that |
| -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we |
| -- follow the normal expansion path (e.g. converting A**4 to A**2**2). |
| -- Note that skipping reanalysis is not just an optimization, testing |
| -- has showed up several complex cases in which reanalyzing an already |
| -- analyzed node causes incorrect behavior. |
| |
| function In_Result_Range return Boolean; |
| -- Returns True iff Lo .. Hi are within range of the result type |
| |
| procedure Max (A : in out Uint; B : Uint); |
| -- If A is No_Uint, sets A to B, else to UI_Max (A, B) |
| |
| procedure Min (A : in out Uint; B : Uint); |
| -- If A is No_Uint, sets A to B, else to UI_Min (A, B) |
| |
| --------------------- |
| -- In_Result_Range -- |
| --------------------- |
| |
| function In_Result_Range return Boolean is |
| begin |
| if No (Lo) or else No (Hi) then |
| return False; |
| |
| elsif Is_OK_Static_Subtype (Etype (N)) then |
| return Lo >= Expr_Value (Type_Low_Bound (Rtyp)) |
| and then |
| Hi <= Expr_Value (Type_High_Bound (Rtyp)); |
| |
| else |
| return Lo >= Expr_Value (Type_Low_Bound (Base_Type (Rtyp))) |
| and then |
| Hi <= Expr_Value (Type_High_Bound (Base_Type (Rtyp))); |
| end if; |
| end In_Result_Range; |
| |
| --------- |
| -- Max -- |
| --------- |
| |
| procedure Max (A : in out Uint; B : Uint) is |
| begin |
| if No (A) or else B > A then |
| A := B; |
| end if; |
| end Max; |
| |
| --------- |
| -- Min -- |
| --------- |
| |
| procedure Min (A : in out Uint; B : Uint) is |
| begin |
| if No (A) or else B < A then |
| A := B; |
| end if; |
| end Min; |
| |
| --------------- |
| -- Reanalyze -- |
| --------------- |
| |
| procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False) is |
| Svg : constant Overflow_Mode_Type := |
| Scope_Suppress.Overflow_Mode_General; |
| Sva : constant Overflow_Mode_Type := |
| Scope_Suppress.Overflow_Mode_Assertions; |
| Svo : constant Boolean := |
| Scope_Suppress.Suppress (Overflow_Check); |
| |
| begin |
| Scope_Suppress.Overflow_Mode_General := Strict; |
| Scope_Suppress.Overflow_Mode_Assertions := Strict; |
| |
| if Suppress then |
| Scope_Suppress.Suppress (Overflow_Check) := True; |
| end if; |
| |
| Analyze_And_Resolve (N, Typ); |
| |
| Scope_Suppress.Suppress (Overflow_Check) := Svo; |
| Scope_Suppress.Overflow_Mode_General := Svg; |
| Scope_Suppress.Overflow_Mode_Assertions := Sva; |
| end Reanalyze; |
| |
| -------------- |
| -- Reexpand -- |
| -------------- |
| |
| procedure Reexpand (Suppress : Boolean := False) is |
| Svg : constant Overflow_Mode_Type := |
| Scope_Suppress.Overflow_Mode_General; |
| Sva : constant Overflow_Mode_Type := |
| Scope_Suppress.Overflow_Mode_Assertions; |
| Svo : constant Boolean := |
| Scope_Suppress.Suppress (Overflow_Check); |
| |
| begin |
| Scope_Suppress.Overflow_Mode_General := Strict; |
| Scope_Suppress.Overflow_Mode_Assertions := Strict; |
| Set_Analyzed (N, False); |
| |
| if Suppress then |
| Scope_Suppress.Suppress (Overflow_Check) := True; |
| end if; |
| |
| Expand (N); |
| |
| Scope_Suppress.Suppress (Overflow_Check) := Svo; |
| Scope_Suppress.Overflow_Mode_General := Svg; |
| Scope_Suppress.Overflow_Mode_Assertions := Sva; |
| end Reexpand; |
| |
| -- Start of processing for Minimize_Eliminate_Overflows |
| |
| begin |
| -- Default initialize Lo and Hi since these are not guaranteed to be |
| -- set otherwise. |
| |
| Lo := No_Uint; |
| Hi := No_Uint; |
| |
| -- Case where we do not have a signed integer arithmetic operation |
| |
| if not Is_Signed_Integer_Arithmetic_Op (N) then |
| |
| -- Use the normal Determine_Range routine to get the range. We |
| -- don't require operands to be valid, invalid values may result in |
| -- rubbish results where the result has not been properly checked for |
| -- overflow, that's fine. |
| |
| Determine_Range (N, OK, Lo, Hi, Assume_Valid => False); |
| |
| -- If Determine_Range did not work (can this in fact happen? Not |
| -- clear but might as well protect), use type bounds. |
| |
| if not OK then |
| Lo := Intval (Type_Low_Bound (Base_Type (Etype (N)))); |
| Hi := Intval (Type_High_Bound (Base_Type (Etype (N)))); |
| end if; |
| |
| -- If we don't have a binary operator, all we have to do is to set |
| -- the Hi/Lo range, so we are done. |
| |
| return; |
| |
| -- Processing for if expression |
| |
| elsif Nkind (N) = N_If_Expression then |
| declare |
| Then_DE : constant Node_Id := Next (First (Expressions (N))); |
| Else_DE : constant Node_Id := Next (Then_DE); |
| |
| begin |
| Bignum_Operands := False; |
| |
| Minimize_Eliminate_Overflows |
| (Then_DE, Lo, Hi, Top_Level => False); |
| |
| if No (Lo) then |
| Bignum_Operands := True; |
| end if; |
| |
| Minimize_Eliminate_Overflows |
| (Else_DE, Rlo, Rhi, Top_Level => False); |
| |
| if No (Rlo) then |
| Bignum_Operands := True; |
| else |
| Long_Long_Integer_Operands := |
| Etype (Then_DE) = LLIB or else Etype (Else_DE) = LLIB; |
| |
| Min (Lo, Rlo); |
| Max (Hi, Rhi); |
| end if; |
| |
| -- If at least one of our operands is now Bignum, we must rebuild |
| -- the if expression to use Bignum operands. We will analyze the |
| -- rebuilt if expression with overflow checks off, since once we |
| -- are in bignum mode, we are all done with overflow checks. |
| |
| if Bignum_Operands then |
| Rewrite (N, |
| Make_If_Expression (Loc, |
| Expressions => New_List ( |
| Remove_Head (Expressions (N)), |
| Convert_To_Bignum (Then_DE), |
| Convert_To_Bignum (Else_DE)), |
| Is_Elsif => Is_Elsif (N))); |
| |
| Reanalyze (RTE (RE_Bignum), Suppress => True); |
| |
| -- If we have no Long_Long_Integer operands, then we are in result |
| -- range, since it means that none of our operands felt the need |
| -- to worry about overflow (otherwise it would have already been |
| -- converted to long long integer or bignum). We reexpand to |
| -- complete the expansion of the if expression (but we do not |
| -- need to reanalyze). |
| |
| elsif not Long_Long_Integer_Operands then |
| Set_Do_Overflow_Check (N, False); |
| Reexpand; |
| |
| -- Otherwise convert us to long long integer mode. Note that we |
| -- don't need any further overflow checking at this level. |
| |
| else |
| Convert_To_And_Rewrite (LLIB, Then_DE); |
| Convert_To_And_Rewrite (LLIB, Else_DE); |
| Set_Etype (N, LLIB); |
| |
| -- Now reanalyze with overflow checks off |
| |
| Set_Do_Overflow_Check (N, False); |
| Reanalyze (LLIB, Suppress => True); |
| end if; |
| end; |
| |
| return; |
| |
| -- Here for case expression |
| |
| elsif Nkind (N) = N_Case_Expression then |
| Bignum_Operands := False; |
| Long_Long_Integer_Operands := False; |
| |
| declare |
| Alt : Node_Id; |
| |
| begin |
| -- Loop through expressions applying recursive call |
| |
| Alt := First (Alternatives (N)); |
| while Present (Alt) loop |
| declare |
| Aexp : constant Node_Id := Expression (Alt); |
| |
| begin |
| Minimize_Eliminate_Overflows |
| (Aexp, Lo, Hi, Top_Level => False); |
| |
| if No (Lo) then |
| Bignum_Operands := True; |
| elsif Etype (Aexp) = LLIB then |
| Long_Long_Integer_Operands := True; |
| end if; |
| end; |
| |
| Next (Alt); |
| end loop; |
| |
| -- If we have no bignum or long long integer operands, it means |
| -- that none of our dependent expressions could raise overflow. |
| -- In this case, we simply return with no changes except for |
| -- resetting the overflow flag, since we are done with overflow |
| -- checks for this node. We will reexpand to get the needed |
| -- expansion for the case expression, but we do not need to |
| -- reanalyze, since nothing has changed. |
| |
| if not (Bignum_Operands or Long_Long_Integer_Operands) then |
| Set_Do_Overflow_Check (N, False); |
| Reexpand (Suppress => True); |
| |
| -- Otherwise we are going to rebuild the case expression using |
| -- either bignum or long long integer operands throughout. |
| |
| else |
| declare |
| Rtype : Entity_Id := Empty; |
| New_Alts : List_Id; |
| New_Exp : Node_Id; |
| |
| begin |
| New_Alts := New_List; |
| Alt := First (Alternatives (N)); |
| while Present (Alt) loop |
| if Bignum_Operands then |
| New_Exp := Convert_To_Bignum (Expression (Alt)); |
| Rtype := RTE (RE_Bignum); |
| else |
| New_Exp := Convert_To (LLIB, Expression (Alt)); |
| Rtype := LLIB; |
| end if; |
| |
| Append_To (New_Alts, |
| Make_Case_Expression_Alternative (Sloc (Alt), |
| Discrete_Choices => Discrete_Choices (Alt), |
| Expression => New_Exp)); |
| |
| Next (Alt); |
| end loop; |
| |
| Rewrite (N, |
| Make_Case_Expression (Loc, |
| Expression => Expression (N), |
| Alternatives => New_Alts)); |
| |
| pragma Assert (Present (Rtype)); |
| Reanalyze (Rtype, Suppress => True); |
| end; |
| end if; |
| end; |
| |
| return; |
| end if; |
| |
| -- If we have an arithmetic operator we make recursive calls on the |
| -- operands to get the ranges (and to properly process the subtree |
| -- that lies below us). |
| |
| Minimize_Eliminate_Overflows |
| (Right_Opnd (N), Rlo, Rhi, Top_Level => False); |
| |
| if Binary then |
| Minimize_Eliminate_Overflows |
| (Left_Opnd (N), Llo, Lhi, Top_Level => False); |
| end if; |
| |
| -- Record if we have Long_Long_Integer operands |
| |
| Long_Long_Integer_Operands := |
| Etype (Right_Opnd (N)) = LLIB |
| or else (Binary and then Etype (Left_Opnd (N)) = LLIB); |
| |
| -- If either operand is a bignum, then result will be a bignum and we |
| -- don't need to do any range analysis. As previously discussed we could |
| -- do range analysis in such cases, but it could mean working with giant |
| -- numbers at compile time for very little gain (the number of cases |
| -- in which we could slip back from bignum mode is small). |
| |
| if No (Rlo) or else (Binary and then No (Llo)) then |
| Lo := No_Uint; |
| Hi := No_Uint; |
| Bignum_Operands := True; |
| |
| -- Otherwise compute result range |
| |
| else |
| Compute_Range_For_Arithmetic_Op |
| (Nkind (N), Llo, Lhi, Rlo, Rhi, OK, Lo, Hi); |
| Bignum_Operands := False; |
| end if; |
| |
| -- Here for the case where we have not rewritten anything (no bignum |
| -- operands or long long integer operands), and we know the result. |
| -- If we know we are in the result range, and we do not have Bignum |
| -- operands or Long_Long_Integer operands, we can just reexpand with |
| -- overflow checks turned off (since we know we cannot have overflow). |
| -- As always the reexpansion is required to complete expansion of the |
| -- operator, but we do not need to reanalyze, and we prevent recursion |
| -- by suppressing the check. |
| |
| if not (Bignum_Operands or Long_Long_Integer_Operands) |
| and then In_Result_Range |
| then |
| Set_Do_Overflow_Check (N, False); |
| Reexpand (Suppress => True); |
| return; |
| |
| -- Here we know that we are not in the result range, and in the general |
| -- case we will move into either the Bignum or Long_Long_Integer domain |
| -- to compute the result. However, there is one exception. If we are |
| -- at the top level, and we do not have Bignum or Long_Long_Integer |
| -- operands, we will have to immediately convert the result back to |
| -- the result type, so there is no point in Bignum/Long_Long_Integer |
| -- fiddling. |
| |
| elsif Top_Level |
| and then not (Bignum_Operands or Long_Long_Integer_Operands) |
| |
| -- One further refinement. If we are at the top level, but our parent |
| -- is a type conversion, then go into bignum or long long integer node |
| -- since the result will be converted to that type directly without |
| -- going through the result type, and we may avoid an overflow. This |
| -- is the case for example of Long_Long_Integer (A ** 4), where A is |
| -- of type Integer, and the result A ** 4 fits in Long_Long_Integer |
| -- but does not fit in Integer. |
| |
| and then Nkind (Parent (N)) /= N_Type_Conversion |
| then |
| -- Here keep original types, but we need to complete analysis |
| |
| -- One subtlety. We can't just go ahead and do an analyze operation |
| -- here because it will cause recursion into the whole MINIMIZED/ |
| -- ELIMINATED overflow processing which is not what we want. Here |
| -- we are at the top level, and we need a check against the result |
| -- mode (i.e. we want to use STRICT mode). So do exactly that. |
| -- Also, we have not modified the node, so this is a case where |
| -- we need to reexpand, but not reanalyze. |
| |
| Reexpand; |
| return; |
| |
| -- Cases where we do the operation in Bignum mode. This happens either |
| -- because one of our operands is in Bignum mode already, or because |
| -- the computed bounds are outside the bounds of Long_Long_Integer, |
| -- which in some cases can be indicated by Hi and Lo being No_Uint. |
| |
| -- Note: we could do better here and in some cases switch back from |
| -- Bignum mode to normal mode, e.g. big mod 2 must be in the range |
| -- 0 .. 1, but the cases are rare and it is not worth the effort. |
| -- Failing to do this switching back is only an efficiency issue. |
| |
| elsif No (Lo) or else Lo < LLLo or else Hi > LLHi then |
| |
| -- OK, we are definitely outside the range of Long_Long_Integer. The |
| -- question is whether to move to Bignum mode, or stay in the domain |
| -- of Long_Long_Integer, signalling that an overflow check is needed. |
| |
| -- Obviously in MINIMIZED mode we stay with LLI, since we are not in |
| -- the Bignum business. In ELIMINATED mode, we will normally move |
| -- into Bignum mode, but there is an exception if neither of our |
| -- operands is Bignum now, and we are at the top level (Top_Level |
| -- set True). In this case, there is no point in moving into Bignum |
| -- mode to prevent overflow if the caller will immediately convert |
| -- the Bignum value back to LLI with an overflow check. It's more |
| -- efficient to stay in LLI mode with an overflow check (if needed) |
| |
| if Check_Mode = Minimized |
| or else (Top_Level and not Bignum_Operands) |
| then |
| if Do_Overflow_Check (N) then |
| Enable_Overflow_Check (N); |
| end if; |
| |
| -- The result now has to be in Long_Long_Integer mode, so adjust |
| -- the possible range to reflect this. Note these calls also |
| -- change No_Uint values from the top level case to LLI bounds. |
| |
| Max (Lo, LLLo); |
| Min (Hi, LLHi); |
| |
| -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode |
| |
| else |
| pragma Assert (Check_Mode = Eliminated); |
| |
| declare |
| Fent : Entity_Id; |
| Args : List_Id; |
| |
| begin |
| case Nkind (N) is |
| when N_Op_Abs => |
| Fent := RTE (RE_Big_Abs); |
| |
| when N_Op_Add => |
| Fent := RTE (RE_Big_Add); |
| |
| when N_Op_Divide => |
| Fent := RTE (RE_Big_Div); |
| |
| when N_Op_Expon => |
| Fent := RTE (RE_Big_Exp); |
| |
| when N_Op_Minus => |
| Fent := RTE (RE_Big_Neg); |
| |
| when N_Op_Mod => |
| Fent := RTE (RE_Big_Mod); |
| |
| when N_Op_Multiply => |
| Fent := RTE (RE_Big_Mul); |
| |
| when N_Op_Rem => |
| Fent := RTE (RE_Big_Rem); |
| |
| when N_Op_Subtract => |
| Fent := RTE (RE_Big_Sub); |
| |
| -- Anything else is an internal error, this includes the |
| -- N_Op_Plus case, since how can plus cause the result |
| -- to be out of range if the operand is in range? |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| -- Construct argument list for Bignum call, converting our |
| -- operands to Bignum form if they are not already there. |
| |
| Args := New_List; |
| |
| if Binary then |
| Append_To (Args, Convert_To_Bignum (Left_Opnd (N))); |
| end if; |
| |
| Append_To (Args, Convert_To_Bignum (Right_Opnd (N))); |
| |
| -- Now rewrite the arithmetic operator with a call to the |
| -- corresponding bignum function. |
| |
| Rewrite (N, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (Fent, Loc), |
| Parameter_Associations => Args)); |
| Reanalyze (RTE (RE_Bignum), Suppress => True); |
| |
| -- Indicate result is Bignum mode |
| |
| Lo := No_Uint; |
| Hi := No_Uint; |
| return; |
| end; |
| end if; |
| |
| -- Otherwise we are in range of Long_Long_Integer, so no overflow |
| -- check is required, at least not yet. |
| |
| else |
| Set_Do_Overflow_Check (N, False); |
| end if; |
| |
| -- Here we are not in Bignum territory, but we may have long long |
| -- integer operands that need special handling. First a special check: |
| -- If an exponentiation operator exponent is of type Long_Long_Integer, |
| -- it means we converted it to prevent overflow, but exponentiation |
| -- requires a Natural right operand, so convert it back to Natural. |
| -- This conversion may raise an exception which is fine. |
| |
| if Nkind (N) = N_Op_Expon and then Etype (Right_Opnd (N)) = LLIB then |
| Convert_To_And_Rewrite (Standard_Natural, Right_Opnd (N)); |
| end if; |
| |
| -- Here we will do the operation in Long_Long_Integer. We do this even |
| -- if we know an overflow check is required, better to do this in long |
| -- long integer mode, since we are less likely to overflow. |
| |
| -- Convert right or only operand to Long_Long_Integer, except that |
| -- we do not touch the exponentiation right operand. |
| |
| if Nkind (N) /= N_Op_Expon then |
| Convert_To_And_Rewrite (LLIB, Right_Opnd (N)); |
| end if; |
| |
| -- Convert left operand to Long_Long_Integer for binary case |
| |
| if Binary then |
| Convert_To_And_Rewrite (LLIB, Left_Opnd (N)); |
| end if; |
| |
| -- Reset node to unanalyzed |
| |
| Set_Analyzed (N, False); |
| Set_Etype (N, Empty); |
| Set_Entity (N, Empty); |
| |
| -- Now analyze this new node. This reanalysis will complete processing |
| -- for the node. In particular we will complete the expansion of an |
| -- exponentiation operator (e.g. changing A ** 2 to A * A), and also |
| -- we will complete any division checks (since we have not changed the |
| -- setting of the Do_Division_Check flag). |
| |
| -- We do this reanalysis in STRICT mode to avoid recursion into the |
| -- MINIMIZED/ELIMINATED handling, since we are now done with that. |
| |
| declare |
| SG : constant Overflow_Mode_Type := |
| Scope_Suppress.Overflow_Mode_General; |
| SA : constant Overflow_Mode_Type := |
| Scope_Suppress.Overflow_Mode_Assertions; |
| |
| begin |
| Scope_Suppress.Overflow_Mode_General := Strict; |
| Scope_Suppress.Overflow_Mode_Assertions := Strict; |
| |
| if not Do_Overflow_Check (N) then |
| Reanalyze (LLIB, Suppress => True); |
| else |
| Reanalyze (LLIB); |
| end if; |
| |
| Scope_Suppress.Overflow_Mode_General := SG; |
| Scope_Suppress.Overflow_Mode_Assertions := SA; |
| end; |
| end Minimize_Eliminate_Overflows; |
| |
| ------------------------- |
| -- Overflow_Check_Mode -- |
| ------------------------- |
| |
| function Overflow_Check_Mode return Overflow_Mode_Type is |
| begin |
| if In_Assertion_Expr = 0 then |
| return Scope_Suppress.Overflow_Mode_General; |
| else |
| return Scope_Suppress.Overflow_Mode_Assertions; |
| end if; |
| end Overflow_Check_Mode; |
| |
| -------------------------------- |
| -- Overflow_Checks_Suppressed -- |
| -------------------------------- |
| |
| function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if Present (E) and then Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Overflow_Check); |
| else |
| return Scope_Suppress.Suppress (Overflow_Check); |
| end if; |
| end Overflow_Checks_Suppressed; |
| |
| --------------------------------- |
| -- Predicate_Checks_Suppressed -- |
| --------------------------------- |
| |
| function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if Present (E) and then Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Predicate_Check); |
| else |
| return Scope_Suppress.Suppress (Predicate_Check); |
| end if; |
| end Predicate_Checks_Suppressed; |
| |
| ----------------------------- |
| -- Range_Checks_Suppressed -- |
| ----------------------------- |
| |
| function Range_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if Present (E) then |
| if Kill_Range_Checks (E) then |
| return True; |
| |
| elsif Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Range_Check); |
| end if; |
| end if; |
| |
| return Scope_Suppress.Suppress (Range_Check); |
| end Range_Checks_Suppressed; |
| |
| ----------------------------------------- |
| -- Range_Or_Validity_Checks_Suppressed -- |
| ----------------------------------------- |
| |
| -- Note: the coding would be simpler here if we simply made appropriate |
| -- calls to Range/Validity_Checks_Suppressed, but that would result in |
| -- duplicated checks which we prefer to avoid. |
| |
| function Range_Or_Validity_Checks_Suppressed |
| (Expr : Node_Id) return Boolean |
| is |
| begin |
| -- Immediate return if scope checks suppressed for either check |
| |
| if Scope_Suppress.Suppress (Range_Check) |
| or |
| Scope_Suppress.Suppress (Validity_Check) |
| then |
| return True; |
| end if; |
| |
| -- If no expression, that's odd, decide that checks are suppressed, |
| -- since we don't want anyone trying to do checks in this case, which |
| -- is most likely the result of some other error. |
| |
| if No (Expr) then |
| return True; |
| end if; |
| |
| -- Expression is present, so perform suppress checks on type |
| |
| declare |
| Typ : constant Entity_Id := Etype (Expr); |
| begin |
| if Checks_May_Be_Suppressed (Typ) |
| and then (Is_Check_Suppressed (Typ, Range_Check) |
| or else |
| Is_Check_Suppressed (Typ, Validity_Check)) |
| then |
| return True; |
| end if; |
| end; |
| |
| -- If expression is an entity name, perform checks on this entity |
| |
| if Is_Entity_Name (Expr) then |
| declare |
| Ent : constant Entity_Id := Entity (Expr); |
| begin |
| if Checks_May_Be_Suppressed (Ent) then |
| return Is_Check_Suppressed (Ent, Range_Check) |
| or else Is_Check_Suppressed (Ent, Validity_Check); |
| end if; |
| end; |
| end if; |
| |
| -- If we fall through, no checks suppressed |
| |
| return False; |
| end Range_Or_Validity_Checks_Suppressed; |
| |
| ------------------- |
| -- Remove_Checks -- |
| ------------------- |
| |
| procedure Remove_Checks (Expr : Node_Id) is |
| function Process (N : Node_Id) return Traverse_Result; |
| -- Process a single node during the traversal |
| |
| procedure Traverse is new Traverse_Proc (Process); |
| -- The traversal procedure itself |
| |
| ------------- |
| -- Process -- |
| ------------- |
| |
| function Process (N : Node_Id) return Traverse_Result is |
| begin |
| if Nkind (N) not in N_Subexpr then |
| return Skip; |
| end if; |
| |
| Set_Do_Range_Check (N, False); |
| |
| case Nkind (N) is |
| when N_And_Then => |
| Traverse (Left_Opnd (N)); |
| return Skip; |
| |
| when N_Attribute_Reference => |
| Set_Do_Overflow_Check (N, False); |
| |
| when N_Op => |
| Set_Do_Overflow_Check (N, False); |
| |
| case Nkind (N) is |
| when N_Op_Divide => |
| Set_Do_Division_Check (N, False); |
| |
| when N_Op_And => |
| Set_Do_Length_Check (N, False); |
| |
| when N_Op_Mod => |
| Set_Do_Division_Check (N, False); |
| |
| when N_Op_Or => |
| Set_Do_Length_Check (N, False); |
| |
| when N_Op_Rem => |
| Set_Do_Division_Check (N, False); |
| |
| when N_Op_Xor => |
| Set_Do_Length_Check (N, False); |
| |
| when others => |
| null; |
| end case; |
| |
| when N_Or_Else => |
| Traverse (Left_Opnd (N)); |
| return Skip; |
| |
| when N_Selected_Component => |
| Set_Do_Discriminant_Check (N, False); |
| |
| when N_Type_Conversion => |
| Set_Do_Length_Check (N, False); |
| Set_Do_Overflow_Check (N, False); |
| |
| when others => |
| null; |
| end case; |
| |
| return OK; |
| end Process; |
| |
| -- Start of processing for Remove_Checks |
| |
| begin |
| Traverse (Expr); |
| end Remove_Checks; |
| |
| ---------------------------- |
| -- Selected_Length_Checks -- |
| ---------------------------- |
| |
| function Selected_Length_Checks |
| (Expr : Node_Id; |
| Target_Typ : Entity_Id; |
| Source_Typ : Entity_Id; |
| Warn_Node : Node_Id) return Check_Result |
| is |
| Loc : constant Source_Ptr := Sloc (Expr); |
| S_Typ : Entity_Id; |
| T_Typ : Entity_Id; |
| Expr_Actual : Node_Id; |
| Exptyp : Entity_Id; |
| Cond : Node_Id := Empty; |
| Do_Access : Boolean := False; |
| Wnode : Node_Id := Warn_Node; |
| Ret_Result : Check_Result := (Empty, Empty); |
| Num_Checks : Natural := 0; |
| |
| procedure Add_Check (N : Node_Id); |
| -- Adds the action given to Ret_Result if N is non-Empty |
| |
| function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id; |
| -- Return E'Length (Indx) |
| |
| function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id; |
| -- Return N'Length (Indx) |
| |
| function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean; |
| -- True for equal literals and for nodes that denote the same constant |
| -- entity, even if its value is not a static constant. This includes the |
| -- case of a discriminal reference within an init proc. Removes some |
| -- obviously superfluous checks. |
| |
| function Length_E_Cond |
| (Exptyp : Entity_Id; |
| Typ : Entity_Id; |
| Indx : Nat) return Node_Id; |
| -- Returns expression to compute: |
| -- Typ'Length /= Exptyp'Length |
| |
| function Length_N_Cond |
| (Exp : Node_Id; |
| Typ : Entity_Id; |
| Indx : Nat) return Node_Id; |
| -- Returns expression to compute: |
| -- Typ'Length /= Exp'Length |
| |
| function Length_Mismatch_Info_Message |
| (Left_Element_Count : Unat; |
| Right_Element_Count : Unat) return String; |
| -- Returns a message indicating how many elements were expected |
| -- (Left_Element_Count) and how many were found (Right_Element_Count). |
| |
| --------------- |
| -- Add_Check -- |
| --------------- |
| |
| procedure Add_Check (N : Node_Id) is |
| begin |
| if Present (N) then |
| |
| -- We do not support inserting more than 2 checks on the same |
| -- node. If this happens it means we have already added an |
| -- unconditional raise, so we can skip the other checks safely |
| -- since N will always raise an exception. |
| |
| if Num_Checks = 2 then |
| return; |
| end if; |
| |
| pragma Assert (Num_Checks <= 1); |
| Num_Checks := Num_Checks + 1; |
| Ret_Result (Num_Checks) := N; |
| end if; |
| end Add_Check; |
| |
| ------------------ |
| -- Get_E_Length -- |
| ------------------ |
| |
| function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is |
| SE : constant Entity_Id := Scope (E); |
| N : Node_Id; |
| E1 : Entity_Id := E; |
| |
| begin |
| if Ekind (Scope (E)) = E_Record_Type |
| and then Has_Discriminants (Scope (E)) |
| then |
| N := Build_Discriminal_Subtype_Of_Component (E); |
| |
| if Present (N) then |
| Insert_Action (Expr, N); |
| E1 := Defining_Identifier (N); |
| end if; |
| end if; |
| |
| if Ekind (E1) = E_String_Literal_Subtype then |
| return |
| Make_Integer_Literal (Loc, |
| Intval => String_Literal_Length (E1)); |
| |
| elsif SE /= Standard_Standard |
| and then Ekind (Scope (SE)) = E_Protected_Type |
| and then Has_Discriminants (Scope (SE)) |
| and then Has_Completion (Scope (SE)) |
| and then not Inside_Init_Proc |
| then |
| -- If the type whose length is needed is a private component |
| -- constrained by a discriminant, we must expand the 'Length |
| -- attribute into an explicit computation, using the discriminal |
| -- of the current protected operation. This is because the actual |
| -- type of the prival is constructed after the protected opera- |
| -- tion has been fully expanded. |
| |
| declare |
| Indx_Type : Node_Id; |
| Bounds : Range_Nodes; |
| Do_Expand : Boolean := False; |
| |
| begin |
| Indx_Type := First_Index (E); |
| |
| for J in 1 .. Indx - 1 loop |
| Next_Index (Indx_Type); |
| end loop; |
| |
| Bounds := Get_Index_Bounds (Indx_Type); |
| |
| if Nkind (Bounds.First) = N_Identifier |
| and then Ekind (Entity (Bounds.First)) = E_In_Parameter |
| then |
| Bounds.First := Get_Discriminal (E, Bounds.First); |
| Do_Expand := True; |
| end if; |
| |
| if Nkind (Bounds.Last) = N_Identifier |
| and then Ekind (Entity (Bounds.Last)) = E_In_Parameter |
| then |
| Bounds.Last := Get_Discriminal (E, Bounds.Last); |
| Do_Expand := True; |
| end if; |
| |
| if Do_Expand then |
| if not Is_Entity_Name (Bounds.First) then |
| Bounds.First := |
| Duplicate_Subexpr_No_Checks (Bounds.First); |
| end if; |
| |
| if not Is_Entity_Name (Bounds.Last) then |
| Bounds.First := Duplicate_Subexpr_No_Checks (Bounds.Last); |
| end if; |
| |
| N := |
| Make_Op_Add (Loc, |
| Left_Opnd => |
| Make_Op_Subtract (Loc, |
| Left_Opnd => Bounds.Last, |
| Right_Opnd => Bounds.First), |
| |
| Right_Opnd => Make_Integer_Literal (Loc, 1)); |
| return N; |
| |
| else |
| N := |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_Length, |
| Prefix => |
| New_Occurrence_Of (E1, Loc)); |
| |
| if Indx > 1 then |
| Set_Expressions (N, New_List ( |
| Make_Integer_Literal (Loc, Indx))); |
| end if; |
| |
| return N; |
| end if; |
| end; |
| |
| else |
| N := |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_Length, |
| Prefix => |
| New_Occurrence_Of (E1, Loc)); |
| |
| if Indx > 1 then |
| Set_Expressions (N, New_List ( |
| Make_Integer_Literal (Loc, Indx))); |
| end if; |
| |
| return N; |
| end if; |
| end Get_E_Length; |
| |
| ------------------ |
| -- Get_N_Length -- |
| ------------------ |
| |
| function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is |
| begin |
| return |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_Length, |
| Prefix => |
| Duplicate_Subexpr_No_Checks (N, Name_Req => True), |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Indx))); |
| end Get_N_Length; |
| |
| ------------------- |
| -- Length_E_Cond -- |
| ------------------- |
| |
| function Length_E_Cond |
| (Exptyp : Entity_Id; |
| Typ : Entity_Id; |
| Indx : Nat) return Node_Id |
| is |
| begin |
| return |
| Make_Op_Ne (Loc, |
| Left_Opnd => Get_E_Length (Typ, Indx), |
| Right_Opnd => Get_E_Length (Exptyp, Indx)); |
| end Length_E_Cond; |
| |
| ------------------- |
| -- Length_N_Cond -- |
| ------------------- |
| |
| function Length_N_Cond |
| (Exp : Node_Id; |
| Typ : Entity_Id; |
| Indx : Nat) return Node_Id |
| is |
| begin |
| return |
| Make_Op_Ne (Loc, |
| Left_Opnd => Get_E_Length (Typ, Indx), |
| Right_Opnd => Get_N_Length (Exp, Indx)); |
| end Length_N_Cond; |
| |
| ---------------------------------- |
| -- Length_Mismatch_Info_Message -- |
| ---------------------------------- |
| |
| function Length_Mismatch_Info_Message |
| (Left_Element_Count : Unat; |
| Right_Element_Count : Unat) return String |
| is |
| |
| function Plural_Vs_Singular_Ending (Count : Unat) return String; |
| -- Returns an empty string if Count is 1; otherwise returns "s" |
| |
| function Plural_Vs_Singular_Ending (Count : Unat) return String is |
| begin |
| if Count = 1 then |
| return ""; |
| else |
| return "s"; |
| end if; |
| end Plural_Vs_Singular_Ending; |
| |
| begin |
| return "expected " |
| & UI_Image (Left_Element_Count, Format => Decimal) |
| & " element" |
| & Plural_Vs_Singular_Ending (Left_Element_Count) |
| & "; found " |
| & UI_Image (Right_Element_Count, Format => Decimal) |
| & " element" |
| & Plural_Vs_Singular_Ending (Right_Element_Count); |
| -- "Format => Decimal" above is needed because otherwise UI_Image |
| -- can sometimes return a hexadecimal number 16#...#, but "#" means |
| -- something special to Errout. A previous version used the default |
| -- Auto, which was essentially the same bug as documented here: |
| -- https://xkcd.com/327/ . |
| end Length_Mismatch_Info_Message; |
| |
| ----------------- |
| -- Same_Bounds -- |
| ----------------- |
| |
| function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is |
| begin |
| return |
| (Nkind (L) = N_Integer_Literal |
| and then Nkind (R) = N_Integer_Literal |
| and then Intval (L) = Intval (R)) |
| |
| or else |
| (Is_Entity_Name (L) |
| and then Ekind (Entity (L)) = E_Constant |
| and then ((Is_Entity_Name (R) |
| and then Entity (L) = Entity (R)) |
| or else |
| (Nkind (R) = N_Type_Conversion |
| and then Is_Entity_Name (Expression (R)) |
| and then Entity (L) = Entity (Expression (R))))) |
| |
| or else |
| (Is_Entity_Name (R) |
| and then Ekind (Entity (R)) = E_Constant |
| and then Nkind (L) = N_Type_Conversion |
| and then Is_Entity_Name (Expression (L)) |
| and then Entity (R) = Entity (Expression (L))) |
| |
| or else |
| (Is_Entity_Name (L) |
| and then Is_Entity_Name (R) |
| and then Entity (L) = Entity (R) |
| and then Ekind (Entity (L)) = E_In_Parameter |
| and then Inside_Init_Proc); |
| end Same_Bounds; |
| |
| -- Start of processing for Selected_Length_Checks |
| |
| begin |
| -- Checks will be applied only when generating code |
| |
| if not Expander_Active then |
| return Ret_Result; |
| end if; |
| |
| if Target_Typ = Any_Type |
| or else Target_Typ = Any_Composite |
| or else Raises_Constraint_Error (Expr) |
| then |
| return Ret_Result; |
| end if; |
| |
| if No (Wnode) then |
| Wnode := Expr; |
| end if; |
| |
| T_Typ := Target_Typ; |
| |
| if No (Source_Typ) then |
| S_Typ := Etype (Expr); |
| else |
| S_Typ := Source_Typ; |
| end if; |
| |
| if S_Typ = Any_Type or else S_Typ = Any_Composite then |
| return Ret_Result; |
| end if; |
| |
| if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then |
| S_Typ := Designated_Type (S_Typ); |
| T_Typ := Designated_Type (T_Typ); |
| Do_Access := True; |
| |
| -- A simple optimization for the null case |
| |
| if Known_Null (Expr) then |
| return Ret_Result; |
| end if; |
| end if; |
| |
| if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then |
| if Is_Constrained (T_Typ) then |
| |
| -- The checking code to be generated will freeze the corresponding |
| -- array type. However, we must freeze the type now, so that the |
| -- freeze node does not appear within the generated if expression, |
| -- but ahead of it. |
| |
| Freeze_Before (Expr, T_Typ); |
| |
| Expr_Actual := Get_Referenced_Object (Expr); |
| Exptyp := Get_Actual_Subtype (Expr); |
| |
| if Is_Access_Type (Exptyp) then |
| Exptyp := Designated_Type (Exptyp); |
| end if; |
| |
| -- String_Literal case. This needs to be handled specially be- |
| -- cause no index types are available for string literals. The |
| -- condition is simply: |
| |
| -- T_Typ'Length = string-literal-length |
| |
| if Nkind (Expr_Actual) = N_String_Literal |
| and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype |
| then |
| Cond := |
| Make_Op_Ne (Loc, |
| Left_Opnd => Get_E_Length (T_Typ, 1), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, |
| Intval => |
| String_Literal_Length (Etype (Expr_Actual)))); |
| |
| -- General array case. Here we have a usable actual subtype for |
| -- the expression, and the condition is built from the two types |
| -- (Do_Length): |
| |
| -- T_Typ'Length /= Exptyp'Length or else |
| -- T_Typ'Length (2) /= Exptyp'Length (2) or else |
| -- T_Typ'Length (3) /= Exptyp'Length (3) or else |
| -- ... |
| |
| elsif Is_Constrained (Exptyp) then |
| declare |
| Ndims : constant Nat := Number_Dimensions (T_Typ); |
| |
| L_Index : Node_Id; |
| R_Index : Node_Id; |
| L_Bounds : Range_Nodes; |
| R_Bounds : Range_Nodes; |
| L_Length : Uint; |
| R_Length : Uint; |
| Ref_Node : Node_Id; |
| |
| begin |
| -- At the library level, we need to ensure that the type of |
| -- the object is elaborated before the check itself is |
| -- emitted. This is only done if the object is in the |
| -- current compilation unit, otherwise the type is frozen |
| -- and elaborated in its unit. |
| |
| if Is_Itype (Exptyp) |
| and then |
| Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package |
| and then |
| not In_Package_Body (Cunit_Entity (Current_Sem_Unit)) |
| and then In_Open_Scopes (Scope (Exptyp)) |
| then |
| Ref_Node := Make_Itype_Reference (Sloc (Expr)); |
| Set_Itype (Ref_Node, Exptyp); |
| Insert_Action (Expr, Ref_Node); |
| end if; |
| |
| L_Index := First_Index (T_Typ); |
| R_Index := First_Index (Exptyp); |
| |
| for Indx in 1 .. Ndims loop |
| if not (Nkind (L_Index) = N_Raise_Constraint_Error |
| or else |
| Nkind (R_Index) = N_Raise_Constraint_Error) |
| then |
| L_Bounds := Get_Index_Bounds (L_Index); |
| R_Bounds := Get_Index_Bounds (R_Index); |
| |
| -- Deal with compile time length check. Note that we |
| -- skip this in the access case, because the access |
| -- value may be null, so we cannot know statically. |
| |
| if not Do_Access |
| and then Compile_Time_Known_Value (L_Bounds.First) |
| and then Compile_Time_Known_Value (L_Bounds.Last) |
| and then Compile_Time_Known_Value (R_Bounds.First) |
| and then Compile_Time_Known_Value (R_Bounds.Last) |
| then |
| if Expr_Value (L_Bounds.Last) >= |
| Expr_Value (L_Bounds.First) |
| then |
| L_Length := Expr_Value (L_Bounds.Last) - |
| Expr_Value (L_Bounds.First) + 1; |
| else |
| L_Length := UI_From_Int (0); |
| end if; |
| |
| if Expr_Value (R_Bounds.Last) >= |
| Expr_Value (R_Bounds.First) |
| then |
| R_Length := Expr_Value (R_Bounds.Last) - |
| Expr_Value (R_Bounds.First) + 1; |
| else |
| R_Length := UI_From_Int (0); |
| end if; |
| |
| if L_Length > R_Length then |
| Add_Check |
| (Compile_Time_Constraint_Error |
| (Wnode, "too few elements for}!!??", T_Typ, |
| Extra_Msg => Length_Mismatch_Info_Message |
| (L_Length, R_Length))); |
| |
| elsif L_Length < R_Length then |
| Add_Check |
| (Compile_Time_Constraint_Error |
| (Wnode, "too many elements for}!!??", T_Typ, |
| Extra_Msg => Length_Mismatch_Info_Message |
| (L_Length, R_Length))); |
| end if; |
| |
| -- The comparison for an individual index subtype |
| -- is omitted if the corresponding index subtypes |
| -- statically match, since the result is known to |
| -- be true. Note that this test is worth while even |
| -- though we do static evaluation, because non-static |
| -- subtypes can statically match. |
| |
| elsif not |
| Subtypes_Statically_Match |
| (Etype (L_Index), Etype (R_Index)) |
| |
| and then not |
| (Same_Bounds (L_Bounds.First, R_Bounds.First) |
| and then |
| Same_Bounds (L_Bounds.Last, R_Bounds.Last)) |
| then |
| Evolve_Or_Else |
| (Cond, Length_E_Cond (Exptyp, T_Typ, Indx)); |
| end if; |
| |
| Next (L_Index); |
| Next (R_Index); |
| end if; |
| end loop; |
| end; |
| |
| -- Handle cases where we do not get a usable actual subtype that |
| -- is constrained. This happens for example in the function call |
| -- and explicit dereference cases. In these cases, we have to get |
| -- the length or range from the expression itself, making sure we |
| -- do not evaluate it more than once. |
| |
| -- Here Expr is the original expression, or more properly the |
| -- result of applying Duplicate_Expr to the original tree, forcing |
| -- the result to be a name. |
| |
| else |
| declare |
| Ndims : constant Pos := Number_Dimensions (T_Typ); |
| |
| begin |
| -- Build the condition for the explicit dereference case |
| |
| for Indx in 1 .. Ndims loop |
| Evolve_Or_Else |
| (Cond, Length_N_Cond (Expr, T_Typ, Indx)); |
| end loop; |
| end; |
| end if; |
| end if; |
| end if; |
| |
| -- Construct the test and insert into the tree |
| |
| if Present (Cond) then |
| if Do_Access then |
| Cond := Guard_Access (Cond, Loc, Expr); |
| end if; |
| |
| Add_Check |
| (Make_Raise_Constraint_Error (Loc, |
| Condition => Cond, |
| Reason => CE_Length_Check_Failed)); |
| end if; |
| |
| return Ret_Result; |
| end Selected_Length_Checks; |
| |
| --------------------------- |
| -- Selected_Range_Checks -- |
| --------------------------- |
| |
| function Selected_Range_Checks |
| (Expr : Node_Id; |
| Target_Typ : Entity_Id; |
| Source_Typ : Entity_Id; |
| Warn_Node : Node_Id) return Check_Result |
| is |
| Loc : constant Source_Ptr := Sloc (Expr); |
| S_Typ : Entity_Id; |
| T_Typ : Entity_Id; |
| Expr_Actual : Node_Id; |
| Exptyp : Entity_Id; |
| Cond : Node_Id := Empty; |
| Do_Access : Boolean := False; |
| Wnode : Node_Id := Warn_Node; |
| Ret_Result : Check_Result := (Empty, Empty); |
| Num_Checks : Natural := 0; |
| |
| procedure Add_Check (N : Node_Id); |
| -- Adds the action given to Ret_Result if N is non-Empty |
| |
| function Discrete_Range_Cond |
| (Exp : Node_Id; |
| Typ : Entity_Id) return Node_Id; |
| -- Returns expression to compute: |
| -- Low_Bound (Exp) < Typ'First |
| -- or else |
| -- High_Bound (Exp) > Typ'Last |
| |
| function Discrete_Expr_Cond |
| (Exp : Node_Id; |
| Typ : Entity_Id) return Node_Id; |
| -- Returns expression to compute: |
| -- Exp < Typ'First |
| -- or else |
| -- Exp > Typ'Last |
| |
| function Get_E_First_Or_Last |
| (Loc : Source_Ptr; |
| E : Entity_Id; |
| Indx : Nat; |
| Nam : Name_Id) return Node_Id; |
| -- Returns an attribute reference |
| -- E'First or E'Last |
| -- with a source location of Loc. |
| -- |
| -- Nam is Name_First or Name_Last, according to which attribute is |
| -- desired. If Indx is non-zero, it is passed as a literal in the |
| -- Expressions of the attribute reference (identifying the desired |
| -- array dimension). |
| |
| function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id; |
| function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id; |
| -- Returns expression to compute: |
| -- N'First or N'Last using Duplicate_Subexpr_No_Checks |
| |
| function Is_Cond_Expr_Ge (N : Node_Id; V : Node_Id) return Boolean; |
| function Is_Cond_Expr_Le (N : Node_Id; V : Node_Id) return Boolean; |
| -- Return True if N is a conditional expression whose dependent |
| -- expressions are all known and greater/lower than or equal to V. |
| |
| function Range_E_Cond |
| (Exptyp : Entity_Id; |
| Typ : Entity_Id; |
| Indx : Nat) |
| return Node_Id; |
| -- Returns expression to compute: |
| -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last |
| |
| function Range_Equal_E_Cond |
| (Exptyp : Entity_Id; |
| Typ : Entity_Id; |
| Indx : Nat) return Node_Id; |
| -- Returns expression to compute: |
| -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last |
| |
| function Range_N_Cond |
| (Exp : Node_Id; |
| Typ : Entity_Id; |
| Indx : Nat) return Node_Id; |
| -- Return expression to compute: |
| -- Exp'First < Typ'First or else Exp'Last > Typ'Last |
| |
| function "<" (Left, Right : Node_Id) return Boolean |
| is (if Is_Floating_Point_Type (S_Typ) |
| then Expr_Value_R (Left) < Expr_Value_R (Right) |
| else Expr_Value (Left) < Expr_Value (Right)); |
| function "<=" (Left, Right : Node_Id) return Boolean |
| is (if Is_Floating_Point_Type (S_Typ) |
| then Expr_Value_R (Left) <= Expr_Value_R (Right) |
| else Expr_Value (Left) <= Expr_Value (Right)); |
| -- Convenience comparison functions of integer or floating point values |
| |
| --------------- |
| -- Add_Check -- |
| --------------- |
| |
| procedure Add_Check (N : Node_Id) is |
| begin |
| if Present (N) then |
| |
| -- We do not support inserting more than 2 checks on the same |
| -- node. If this happens it means we have already added an |
| -- unconditional raise, so we can skip the other checks safely |
| -- since N will always raise an exception. |
| |
| if Num_Checks = 2 then |
| return; |
| end if; |
| |
| pragma Assert (Num_Checks <= 1); |
| Num_Checks := Num_Checks + 1; |
| Ret_Result (Num_Checks) := N; |
| end if; |
| end Add_Check; |
| |
| ------------------------- |
| -- Discrete_Expr_Cond -- |
| ------------------------- |
| |
| function Discrete_Expr_Cond |
| (Exp : Node_Id; |
| Typ : Entity_Id) return Node_Id |
| is |
| begin |
| return |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Lt (Loc, |
| Left_Opnd => |
| Convert_To (Base_Type (Typ), |
| Duplicate_Subexpr_No_Checks (Exp)), |
| Right_Opnd => |
| Convert_To (Base_Type (Typ), |
| Get_E_First_Or_Last (Loc, Typ, 0, Name_First))), |
| |
| Right_Opnd => |
| Make_Op_Gt (Loc, |
| Left_Opnd => |
| Convert_To (Base_Type (Typ), |
| Duplicate_Subexpr_No_Checks (Exp)), |
| Right_Opnd => |
| Convert_To |
| (Base_Type (Typ), |
| Get_E_First_Or_Last (Loc, Typ, 0, Name_Last)))); |
| end Discrete_Expr_Cond; |
| |
| ------------------------- |
| -- Discrete_Range_Cond -- |
| ------------------------- |
| |
| function Discrete_Range_Cond |
| (Exp : Node_Id; |
| Typ : Entity_Id) return Node_Id |
| is |
| LB : Node_Id := Low_Bound (Exp); |
| HB : Node_Id := High_Bound (Exp); |
| |
| Left_Opnd : Node_Id; |
| Right_Opnd : Node_Id; |
| |
| begin |
| if Nkind (LB) = N_Identifier |
| and then Ekind (Entity (LB)) = E_Discriminant |
| then |
| LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc); |
| end if; |
| |
| -- If the index type has a fixed lower bound, then we require an |
| -- exact match of the range's lower bound against that fixed lower |
| -- bound. |
| |
| if Is_Fixed_Lower_Bound_Index_Subtype (Typ) then |
| Left_Opnd := |
| Make_Op_Ne (Loc, |
| Left_Opnd => |
| Convert_To |
| (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)), |
| |
| Right_Opnd => |
| Convert_To |
| (Base_Type (Typ), |
| Get_E_First_Or_Last (Loc, Typ, 0, Name_First))); |
| |
| -- Otherwise we do the expected less-than comparison |
| |
| else |
| Left_Opnd := |
| Make_Op_Lt (Loc, |
| Left_Opnd => |
| Convert_To |
| (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)), |
| |
| Right_Opnd => |
| Convert_To |
| (Base_Type (Typ), |
| Get_E_First_Or_Last (Loc, Typ, 0, Name_First))); |
| end if; |
| |
| if Nkind (HB) = N_Identifier |
| and then Ekind (Entity (HB)) = E_Discriminant |
| then |
| HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc); |
| end if; |
| |
| Right_Opnd := |
| Make_Op_Gt (Loc, |
| Left_Opnd => |
| Convert_To |
| (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)), |
| |
| Right_Opnd => |
| Convert_To |
| (Base_Type (Typ), |
| Get_E_First_Or_Last (Loc, Typ, 0, Name_Last))); |
| |
| return Make_Or_Else (Loc, Left_Opnd, Right_Opnd); |
| end Discrete_Range_Cond; |
| |
| ------------------------- |
| -- Get_E_First_Or_Last -- |
| ------------------------- |
| |
| function Get_E_First_Or_Last |
| (Loc : Source_Ptr; |
| E : Entity_Id; |
| Indx : Nat; |
| Nam : Name_Id) return Node_Id |
| is |
| Exprs : List_Id; |
| begin |
| if Indx > 0 then |
| Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx))); |
| else |
| Exprs := No_List; |
| end if; |
| |
| return Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (E, Loc), |
| Attribute_Name => Nam, |
| Expressions => Exprs); |
| end Get_E_First_Or_Last; |
| |
| ----------------- |
| -- Get_N_First -- |
| ----------------- |
| |
| function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is |
| begin |
| return |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_First, |
| Prefix => |
| Duplicate_Subexpr_No_Checks (N, Name_Req => True), |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Indx))); |
| end Get_N_First; |
| |
| ---------------- |
| -- Get_N_Last -- |
| ---------------- |
| |
| function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is |
| begin |
| return |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_Last, |
| Prefix => |
| Duplicate_Subexpr_No_Checks (N, Name_Req => True), |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Indx))); |
| end Get_N_Last; |
| |
| --------------------- |
| -- Is_Cond_Expr_Ge -- |
| --------------------- |
| |
| function Is_Cond_Expr_Ge (N : Node_Id; V : Node_Id) return Boolean is |
| begin |
| -- Only if expressions are relevant for the time being |
| |
| if Nkind (N) = N_If_Expression then |
| declare |
| Cond : constant Node_Id := First (Expressions (N)); |
| Thenx : constant Node_Id := Next (Cond); |
| Elsex : constant Node_Id := Next (Thenx); |
| |
| begin |
| return Compile_Time_Known_Value (Thenx) |
| and then V <= Thenx |
| and then |
| ((Compile_Time_Known_Value (Elsex) and then V <= Elsex) |
| or else Is_Cond_Expr_Ge (Elsex, V)); |
| end; |
| |
| else |
| return False; |
| end if; |
| end Is_Cond_Expr_Ge; |
| |
| --------------------- |
| -- Is_Cond_Expr_Le -- |
| --------------------- |
| |
| function Is_Cond_Expr_Le (N : Node_Id; V : Node_Id) return Boolean is |
| begin |
| -- Only if expressions are relevant for the time being |
| |
| if Nkind (N) = N_If_Expression then |
| declare |
| Cond : constant Node_Id := First (Expressions (N)); |
| Thenx : constant Node_Id := Next (Cond); |
| Elsex : constant Node_Id := Next (Thenx); |
| |
| begin |
| return Compile_Time_Known_Value (Thenx) |
| and then Thenx <= V |
| and then |
| ((Compile_Time_Known_Value (Elsex) and then Elsex <= V) |
| or else Is_Cond_Expr_Le (Elsex, V)); |
| end; |
| |
| else |
| return False; |
| end if; |
| end Is_Cond_Expr_Le; |
| |
| ------------------ |
| -- Range_E_Cond -- |
| ------------------ |
| |
| function Range_E_Cond |
| (Exptyp : Entity_Id; |
| Typ : Entity_Id; |
| Indx : Nat) return Node_Id |
| is |
| begin |
| return |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Lt (Loc, |
| Left_Opnd => |
| Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First), |
| Right_Opnd => |
| Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), |
| |
| Right_Opnd => |
| Make_Op_Gt (Loc, |
| Left_Opnd => |
| Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last), |
| Right_Opnd => |
| Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); |
| end Range_E_Cond; |
| |
| ------------------------ |
| -- Range_Equal_E_Cond -- |
| ------------------------ |
| |
| function Range_Equal_E_Cond |
| (Exptyp : Entity_Id; |
| Typ : Entity_Id; |
| Indx : Nat) return Node_Id |
| is |
| begin |
| return |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Ne (Loc, |
| Left_Opnd => |
| Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First), |
| Right_Opnd => |
| Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), |
| |
| Right_Opnd => |
| Make_Op_Ne (Loc, |
| Left_Opnd => |
| Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last), |
| Right_Opnd => |
| Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); |
| end Range_Equal_E_Cond; |
| |
| ------------------ |
| -- Range_N_Cond -- |
| ------------------ |
| |
| function Range_N_Cond |
| (Exp : Node_Id; |
| Typ : Entity_Id; |
| Indx : Nat) return Node_Id |
| is |
| begin |
| return |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Lt (Loc, |
| Left_Opnd => |
| Get_N_First (Exp, Indx), |
| Right_Opnd => |
| Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), |
| |
| Right_Opnd => |
| Make_Op_Gt (Loc, |
| Left_Opnd => |
| Get_N_Last (Exp, Indx), |
| Right_Opnd => |
| Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); |
| end Range_N_Cond; |
| |
| -- Start of processing for Selected_Range_Checks |
| |
| begin |
| -- Checks will be applied only when generating code. In GNATprove mode, |
| -- we do not apply the checks, but we still call Selected_Range_Checks |
| -- outside of generics to possibly issue errors on SPARK code when a |
| -- run-time error can be detected at compile time. |
| |
| if Inside_A_Generic or (not GNATprove_Mode and not Expander_Active) then |
| return Ret_Result; |
| end if; |
| |
| if Target_Typ = Any_Type |
| or else Target_Typ = Any_Composite |
| or else Raises_Constraint_Error (Expr) |
| then |
| return Ret_Result; |
| end if; |
| |
| if No (Wnode) then |
| Wnode := Expr; |
| end if; |
| |
| T_Typ := Target_Typ; |
| |
| if No (Source_Typ) then |
| S_Typ := Etype (Expr); |
| else |
| S_Typ := Source_Typ; |
| end if; |
| |
| if S_Typ = Any_Type or else S_Typ = Any_Composite then |
| return Ret_Result; |
| end if; |
| |
| -- The order of evaluating T_Typ before S_Typ seems to be critical |
| -- because S_Typ can be derived from Etype (Expr), if it's not passed |
| -- in, and since Node can be an N_Range node, it might be invalid. |
| -- Should there be an assert check somewhere for taking the Etype of |
| -- an N_Range node ??? |
| |
| if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then |
| S_Typ := Designated_Type (S_Typ); |
| T_Typ := Designated_Type (T_Typ); |
| Do_Access := True; |
| |
| -- A simple optimization for the null case |
| |
| if Known_Null (Expr) then |
| return Ret_Result; |
| end if; |
| end if; |
| |
| -- For an N_Range Node, check for a null range and then if not |
| -- null generate a range check action. |
| |
| if Nkind (Expr) = N_Range then |
| |
| -- There's no point in checking a range against itself |
| |
| if Expr = Scalar_Range (T_Typ) then |
| return Ret_Result; |
| end if; |
| |
| declare |
| T_LB : constant Node_Id := Type_Low_Bound (T_Typ); |
| T_HB : constant Node_Id := Type_High_Bound (T_Typ); |
| Known_T_LB : constant Boolean := Compile_Time_Known_Value (T_LB); |
| Known_T_HB : constant Boolean := Compile_Time_Known_Value (T_HB); |
| |
| LB : Node_Id := Low_Bound (Expr); |
| HB : Node_Id := High_Bound (Expr); |
| Known_LB : Boolean := False; |
| Known_HB : Boolean := False; |
| Check_Added : Boolean := False; |
| |
| Out_Of_Range_L : Boolean := False; |
| Out_Of_Range_H : Boolean := False; |
| |
| begin |
| -- Compute what is known at compile time |
| |
| if Known_T_LB and Known_T_HB then |
| if Compile_Time_Known_Value (LB) then |
| Known_LB := True; |
| |
| -- There's no point in checking that a bound is within its |
| -- own range so pretend that it is known in this case. First |
| -- deal with low bound. |
| |
| elsif Ekind (Etype (LB)) = E_Signed_Integer_Subtype |
| and then Scalar_Range (Etype (LB)) = Scalar_Range (T_Typ) |
| then |
| LB := T_LB; |
| Known_LB := True; |
| |
| -- Similarly; deal with the case where the low bound is a |
| -- conditional expression whose result is greater than or |
| -- equal to the target low bound. |
| |
| elsif Is_Cond_Expr_Ge (LB, T_LB) then |
| LB := T_LB; |
| Known_LB := True; |
| end if; |
| |
| -- Likewise for the high bound |
| |
| if Compile_Time_Known_Value (HB) then |
| Known_HB := True; |
| |
| elsif Ekind (Etype (HB)) = E_Signed_Integer_Subtype |
| and then Scalar_Range (Etype (HB)) = Scalar_Range (T_Typ) |
| then |
| HB := T_HB; |
| Known_HB := True; |
| |
| elsif Is_Cond_Expr_Le (HB, T_HB) then |
| HB := T_HB; |
| Known_HB := True; |
| end if; |
| end if; |
| |
| -- Check for the simple cases where we can do the check at |
| -- compile time. This is skipped if we have an access type, since |
| -- the access value may be null. |
| |
| if not Do_Access and then Not_Null_Range (LB, HB) then |
| if Known_LB then |
| if Known_T_LB then |
| Out_Of_Range_L := LB < T_LB; |
| end if; |
| |
| if Known_T_HB and not Out_Of_Range_L then |
| Out_Of_Range_L := T_HB < LB; |
| end if; |
| |
| if Out_Of_Range_L then |
| if No (Warn_Node) then |
| Add_Check |
| (Compile_Time_Constraint_Error |
| (Low_Bound (Expr), |
| "static value out of range of}??", T_Typ)); |
| Check_Added := True; |
| |
| else |
| Add_Check |
| (Compile_Time_Constraint_Error |
| (Wnode, |
| "static range out of bounds of}??", T_Typ)); |
| Check_Added := True; |
| end if; |
| end if; |
| end if; |
| |
| -- Flag the case of a fixed-lower-bound index where the static |
| -- bounds are not equal. |
| |
| if not Check_Added |
| and then Is_Fixed_Lower_Bound_Index_Subtype (T_Typ) |
| and then Expr_Value (LB) /= Expr_Value (T_LB) |
| then |
| Add_Check |
| (Compile_Time_Constraint_Error |
| ((if Present (Warn_Node) |
| then Warn_Node else Low_Bound (Expr)), |
| "static value does not equal lower bound of}??", |
| T_Typ)); |
| Check_Added := True; |
| end if; |
| |
| if Known_HB then |
| if Known_T_HB then |
| Out_Of_Range_H := T_HB < HB; |
| end if; |
| |
| if Known_T_LB and not Out_Of_Range_H then |
| Out_Of_Range_H := HB < T_LB; |
| end if; |
| |
| if Out_Of_Range_H then |
| if No (Warn_Node) then |
| Add_Check |
| (Compile_Time_Constraint_Error |
| (High_Bound (Expr), |
| "static value out of range of}??", T_Typ)); |
| Check_Added := True; |
| |
| else |
| Add_Check |
| (Compile_Time_Constraint_Error |
| (Wnode, |
| "static range out of bounds of}??", T_Typ)); |
| Check_Added := True; |
| end if; |
| end if; |
| end if; |
| end if; |
| |
| -- Check for the case where not everything is static |
| |
| if not Check_Added |
| and then |
| (Do_Access |
| or else not Known_T_LB |
| or else not Known_LB |
| or else not Known_T_HB |
| or else not Known_HB) |
| then |
| declare |
| LB : Node_Id := Low_Bound (Expr); |
| HB : Node_Id := High_Bound (Expr); |
| |
| begin |
| -- If either bound is a discriminant and we are within the |
| -- record declaration, it is a use of the discriminant in a |
| -- constraint of a component, and nothing can be checked |
| -- here. The check will be emitted within the init proc. |
| -- Before then, the discriminal has no real meaning. |
| -- Similarly, if the entity is a discriminal, there is no |
| -- check to perform yet. |
| |
| -- The same holds within a discriminated synchronized type, |
| -- where the discriminant may constrain a component or an |
| -- entry family. |
| |
| if Nkind (LB) = N_Identifier |
| and then Denotes_Discriminant (LB, True) |
| then |
| if Current_Scope = Scope (Entity (LB)) |
| or else Is_Concurrent_Type (Current_Scope) |
| or else Ekind (Entity (LB)) /= E_Discriminant |
| then |
| return Ret_Result; |
| else |
| LB := |
| New_Occurrence_Of (Discriminal (Entity (LB)), Loc); |
| end if; |
| end if; |
| |
| if Nkind (HB) = N_Identifier |
| and then Denotes_Discriminant (HB, True) |
| then |
| if Current_Scope = Scope (Entity (HB)) |
| or else Is_Concurrent_Type (Current_Scope) |
| or else Ekind (Entity (HB)) /= E_Discriminant |
| then |
| return Ret_Result; |
| else |
| HB := |
| New_Occurrence_Of (Discriminal (Entity (HB)), Loc); |
| end if; |
| end if; |
| |
| Cond := Discrete_Range_Cond (Expr, T_Typ); |
| Set_Paren_Count (Cond, 1); |
| |
| Cond := |
| Make_And_Then (Loc, |
| Left_Opnd => |
| Make_Op_Ge (Loc, |
| Left_Opnd => |
| Convert_To (Base_Type (Etype (HB)), |
| Duplicate_Subexpr_No_Checks (HB)), |
| Right_Opnd => |
| Convert_To (Base_Type (Etype (LB)), |
| Duplicate_Subexpr_No_Checks (LB))), |
| Right_Opnd => Cond); |
| end; |
| end if; |
| end; |
| |
| elsif Is_Scalar_Type (S_Typ) then |
| |
| -- This somewhat duplicates what Apply_Scalar_Range_Check does, |
| -- except the above simply sets a flag in the node and lets the |
| -- check be generated based on the Etype of the expression. |
| -- Sometimes, however we want to do a dynamic check against an |
| -- arbitrary target type, so we do that here. |
| |
| if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then |
| Cond := Discrete_Expr_Cond (Expr, T_Typ); |
| |
| -- For literals, we can tell if the constraint error will be |
| -- raised at compile time, so we never need a dynamic check, but |
| -- if the exception will be raised, then post the usual warning, |
| -- and replace the literal with a raise constraint error |
| -- expression. As usual, skip this for access types |
| |
| elsif Compile_Time_Known_Value (Expr) and then not Do_Access then |
| if Is_Out_Of_Range (Expr, T_Typ) then |
| |
| -- Bounds of the type are static and the literal is out of |
| -- range so output a warning message. |
| |
| if No (Warn_Node) then |
| Add_Check |
| (Compile_Time_Constraint_Error |
| (Expr, "static value out of range of}??", T_Typ)); |
| |
| else |
| Add_Check |
| (Compile_Time_Constraint_Error |
| (Wnode, "static value out of range of}??", T_Typ)); |
| end if; |
| else |
| Cond := Discrete_Expr_Cond (Expr, T_Typ); |
| end if; |
| |
| -- Here for the case of a non-static expression, we need a runtime |
| -- check unless the source type range is guaranteed to be in the |
| -- range of the target type. |
| |
| else |
| if not In_Subrange_Of (S_Typ, T_Typ) then |
| Cond := Discrete_Expr_Cond (Expr, T_Typ); |
| end if; |
| end if; |
| end if; |
| |
| if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then |
| if Is_Constrained (T_Typ) then |
| Expr_Actual := Get_Referenced_Object (Expr); |
| Exptyp := Get_Actual_Subtype (Expr_Actual); |
| |
| if Is_Access_Type (Exptyp) then |
| Exptyp := Designated_Type (Exptyp); |
| end if; |
| |
| -- String_Literal case. This needs to be handled specially be- |
| -- cause no index types are available for string literals. The |
| -- condition is simply: |
| |
| -- T_Typ'Length = string-literal-length |
| |
| if Nkind (Expr_Actual) = N_String_Literal then |
| null; |
| |
| -- General array case. Here we have a usable actual subtype for |
| -- the expression, and the condition is built from the two types |
| |
| -- T_Typ'First < Exptyp'First or else |
| -- T_Typ'Last > Exptyp'Last or else |
| -- T_Typ'First(1) < Exptyp'First(1) or else |
| -- T_Typ'Last(1) > Exptyp'Last(1) or else |
| -- ... |
| |
| elsif Is_Constrained (Exptyp) then |
| declare |
| Ndims : constant Pos := Number_Dimensions (T_Typ); |
| |
| L_Index : Node_Id; |
| R_Index : Node_Id; |
| |
| begin |
| L_Index := First_Index (T_Typ); |
| R_Index := First_Index (Exptyp); |
| |
| for Indx in 1 .. Ndims loop |
| if not (Nkind (L_Index) = N_Raise_Constraint_Error |
| or else |
| Nkind (R_Index) = N_Raise_Constraint_Error) |
| then |
| -- Deal with compile time length check. Note that we |
| -- skip this in the access case, because the access |
| -- value may be null, so we cannot know statically. |
| |
| if not |
| Subtypes_Statically_Match |
| (Etype (L_Index), Etype (R_Index)) |
| then |
| -- If the target type is constrained then we |
| -- have to check for exact equality of bounds |
| -- (required for qualified expressions). |
| |
| if Is_Constrained (T_Typ) then |
| Evolve_Or_Else |
| (Cond, |
| Range_Equal_E_Cond (Exptyp, T_Typ, Indx)); |
| else |
| Evolve_Or_Else |
| (Cond, Range_E_Cond (Exptyp, T_Typ, Indx)); |
| end if; |
| end if; |
| |
| Next (L_Index); |
| Next (R_Index); |
| end if; |
| end loop; |
| end; |
| |
| -- Handle cases where we do not get a usable actual subtype that |
| -- is constrained. This happens for example in the function call |
| -- and explicit dereference cases. In these cases, we have to get |
| -- the length or range from the expression itself, making sure we |
| -- do not evaluate it more than once. |
| |
| -- Here Expr is the original expression, or more properly the |
| -- result of applying Duplicate_Expr to the original tree, |
| -- forcing the result to be a name. |
| |
| else |
| declare |
| Ndims : constant Pos := Number_Dimensions (T_Typ); |
| |
| begin |
| -- Build the condition for the explicit dereference case |
| |
| for Indx in 1 .. Ndims loop |
| Evolve_Or_Else |
| (Cond, Range_N_Cond (Expr, T_Typ, Indx)); |
| end loop; |
| end; |
| end if; |
| |
| -- If the context is a qualified_expression where the subtype is |
| -- an unconstrained array subtype with fixed-lower-bound indexes, |
| -- then consistency checks must be done between the lower bounds |
| -- of any such indexes and the corresponding lower bounds of the |
| -- qualified array object. |
| |
| elsif Is_Fixed_Lower_Bound_Array_Subtype (T_Typ) |
| and then Nkind (Parent (Expr)) = N_Qualified_Expression |
| and then not Do_Access |
| then |
| declare |
| Ndims : constant Pos := Number_Dimensions (T_Typ); |
| |
| Qual_Index : Node_Id; |
| Expr_Index : Node_Id; |
| |
| begin |
| Expr_Actual := Get_Referenced_Object (Expr); |
| Exptyp := Get_Actual_Subtype (Expr_Actual); |
| |
| Qual_Index := First_Index (T_Typ); |
| Expr_Index := First_Index (Exptyp); |
| |
| for Indx in 1 .. Ndims loop |
| if Nkind (Expr_Index) /= N_Raise_Constraint_Error then |
| |
| -- If this index of the qualifying array subtype has |
| -- a fixed lower bound, then apply a check that the |
| -- corresponding lower bound of the array expression |
| -- is equal to it. |
| |
| if Is_Fixed_Lower_Bound_Index_Subtype (Etype (Qual_Index)) |
| then |
| Evolve_Or_Else |
| (Cond, |
| Make_Op_Ne (Loc, |
| Left_Opnd => |
| Get_E_First_Or_Last |
| (Loc, Exptyp, Indx, Name_First), |
| Right_Opnd => |
| New_Copy_Tree |
| (Type_Low_Bound (Etype (Qual_Index))))); |
| end if; |
| |
| Next (Qual_Index); |
| Next (Expr_Index); |
| end if; |
| end loop; |
| end; |
| |
| else |
| -- For a conversion to an unconstrained array type, generate an |
| -- Action to check that the bounds of the source value are within |
| -- the constraints imposed by the target type (RM 4.6(38)). No |
| -- check is needed for a conversion to an access to unconstrained |
| -- array type, as 4.6(24.15/2) requires the designated subtypes |
| -- of the two access types to statically match. |
| |
| if Nkind (Parent (Expr)) = N_Type_Conversion |
| and then not Do_Access |
| then |
| declare |
| Opnd_Index : Node_Id; |
| Targ_Index : Node_Id; |
| Opnd_Range : Node_Id; |
| |
| begin |
| Opnd_Index := First_Index (Get_Actual_Subtype (Expr)); |
| Targ_Index := First_Index (T_Typ); |
| while Present (Opnd_Index) loop |
| |
| -- If the index is a range, use its bounds. If it is an |
| -- entity (as will be the case if it is a named subtype |
| -- or an itype created for a slice) retrieve its range. |
| |
| if Is_Entity_Name (Opnd_Index) |
| and then Is_Type (Entity (Opnd_Index)) |
| then |
| Opnd_Range := Scalar_Range (Entity (Opnd_Index)); |
| else |
| Opnd_Range := Opnd_Index; |
| end if; |
| |
| if Nkind (Opnd_Range) = N_Range then |
| if Is_In_Range |
| (Low_Bound (Opnd_Range), Etype (Targ_Index), |
| Assume_Valid => True) |
| and then |
| Is_In_Range |
| (High_Bound (Opnd_Range), Etype (Targ_Index), |
| Assume_Valid => True) |
| then |
| null; |
| |
| -- If null range, no check needed |
| |
| elsif |
| Compile_Time_Known_Value (High_Bound (Opnd_Range)) |
| and then |
| Compile_Time_Known_Value (Low_Bound (Opnd_Range)) |
| and then |
| Expr_Value (High_Bound (Opnd_Range)) < |
| Expr_Value (Low_Bound (Opnd_Range)) |
| then |
| null; |
| |
| elsif Is_Out_Of_Range |
| (Low_Bound (Opnd_Range), Etype (Targ_Index), |
| Assume_Valid => True) |
| or else |
| Is_Out_Of_Range |
| (High_Bound (Opnd_Range), Etype (Targ_Index), |
| Assume_Valid => True) |
| then |
| Add_Check |
| (Compile_Time_Constraint_Error |
| (Wnode, "value out of range of}??", T_Typ)); |
| |
| else |
| Evolve_Or_Else |
| (Cond, |
| Discrete_Range_Cond |
| (Opnd_Range, Etype (Targ_Index))); |
| end if; |
| end if; |
| |
| Next_Index (Opnd_Index); |
| Next_Index (Targ_Index); |
| end loop; |
| end; |
| end if; |
| end if; |
| end if; |
| |
| -- Construct the test and insert into the tree |
| |
| if Present (Cond) then |
| if Do_Access then |
| Cond := Guard_Access (Cond, Loc, Expr); |
| end if; |
| |
| Add_Check |
| (Make_Raise_Constraint_Error (Loc, |
| Condition => Cond, |
| Reason => CE_Range_Check_Failed)); |
| end if; |
| |
| return Ret_Result; |
| end Selected_Range_Checks; |
| |
| ------------------------------- |
| -- Storage_Checks_Suppressed -- |
| ------------------------------- |
| |
| function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if Present (E) and then Checks_May_Be_Suppressed (E) then |
| return Is_Check_Suppressed (E, Storage_Check); |
| else |
| return Scope_Suppress.Suppress (Storage_Check); |
| end if; |
| end Storage_Checks_Suppressed; |
| |
| --------------------------- |
| -- Tag_Checks_Suppressed -- |
| --------------------------- |
| |
| function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is |
| begin |
| if Present (E) |
| and then Checks_May_Be_Suppressed (E) |
| then |
| return Is_Check_Suppressed (E, Tag_Check); |
| else |
| return Scope_Suppress.Suppress (Tag_Check); |
| end if; |
| end Tag_Checks_Suppressed; |
| |
| --------------------------------------- |
| -- Validate_Alignment_Check_Warnings -- |
| --------------------------------------- |
| |
| procedure Validate_Alignment_Check_Warnings is |
| begin |
| for J in Alignment_Warnings.First .. Alignment_Warnings.Last loop |
| declare |
| AWR : Alignment_Warnings_Record |
| renames Alignment_Warnings.Table (J); |
| begin |
| if Known_Alignment (AWR.E) |
| and then ((Present (AWR.A) |
| and then AWR.A mod Alignment (AWR.E) = 0) |
| or else (Present (AWR.P) |
| and then Has_Compatible_Alignment |
| (AWR.E, AWR.P, True) = |
| Known_Compatible)) |
| then |
| Delete_Warning_And_Continuations (AWR.W); |
| end if; |
| end; |
| end loop; |
| end Validate_Alignment_Check_Warnings; |
| |
| -------------------------- |
| -- Validity_Check_Range -- |
| -------------------------- |
| |
| procedure Validity_Check_Range |
| (N : Node_Id; |
| Related_Id : Entity_Id := Empty) is |
| begin |
| if Validity_Checks_On and Validity_Check_Operands then |
| if Nkind (N) = N_Range then |
| Ensure_Valid |
| (Expr => Low_Bound (N), |
| Related_Id => Related_Id, |
| Is_Low_Bound => True); |
| |
| Ensure_Valid |
| (Expr => High_Bound (N), |
| Related_Id => Related_Id, |
| Is_High_Bound => True); |
| end if; |
| end if; |
| end Validity_Check_Range; |
| |
| end Checks; |