| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- C H E C K S -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2019, 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 Casing; use Casing; |
| with Debug; use Debug; |
| with Einfo; use Einfo; |
| with Elists; use Elists; |
| with Eval_Fat; use Eval_Fat; |
| with Exp_Ch11; use Exp_Ch11; |
| with Exp_Ch2; use Exp_Ch2; |
| 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_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 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 warning 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 |
| (Ck_Node : 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 |
| (Ck_Node : 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 Apply_Selected_Range_Checks |
| (Ck_Node : Node_Id; |
| Target_Typ : Entity_Id; |
| Source_Typ : Entity_Id; |
| Do_Static : Boolean); |
| -- This is the subprogram that does all the work for Apply_Range_Check. |
| -- Expr, Target_Typ and Source_Typ are as described for the above |
| -- routine. The Do_Static flag indicates that only a static check is |
| -- to be done. |
| |
| 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; |
| Ck_Node : 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 |
| (Ck_Node : 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 |
| (Ck_Node : Node_Id; |
| Target_Typ : Entity_Id; |
| Source_Typ : Entity_Id; |
| Warn_Node : Node_Id) return Check_Result; |
| -- Like Apply_Selected_Range_Checks, except it doesn't modify anything, |
| -- just returns a list of nodes as described in the spec of this package |
| -- 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 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_In (N, 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, True); |
| 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, True); |
| 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; |
| Flag_Node : Node_Id) |
| is |
| Checks_On : constant Boolean := |
| not Index_Checks_Suppressed (Suppress_Typ) |
| or else |
| not Range_Checks_Suppressed (Suppress_Typ); |
| |
| Internal_Flag_Node : constant Node_Id := Flag_Node; |
| Internal_Static_Sloc : constant Source_Ptr := Static_Sloc; |
| |
| 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 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 |
| if not Has_Dynamic_Range_Check (Internal_Flag_Node) then |
| Append_To (Stmts, Checks (J)); |
| Set_Has_Dynamic_Range_Check (Internal_Flag_Node); |
| end if; |
| |
| else |
| Append_To |
| (Stmts, |
| Make_Raise_Constraint_Error (Internal_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 RTU_Loaded (Ada_Tags) |
| and then RTE_Available (RE_Offset_To_Top_Ptr) |
| and then Etype (P) = RTE (RE_Offset_To_Top_Ptr) |
| then |
| return; |
| end if; |
| |
| -- Otherwise go ahead and install the check |
| |
| Install_Null_Excluding_Check (P); |
| 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); |
| Param_Ent : Entity_Id := Param_Entity (N); |
| Param_Level : Node_Id; |
| Type_Level : Node_Id; |
| |
| begin |
| if Ada_Version >= Ada_2012 |
| and then not Present (Param_Ent) |
| and then Is_Entity_Name (N) |
| and then Ekind_In (Entity (N), 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 the level of the |
| -- type is less deep than the level of the access parameter, and |
| -- accessibility checks are not suppressed. |
| |
| elsif Present (Param_Ent) |
| and then Present (Extra_Accessibility (Param_Ent)) |
| and then UI_Gt (Object_Access_Level (N), |
| Deepest_Type_Access_Level (Typ)) |
| and then not Accessibility_Checks_Suppressed (Param_Ent) |
| and then not Accessibility_Checks_Suppressed (Typ) |
| then |
| Param_Level := |
| New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc); |
| |
| Type_Level := |
| Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ)); |
| |
| -- Raise Program_Error if the accessibility level of the access |
| -- parameter is deeper than the level of the target access type. |
| |
| Insert_Action (Insert_Node, |
| Make_Raise_Program_Error (Loc, |
| Condition => |
| Make_Op_Gt (Loc, |
| Left_Opnd => Param_Level, |
| Right_Opnd => Type_Level), |
| Reason => PE_Accessibility_Check_Failed)); |
| |
| Analyze_And_Resolve (N); |
| 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 not Present (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), 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 (Left_Opnd (N), |
| Make_Type_Conversion (Loc, |
| Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), |
| Expression => Relocate_Node (Left_Opnd (N)))); |
| |
| Rewrite (Right_Opnd (N), |
| Make_Type_Conversion (Loc, |
| Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), |
| Expression => Relocate_Node (Right_Opnd (N)))); |
| |
| -- Rewrite the conversion operand so that the original |
| -- node is retained, in order to avoid the warning for |
| -- redundant conversions in Resolve_Type_Conversion. |
| |
| Rewrite (N, Relocate_Node (N)); |
| |
| 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 |
| Siz : constant Int := UI_To_Int (Esize (Rtyp)); |
| Dsiz : constant Int := Siz * 2; |
| 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 check type exceeds the size of Long_Long_Integer, |
| -- we use a different approach, expanding to: |
| |
| -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y))) |
| |
| -- where xxx is Add, Multiply or Subtract as appropriate |
| |
| -- Find check type if one exists |
| |
| if Dsiz <= Standard_Integer_Size then |
| Ctyp := Standard_Integer; |
| |
| elsif Dsiz <= Standard_Long_Long_Integer_Size then |
| Ctyp := Standard_Long_Long_Integer; |
| |
| -- No check type exists, use runtime call |
| |
| else |
| if Nkind (N) = N_Op_Add then |
| Cent := RE_Add_With_Ovflo_Check; |
| |
| elsif Nkind (N) = N_Op_Multiply then |
| Cent := RE_Multiply_With_Ovflo_Check; |
| |
| else |
| pragma Assert (Nkind (N) = N_Op_Subtract); |
| Cent := RE_Subtract_With_Ovflo_Check; |
| 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 (RTE (RE_Integer_64), Left_Opnd (N)), |
| OK_Convert_To (RTE (RE_Integer_64), 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. |
| |
| if Nkind_In (P, N_If_Expression, N_Case_Expression) |
| and then not Is_Signed_Integer_Arithmetic_Op (Parent (P)) |
| 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 (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 |
| (Ck_Node : 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 (Ck_Node); |
| Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node)); |
| Target_Base : constant Entity_Id := |
| Implementation_Base_Type (Target_Typ); |
| |
| Par : constant Node_Id := Parent (Ck_Node); |
| 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; |
| |
| 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 (Ck_Node, Target_Base); |
| Set_Etype (Temp, Target_Base); |
| |
| Insert_Action (Parent (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 (Ck_Node) = N_Real_Literal |
| and then Etype (Ck_Node) = Universal_Real |
| and then Is_Integer_Type (Target_Typ) |
| and then Nkind (Parent (Ck_Node)) = N_Type_Conversion |
| then |
| declare |
| Int_Val : constant Uint := UR_To_Uint (Realval (Ck_Node)); |
| |
| begin |
| if Int_Val <= Ilast and then Int_Val >= Ifirst then |
| |
| -- Conversion is safe |
| |
| Rewrite (Parent (Ck_Node), |
| Make_Integer_Literal (Loc, UI_To_Int (Int_Val))); |
| Analyze_And_Resolve (Parent (Ck_Node), 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 (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node); |
| Lo_OK := (Lo >= UR_From_Uint (Ifirst)); |
| end if; |
| |
| if Lo_OK then |
| |
| -- Lo_Chk := (X >= Lo) |
| |
| Lo_Chk := Make_Op_Ge (Loc, |
| Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node), |
| Right_Opnd => Make_Real_Literal (Loc, Lo)); |
| |
| else |
| -- Lo_Chk := (X > Lo) |
| |
| Lo_Chk := Make_Op_Gt (Loc, |
| Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node), |
| 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 (Expr_Type, UR_From_Uint (Ilast), Round_Even, Ck_Node); |
| Hi_OK := (Hi <= UR_From_Uint (Ilast)); |
| end if; |
| |
| if Hi_OK then |
| |
| -- Hi_Chk := (X <= Hi) |
| |
| Hi_Chk := Make_Op_Le (Loc, |
| Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node), |
| Right_Opnd => Make_Real_Literal (Loc, Hi)); |
| |
| else |
| -- Hi_Chk := (X < Hi) |
| |
| Hi_Chk := Make_Op_Lt (Loc, |
| Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node), |
| 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 (Ck_Node, |
| 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 |
| (Ck_Node : Node_Id; |
| Target_Typ : Entity_Id; |
| Source_Typ : Entity_Id := Empty) |
| is |
| begin |
| Apply_Selected_Length_Checks |
| (Ck_Node, Target_Typ, Source_Typ, Do_Static => False); |
| end Apply_Length_Check; |
| |
| ------------------------------------- |
| -- Apply_Parameter_Aliasing_Checks -- |
| ------------------------------------- |
| |
| procedure Apply_Parameter_Aliasing_Checks |
| (Call : Node_Id; |
| Subp : Entity_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Call); |
| |
| 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. |
| |
| ------------------------ |
| -- 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; |
| ID_Casing : constant Casing_Type := |
| Identifier_Casing (Source_Index (Current_Sem_Unit)); |
| |
| 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 """); |
| |
| Get_Name_String (Chars (Formal_1)); |
| Set_Casing (ID_Casing); |
| Store_String_Chars (Name_Buffer (1 .. Name_Len)); |
| |
| Store_String_Chars (""" and """); |
| |
| Get_Name_String (Chars (Formal_2)); |
| Set_Casing (ID_Casing); |
| Store_String_Chars (Name_Buffer (1 .. Name_Len)); |
| |
| 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); |
| |
| -- Ensure that the actual is an object that is not passed by value. |
| -- Elementary types are always passed by value, therefore actuals of |
| -- such types cannot lead to aliasing. An aggregate is an object in |
| -- Ada 2012, but an actual that is an aggregate cannot overlap with |
| -- another actual. A type that is By_Reference (such as an array of |
| -- controlled types) is not subject to the check because any update |
| -- will be done in place and a subsequent read will always see the |
| -- correct value, see RM 6.2 (12/3). |
| |
| if Nkind (Orig_Act_1) = N_Aggregate |
| or else (Nkind (Orig_Act_1) = N_Qualified_Expression |
| and then Nkind (Expression (Orig_Act_1)) = N_Aggregate) |
| then |
| null; |
| |
| elsif Is_Object_Reference (Orig_Act_1) |
| and then not Is_Elementary_Type (Etype (Orig_Act_1)) |
| and then not Is_By_Reference_Type (Etype (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); |
| |
| -- The other actual we are testing against must also denote |
| -- a non pass-by-value object. Generate the check only when |
| -- the mode of the two formals may lead to aliasing. |
| |
| if Is_Object_Reference (Orig_Act_2) |
| and then not Is_Elementary_Type (Etype (Orig_Act_2)) |
| and then May_Cause_Aliasing (Formal_1, Formal_2) |
| then |
| 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; |
| |
| 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[_Scalar] 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 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 Check_Validity_Of_Parameters then |
| if Ekind_In (Formal, E_In_Parameter, E_In_Out_Parameter) then |
| Add_Validity_Check (Formal, Name_Precondition, False); |
| end if; |
| |
| if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then |
| Add_Validity_Check (Formal, Name_Postcondition, False); |
| end if; |
| end if; |
| |
| Next_Formal (Formal); |
| end loop; |
| |
| -- Generate following scalar initialization check for function result: |
| |
| -- Post => Subp'Result'Valid[_Scalars] |
| |
| if Check_Validity_Of_Parameters and then 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 |
| S : Entity_Id; |
| |
| begin |
| if Predicate_Checks_Suppressed (Empty) then |
| return; |
| |
| elsif Predicates_Ignored (Typ) then |
| return; |
| |
| elsif Present (Predicate_Function (Typ)) then |
| S := Current_Scope; |
| while Present (S) and then not Is_Subprogram (S) loop |
| S := Scope (S); |
| end loop; |
| |
| -- A predicate check does not apply within internally generated |
| -- subprograms, such as TSS functions. |
| |
| if Within_Internal_Subprogram then |
| return; |
| |
| -- 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. |
| |
| elsif 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; |
| |
| Insert_Action (N, |
| Make_Raise_Storage_Error (Sloc (N), |
| Reason => SE_Infinite_Recursion)); |
| |
| -- Here for normal case of predicate active |
| |
| else |
| -- 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; |
| |
| -- 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)))); |
| |
| -- 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. |
| |
| -- If the prefix is an aggregate in an assignment, apply the |
| -- check to the LHS after 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. |
| |
| elsif Nkind (N) = N_Aggregate |
| and then Nkind (Parent (N)) = N_Assignment_Statement |
| then |
| Insert_Action_After (Parent (N), |
| Make_Predicate_Check |
| (Typ, Duplicate_Subexpr (Name (Parent (N))))); |
| |
| else |
| Insert_Action (N, |
| Make_Predicate_Check |
| (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks); |
| end if; |
| end if; |
| end if; |
| end Apply_Predicate_Check; |
| |
| ----------------------- |
| -- Apply_Range_Check -- |
| ----------------------- |
| |
| procedure Apply_Range_Check |
| (Ck_Node : Node_Id; |
| Target_Typ : Entity_Id; |
| Source_Typ : Entity_Id := Empty) |
| is |
| begin |
| Apply_Selected_Range_Checks |
| (Ck_Node, Target_Typ, Source_Typ, Do_Static => False); |
| 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. Right now we only do this for |
| -- discrete types, and not fixed-point or floating-point types. |
| |
| -- The additional less-precise tests below catch these cases |
| |
| -- In GNATprove_Mode, also deal with the case of a conversion from |
| -- floating-point to integer. It is only possible because analysis |
| -- in GNATprove rules out the possibility of a NaN or infinite value. |
| |
| -- 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 (Is_Discrete_Type (Etype (Expr)) |
| or else (GNATprove_Mode |
| and then Is_Floating_Point_Type (Etype (Expr)))) |
| 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); |
| |
| -- In GNATprove mode, we enable the range check so that |
| -- GNATprove will issue a message if it cannot be proved. |
| |
| if GNATprove_Mode then |
| Enable_Range_Check (Expr); |
| end if; |
| |
| return; |
| end if; |
| |
| -- Otherwise determine range of value |
| |
| if Is_Discrete_Type (Etype (Expr)) then |
| Determine_Range |
| (Expr, OK, Lo, Hi, Assume_Valid => True); |
| |
| -- When converting a float to an integer type, 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. It is only possible because |
| -- analysis in GNATprove rules out the possibility of a NaN |
| -- or infinite value. |
| |
| elsif GNATprove_Mode |
| and then Is_Floating_Point_Type (Etype (Expr)) |
| then |
| declare |
| Hir : Ureal; |
| Lor : Ureal; |
| |
| begin |
| Determine_Range_R |
| (Expr, OK, Lor, Hir, Assume_Valid => True); |
| |
| if OK then |
| Lo := UR_To_Uint (Lor); |
| Hi := UR_To_Uint (Hir); |
| end if; |
| end; |
| end if; |
| |
| 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 Target_Typ /= RTE (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. |
| |
| if not Is_Unconstrained_Subscr_Ref |
| and then Is_Discrete_Type (S_Typ) = 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 |
| (Ck_Node : 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 (Ck_Node); |
| |
| 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 (Ck_Node, 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, Ck_Node); |
| |
| if Present (Source_Typ) then |
| Ensure_Defined (Source_Typ, Ck_Node); |
| |
| elsif Is_Itype (Etype (Ck_Node)) then |
| Ensure_Defined (Etype (Ck_Node), Ck_Node); |
| end if; |
| end if; |
| |
| -- If the item is a conditional raise of constraint error, then have |
| -- a look at what check is being performed and ??? |
| |
| 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 (Ck_Node) then |
| |
| -- If checks are on, just insert the check |
| |
| if Checks_On then |
| Insert_Action (Ck_Node, R_Cno); |
| |
| if not Do_Static then |
| Set_Has_Dynamic_Length_Check (Ck_Node); |
| 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, Ck_Node); |
| 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 |
| (Ck_Node, "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_Selected_Range_Checks -- |
| --------------------------------- |
| |
| procedure Apply_Selected_Range_Checks |
| (Ck_Node : Node_Id; |
| Target_Typ : Entity_Id; |
| Source_Typ : Entity_Id; |
| Do_Static : Boolean) |
| is |
| Checks_On : constant Boolean := |
| not Index_Checks_Suppressed (Target_Typ) |
| or else |
| not Range_Checks_Suppressed (Target_Typ); |
| |
| Loc : constant Source_Ptr := Sloc (Ck_Node); |
| |
| 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 (Ck_Node, Target_Typ, Source_Typ, Empty); |
| |
| if GNATprove_Mode then |
| return; |
| end if; |
| |
| for J in 1 .. 2 loop |
| R_Cno := R_Result (J); |
| exit when No (R_Cno); |
| |
| -- The range check requires runtime evaluation. Depending on what its |
| -- triggering condition is, the check may be converted into a compile |
| -- time constraint check. |
| |
| if Nkind (R_Cno) = N_Raise_Constraint_Error |
| and then Present (Condition (R_Cno)) |
| then |
| Cond := Condition (R_Cno); |
| |
| -- Insert the range check before the related context. Note that |
| -- this action analyses the triggering condition. |
| |
| Insert_Action (Ck_Node, R_Cno); |
| |
| -- This old code doesn't make sense, why is the context flagged as |
| -- requiring dynamic range checks now in the middle of generating |
| -- them ??? |
| |
| if not Do_Static then |
| Set_Has_Dynamic_Range_Check (Ck_Node); |
| 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 (Ck_Node) = N_Range then |
| Apply_Compile_Time_Constraint_Error |
| (Low_Bound (Ck_Node), |
| "static range out of bounds of}??", |
| CE_Range_Check_Failed, |
| Ent => Target_Typ, |
| Typ => Target_Typ); |
| |
| Set_Raises_Constraint_Error (Ck_Node); |
| |
| else |
| Apply_Compile_Time_Constraint_Error |
| (Ck_Node, |
| "static value out of range of}??", |
| CE_Range_Check_Failed, |
| Ent => Target_Typ, |
| Typ => Target_Typ); |
| end if; |
| |
| -- If we were only doing a static check, or if checks are not |
| -- on, then we want to delete the check, since it is not needed. |
| -- We do this by replacing the if statement by a null statement |
| |
| elsif Do_Static then |
| Remove_Warning_Messages (R_Cno); |
| Rewrite (R_Cno, Make_Null_Statement (Loc)); |
| end if; |
| |
| -- The range check raises Constraint_Error explicitly |
| |
| else |
| Install_Static_Check (R_Cno, Loc); |
| end if; |
| end loop; |
| end Apply_Selected_Range_Checks; |
| |
| ------------------------------- |
| -- Apply_Static_Length_Check -- |
| ------------------------------- |
| |
| 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) is |
| Sub : Node_Id; |
| |
| 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. |
| |
| Ensure_Valid (Sub, Holes_OK => True); |
| |
| -- Move to next subscript |
| |
| Sub := Next (Sub); |
| 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. |
| |
| 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 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 (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 |
| null; |
| |
| else |
| 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 |
| -- Conversions involving fixed-point types are expanded |
| -- separately, and do not need a Range_Check flag, except |
| -- in GNATprove_Mode, where the explicit constraint check |
| -- will not be generated. |
| |
| if GNATprove_Mode |
| or else not Is_Fixed_Point_Type (Expr_Type) |
| then |
| Apply_Scalar_Range_Check |
| (Expr, Target_Type, Fixed_Int => Conv_OK); |
| |
| else |
| Set_Do_Range_Check (Expression (N), 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; |
| |
| 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 |
| -- An unconstrained derived type may have inherited discriminant. |
| -- 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. |
| |
| declare |
| 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 |
| 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. |
| |
| Set_Discriminant_Constraint (Expr_Type, New_Constraints); |
| Cond := Build_Discriminant_Checks (Expr, Expr_Type); |
| Set_Discriminant_Constraint (Expr_Type, Old_Constraints); |
| |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => Cond, |
| Reason => CE_Discriminant_Check_Failed)); |
| end; |
| |
| -- 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 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; |
| |
| -------------------------------- |
| -- 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; |
| |
| -- 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; |
| |
| -- 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)); |
| |
| 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_In (LE, 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 |
| (Nkind_In (Kind, 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; |
| |
| ---------------------------------- |
| -- 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 |
| |