1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Casing
; use Casing
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Eval_Fat
; use Eval_Fat
;
32 with Exp_Ch11
; use Exp_Ch11
;
33 with Exp_Ch2
; use Exp_Ch2
;
34 with Exp_Ch4
; use Exp_Ch4
;
35 with Exp_Pakd
; use Exp_Pakd
;
36 with Exp_Util
; use Exp_Util
;
37 with Expander
; use Expander
;
38 with Freeze
; use Freeze
;
40 with Nlists
; use Nlists
;
41 with Nmake
; use Nmake
;
43 with Output
; use Output
;
44 with Restrict
; use Restrict
;
45 with Rident
; use Rident
;
46 with Rtsfind
; use Rtsfind
;
48 with Sem_Aux
; use Sem_Aux
;
49 with Sem_Ch3
; use Sem_Ch3
;
50 with Sem_Ch8
; use Sem_Ch8
;
51 with Sem_Disp
; use Sem_Disp
;
52 with Sem_Eval
; use Sem_Eval
;
53 with Sem_Res
; use Sem_Res
;
54 with Sem_Util
; use Sem_Util
;
55 with Sem_Warn
; use Sem_Warn
;
56 with Sinfo
; use Sinfo
;
57 with Sinput
; use Sinput
;
58 with Snames
; use Snames
;
59 with Sprint
; use Sprint
;
60 with Stand
; use Stand
;
61 with Stringt
; use Stringt
;
62 with Targparm
; use Targparm
;
63 with Tbuild
; use Tbuild
;
64 with Ttypes
; use Ttypes
;
65 with Validsw
; use Validsw
;
67 package body Checks
is
69 -- General note: many of these routines are concerned with generating
70 -- checking code to make sure that constraint error is raised at runtime.
71 -- Clearly this code is only needed if the expander is active, since
72 -- otherwise we will not be generating code or going into the runtime
75 -- We therefore disconnect most of these checks if the expander is
76 -- inactive. This has the additional benefit that we do not need to
77 -- worry about the tree being messed up by previous errors (since errors
78 -- turn off expansion anyway).
80 -- There are a few exceptions to the above rule. For instance routines
81 -- such as Apply_Scalar_Range_Check that do not insert any code can be
82 -- safely called even when the Expander is inactive (but Errors_Detected
83 -- is 0). The benefit of executing this code when expansion is off, is
84 -- the ability to emit constraint error warning for static expressions
85 -- even when we are not generating code.
87 -- The above is modified in gnatprove mode to ensure that proper check
88 -- flags are always placed, even if expansion is off.
90 -------------------------------------
91 -- Suppression of Redundant Checks --
92 -------------------------------------
94 -- This unit implements a limited circuit for removal of redundant
95 -- checks. The processing is based on a tracing of simple sequential
96 -- flow. For any sequence of statements, we save expressions that are
97 -- marked to be checked, and then if the same expression appears later
98 -- with the same check, then under certain circumstances, the second
99 -- check can be suppressed.
101 -- Basically, we can suppress the check if we know for certain that
102 -- the previous expression has been elaborated (together with its
103 -- check), and we know that the exception frame is the same, and that
104 -- nothing has happened to change the result of the exception.
106 -- Let us examine each of these three conditions in turn to describe
107 -- how we ensure that this condition is met.
109 -- First, we need to know for certain that the previous expression has
110 -- been executed. This is done principally by the mechanism of calling
111 -- Conditional_Statements_Begin at the start of any statement sequence
112 -- and Conditional_Statements_End at the end. The End call causes all
113 -- checks remembered since the Begin call to be discarded. This does
114 -- miss a few cases, notably the case of a nested BEGIN-END block with
115 -- no exception handlers. But the important thing is to be conservative.
116 -- The other protection is that all checks are discarded if a label
117 -- is encountered, since then the assumption of sequential execution
118 -- is violated, and we don't know enough about the flow.
120 -- Second, we need to know that the exception frame is the same. We
121 -- do this by killing all remembered checks when we enter a new frame.
122 -- Again, that's over-conservative, but generally the cases we can help
123 -- with are pretty local anyway (like the body of a loop for example).
125 -- Third, we must be sure to forget any checks which are no longer valid.
126 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
127 -- used to note any changes to local variables. We only attempt to deal
128 -- with checks involving local variables, so we do not need to worry
129 -- about global variables. Second, a call to any non-global procedure
130 -- causes us to abandon all stored checks, since such a all may affect
131 -- the values of any local variables.
133 -- The following define the data structures used to deal with remembering
134 -- checks so that redundant checks can be eliminated as described above.
136 -- Right now, the only expressions that we deal with are of the form of
137 -- simple local objects (either declared locally, or IN parameters) or
138 -- such objects plus/minus a compile time known constant. We can do
139 -- more later on if it seems worthwhile, but this catches many simple
140 -- cases in practice.
142 -- The following record type reflects a single saved check. An entry
143 -- is made in the stack of saved checks if and only if the expression
144 -- has been elaborated with the indicated checks.
146 type Saved_Check
is record
148 -- Set True if entry is killed by Kill_Checks
151 -- The entity involved in the expression that is checked
154 -- A compile time value indicating the result of adding or
155 -- subtracting a compile time value. This value is to be
156 -- added to the value of the Entity. A value of zero is
157 -- used for the case of a simple entity reference.
159 Check_Type
: Character;
160 -- This is set to 'R' for a range check (in which case Target_Type
161 -- is set to the target type for the range check) or to 'O' for an
162 -- overflow check (in which case Target_Type is set to Empty).
164 Target_Type
: Entity_Id
;
165 -- Used only if Do_Range_Check is set. Records the target type for
166 -- the check. We need this, because a check is a duplicate only if
167 -- it has the same target type (or more accurately one with a
168 -- range that is smaller or equal to the stored target type of a
172 -- The following table keeps track of saved checks. Rather than use an
173 -- extensible table, we just use a table of fixed size, and we discard
174 -- any saved checks that do not fit. That's very unlikely to happen and
175 -- this is only an optimization in any case.
177 Saved_Checks
: array (Int
range 1 .. 200) of Saved_Check
;
178 -- Array of saved checks
180 Num_Saved_Checks
: Nat
:= 0;
181 -- Number of saved checks
183 -- The following stack keeps track of statement ranges. It is treated
184 -- as a stack. When Conditional_Statements_Begin is called, an entry
185 -- is pushed onto this stack containing the value of Num_Saved_Checks
186 -- at the time of the call. Then when Conditional_Statements_End is
187 -- called, this value is popped off and used to reset Num_Saved_Checks.
189 -- Note: again, this is a fixed length stack with a size that should
190 -- always be fine. If the value of the stack pointer goes above the
191 -- limit, then we just forget all saved checks.
193 Saved_Checks_Stack
: array (Int
range 1 .. 100) of Nat
;
194 Saved_Checks_TOS
: Nat
:= 0;
196 -----------------------
197 -- Local Subprograms --
198 -----------------------
200 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
);
201 -- Used to apply arithmetic overflow checks for all cases except operators
202 -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we
203 -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a
204 -- signed integer arithmetic operator (but not an if or case expression).
205 -- It is also called for types other than signed integers.
207 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
);
208 -- Used to apply arithmetic overflow checks for the case where the overflow
209 -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer
210 -- arithmetic op (which includes the case of if and case expressions). Note
211 -- that Do_Overflow_Check may or may not be set for node Op. In these modes
212 -- we have work to do even if overflow checking is suppressed.
214 procedure Apply_Division_Check
219 -- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies
220 -- division checks as required if the Do_Division_Check flag is set.
221 -- Rlo and Rhi give the possible range of the right operand, these values
222 -- can be referenced and trusted only if ROK is set True.
224 procedure Apply_Float_Conversion_Check
226 Target_Typ
: Entity_Id
);
227 -- The checks on a conversion from a floating-point type to an integer
228 -- type are delicate. They have to be performed before conversion, they
229 -- have to raise an exception when the operand is a NaN, and rounding must
230 -- be taken into account to determine the safe bounds of the operand.
232 procedure Apply_Selected_Length_Checks
234 Target_Typ
: Entity_Id
;
235 Source_Typ
: Entity_Id
;
236 Do_Static
: Boolean);
237 -- This is the subprogram that does all the work for Apply_Length_Check
238 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
239 -- described for the above routines. The Do_Static flag indicates that
240 -- only a static check is to be done.
242 procedure Apply_Selected_Range_Checks
244 Target_Typ
: Entity_Id
;
245 Source_Typ
: Entity_Id
;
246 Do_Static
: Boolean);
247 -- This is the subprogram that does all the work for Apply_Range_Check.
248 -- Expr, Target_Typ and Source_Typ are as described for the above
249 -- routine. The Do_Static flag indicates that only a static check is
252 type Check_Type
is new Check_Id
range Access_Check
.. Division_Check
;
253 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean;
254 -- This function is used to see if an access or division by zero check is
255 -- needed. The check is to be applied to a single variable appearing in the
256 -- source, and N is the node for the reference. If N is not of this form,
257 -- True is returned with no further processing. If N is of the right form,
258 -- then further processing determines if the given Check is needed.
260 -- The particular circuit is to see if we have the case of a check that is
261 -- not needed because it appears in the right operand of a short circuited
262 -- conditional where the left operand guards the check. For example:
264 -- if Var = 0 or else Q / Var > 12 then
268 -- In this example, the division check is not required. At the same time
269 -- we can issue warnings for suspicious use of non-short-circuited forms,
272 -- if Var = 0 or Q / Var > 12 then
278 Check_Type
: Character;
279 Target_Type
: Entity_Id
;
280 Entry_OK
: out Boolean;
284 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
285 -- to see if a check is of the form for optimization, and if so, to see
286 -- if it has already been performed. Expr is the expression to check,
287 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
288 -- Target_Type is the target type for a range check, and Empty for an
289 -- overflow check. If the entry is not of the form for optimization,
290 -- then Entry_OK is set to False, and the remaining out parameters
291 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
292 -- entity and offset from the expression. Check_Num is the number of
293 -- a matching saved entry in Saved_Checks, or zero if no such entry
296 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
;
297 -- If a discriminal is used in constraining a prival, Return reference
298 -- to the discriminal of the protected body (which renames the parameter
299 -- of the enclosing protected operation). This clumsy transformation is
300 -- needed because privals are created too late and their actual subtypes
301 -- are not available when analysing the bodies of the protected operations.
302 -- This function is called whenever the bound is an entity and the scope
303 -- indicates a protected operation. If the bound is an in-parameter of
304 -- a protected operation that is not a prival, the function returns the
306 -- To be cleaned up???
308 function Guard_Access
311 Ck_Node
: Node_Id
) return Node_Id
;
312 -- In the access type case, guard the test with a test to ensure
313 -- that the access value is non-null, since the checks do not
314 -- not apply to null access values.
316 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
);
317 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
318 -- Constraint_Error node.
320 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean;
321 -- Returns True if node N is for an arithmetic operation with signed
322 -- integer operands. This includes unary and binary operators, and also
323 -- if and case expression nodes where the dependent expressions are of
324 -- a signed integer type. These are the kinds of nodes for which special
325 -- handling applies in MINIMIZED or ELIMINATED overflow checking mode.
327 function Range_Or_Validity_Checks_Suppressed
328 (Expr
: Node_Id
) return Boolean;
329 -- Returns True if either range or validity checks or both are suppressed
330 -- for the type of the given expression, or, if the expression is the name
331 -- of an entity, if these checks are suppressed for the entity.
333 function Selected_Length_Checks
335 Target_Typ
: Entity_Id
;
336 Source_Typ
: Entity_Id
;
337 Warn_Node
: Node_Id
) return Check_Result
;
338 -- Like Apply_Selected_Length_Checks, except it doesn't modify
339 -- anything, just returns a list of nodes as described in the spec of
340 -- this package for the Range_Check function.
341 -- ??? In fact it does construct the test and insert it into the tree,
342 -- and insert actions in various ways (calling Insert_Action directly
343 -- in particular) so we do not call it in GNATprove mode, contrary to
344 -- Selected_Range_Checks.
346 function Selected_Range_Checks
348 Target_Typ
: Entity_Id
;
349 Source_Typ
: Entity_Id
;
350 Warn_Node
: Node_Id
) return Check_Result
;
351 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
352 -- just returns a list of nodes as described in the spec of this package
353 -- for the Range_Check function.
355 ------------------------------
356 -- Access_Checks_Suppressed --
357 ------------------------------
359 function Access_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
361 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
362 return Is_Check_Suppressed
(E
, Access_Check
);
364 return Scope_Suppress
.Suppress
(Access_Check
);
366 end Access_Checks_Suppressed
;
368 -------------------------------------
369 -- Accessibility_Checks_Suppressed --
370 -------------------------------------
372 function Accessibility_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
374 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
375 return Is_Check_Suppressed
(E
, Accessibility_Check
);
377 return Scope_Suppress
.Suppress
(Accessibility_Check
);
379 end Accessibility_Checks_Suppressed
;
381 -----------------------------
382 -- Activate_Division_Check --
383 -----------------------------
385 procedure Activate_Division_Check
(N
: Node_Id
) is
387 Set_Do_Division_Check
(N
, True);
388 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
389 end Activate_Division_Check
;
391 -----------------------------
392 -- Activate_Overflow_Check --
393 -----------------------------
395 procedure Activate_Overflow_Check
(N
: Node_Id
) is
396 Typ
: constant Entity_Id
:= Etype
(N
);
399 -- Floating-point case. If Etype is not set (this can happen when we
400 -- activate a check on a node that has not yet been analyzed), then
401 -- we assume we do not have a floating-point type (as per our spec).
403 if Present
(Typ
) and then Is_Floating_Point_Type
(Typ
) then
405 -- Ignore call if we have no automatic overflow checks on the target
406 -- and Check_Float_Overflow mode is not set. These are the cases in
407 -- which we expect to generate infinities and NaN's with no check.
409 if not (Machine_Overflows_On_Target
or Check_Float_Overflow
) then
412 -- Ignore for unary operations ("+", "-", abs) since these can never
413 -- result in overflow for floating-point cases.
415 elsif Nkind
(N
) in N_Unary_Op
then
418 -- Otherwise we will set the flag
427 -- Nothing to do for Rem/Mod/Plus (overflow not possible, the check
428 -- for zero-divide is a divide check, not an overflow check).
430 if Nkind_In
(N
, N_Op_Rem
, N_Op_Mod
, N_Op_Plus
) then
435 -- Fall through for cases where we do set the flag
437 Set_Do_Overflow_Check
(N
, True);
438 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
439 end Activate_Overflow_Check
;
441 --------------------------
442 -- Activate_Range_Check --
443 --------------------------
445 procedure Activate_Range_Check
(N
: Node_Id
) is
447 Set_Do_Range_Check
(N
, True);
448 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
449 end Activate_Range_Check
;
451 ---------------------------------
452 -- Alignment_Checks_Suppressed --
453 ---------------------------------
455 function Alignment_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
457 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
458 return Is_Check_Suppressed
(E
, Alignment_Check
);
460 return Scope_Suppress
.Suppress
(Alignment_Check
);
462 end Alignment_Checks_Suppressed
;
464 ----------------------------------
465 -- Allocation_Checks_Suppressed --
466 ----------------------------------
468 -- Note: at the current time there are no calls to this function, because
469 -- the relevant check is in the run-time, so it is not a check that the
470 -- compiler can suppress anyway, but we still have to recognize the check
471 -- name Allocation_Check since it is part of the standard.
473 function Allocation_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
475 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
476 return Is_Check_Suppressed
(E
, Allocation_Check
);
478 return Scope_Suppress
.Suppress
(Allocation_Check
);
480 end Allocation_Checks_Suppressed
;
482 -------------------------
483 -- Append_Range_Checks --
484 -------------------------
486 procedure Append_Range_Checks
487 (Checks
: Check_Result
;
489 Suppress_Typ
: Entity_Id
;
490 Static_Sloc
: Source_Ptr
;
493 Checks_On
: constant Boolean :=
494 not Index_Checks_Suppressed
(Suppress_Typ
)
496 not Range_Checks_Suppressed
(Suppress_Typ
);
498 Internal_Flag_Node
: constant Node_Id
:= Flag_Node
;
499 Internal_Static_Sloc
: constant Source_Ptr
:= Static_Sloc
;
502 -- For now we just return if Checks_On is false, however this should be
503 -- enhanced to check for an always True value in the condition and to
504 -- generate a compilation warning???
506 if not Checks_On
then
511 exit when No
(Checks
(J
));
513 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
514 and then Present
(Condition
(Checks
(J
)))
516 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
517 Append_To
(Stmts
, Checks
(J
));
518 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
524 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
525 Reason
=> CE_Range_Check_Failed
));
528 end Append_Range_Checks
;
530 ------------------------
531 -- Apply_Access_Check --
532 ------------------------
534 procedure Apply_Access_Check
(N
: Node_Id
) is
535 P
: constant Node_Id
:= Prefix
(N
);
538 -- We do not need checks if we are not generating code (i.e. the
539 -- expander is not active). This is not just an optimization, there
540 -- are cases (e.g. with pragma Debug) where generating the checks
541 -- can cause real trouble).
543 if not Expander_Active
then
547 -- No check if short circuiting makes check unnecessary
549 if not Check_Needed
(P
, Access_Check
) then
553 -- No check if accessing the Offset_To_Top component of a dispatch
554 -- table. They are safe by construction.
556 if Tagged_Type_Expansion
557 and then Present
(Etype
(P
))
558 and then RTU_Loaded
(Ada_Tags
)
559 and then RTE_Available
(RE_Offset_To_Top_Ptr
)
560 and then Etype
(P
) = RTE
(RE_Offset_To_Top_Ptr
)
565 -- Otherwise go ahead and install the check
567 Install_Null_Excluding_Check
(P
);
568 end Apply_Access_Check
;
570 -------------------------------
571 -- Apply_Accessibility_Check --
572 -------------------------------
574 procedure Apply_Accessibility_Check
577 Insert_Node
: Node_Id
)
579 Loc
: constant Source_Ptr
:= Sloc
(N
);
580 Param_Ent
: Entity_Id
:= Param_Entity
(N
);
581 Param_Level
: Node_Id
;
582 Type_Level
: Node_Id
;
585 if Ada_Version
>= Ada_2012
586 and then not Present
(Param_Ent
)
587 and then Is_Entity_Name
(N
)
588 and then Ekind_In
(Entity
(N
), E_Constant
, E_Variable
)
589 and then Present
(Effective_Extra_Accessibility
(Entity
(N
)))
591 Param_Ent
:= Entity
(N
);
592 while Present
(Renamed_Object
(Param_Ent
)) loop
594 -- Renamed_Object must return an Entity_Name here
595 -- because of preceding "Present (E_E_A (...))" test.
597 Param_Ent
:= Entity
(Renamed_Object
(Param_Ent
));
601 if Inside_A_Generic
then
604 -- Only apply the run-time check if the access parameter has an
605 -- associated extra access level parameter and when the level of the
606 -- type is less deep than the level of the access parameter, and
607 -- accessibility checks are not suppressed.
609 elsif Present
(Param_Ent
)
610 and then Present
(Extra_Accessibility
(Param_Ent
))
611 and then UI_Gt
(Object_Access_Level
(N
),
612 Deepest_Type_Access_Level
(Typ
))
613 and then not Accessibility_Checks_Suppressed
(Param_Ent
)
614 and then not Accessibility_Checks_Suppressed
(Typ
)
617 New_Occurrence_Of
(Extra_Accessibility
(Param_Ent
), Loc
);
620 Make_Integer_Literal
(Loc
, Deepest_Type_Access_Level
(Typ
));
622 -- Raise Program_Error if the accessibility level of the access
623 -- parameter is deeper than the level of the target access type.
625 Insert_Action
(Insert_Node
,
626 Make_Raise_Program_Error
(Loc
,
629 Left_Opnd
=> Param_Level
,
630 Right_Opnd
=> Type_Level
),
631 Reason
=> PE_Accessibility_Check_Failed
));
633 Analyze_And_Resolve
(N
);
635 end Apply_Accessibility_Check
;
637 --------------------------------
638 -- Apply_Address_Clause_Check --
639 --------------------------------
641 procedure Apply_Address_Clause_Check
(E
: Entity_Id
; N
: Node_Id
) is
642 pragma Assert
(Nkind
(N
) = N_Freeze_Entity
);
644 AC
: constant Node_Id
:= Address_Clause
(E
);
645 Loc
: constant Source_Ptr
:= Sloc
(AC
);
646 Typ
: constant Entity_Id
:= Etype
(E
);
649 -- Address expression (not necessarily the same as Aexp, for example
650 -- when Aexp is a reference to a constant, in which case Expr gets
651 -- reset to reference the value expression of the constant).
654 -- See if alignment check needed. Note that we never need a check if the
655 -- maximum alignment is one, since the check will always succeed.
657 -- Note: we do not check for checks suppressed here, since that check
658 -- was done in Sem_Ch13 when the address clause was processed. We are
659 -- only called if checks were not suppressed. The reason for this is
660 -- that we have to delay the call to Apply_Alignment_Check till freeze
661 -- time (so that all types etc are elaborated), but we have to check
662 -- the status of check suppressing at the point of the address clause.
665 or else not Check_Address_Alignment
(AC
)
666 or else Maximum_Alignment
= 1
671 -- Obtain expression from address clause
673 Expr
:= Address_Value
(Expression
(AC
));
675 -- See if we know that Expr has an acceptable value at compile time. If
676 -- it hasn't or we don't know, we defer issuing the warning until the
677 -- end of the compilation to take into account back end annotations.
679 if Compile_Time_Known_Value
(Expr
)
680 and then (Known_Alignment
(E
) or else Known_Alignment
(Typ
))
683 AL
: Uint
:= Alignment
(Typ
);
686 -- The object alignment might be more restrictive than the type
689 if Known_Alignment
(E
) then
693 if Expr_Value
(Expr
) mod AL
= 0 then
698 -- If the expression has the form X'Address, then we can find out if the
699 -- object X has an alignment that is compatible with the object E. If it
700 -- hasn't or we don't know, we defer issuing the warning until the end
701 -- of the compilation to take into account back end annotations.
703 elsif Nkind
(Expr
) = N_Attribute_Reference
704 and then Attribute_Name
(Expr
) = Name_Address
706 Has_Compatible_Alignment
(E
, Prefix
(Expr
), False) = Known_Compatible
711 -- Here we do not know if the value is acceptable. Strictly we don't
712 -- have to do anything, since if the alignment is bad, we have an
713 -- erroneous program. However we are allowed to check for erroneous
714 -- conditions and we decide to do this by default if the check is not
717 -- However, don't do the check if elaboration code is unwanted
719 if Restriction_Active
(No_Elaboration_Code
) then
722 -- Generate a check to raise PE if alignment may be inappropriate
725 -- If the original expression is a nonstatic constant, use the name
726 -- of the constant itself rather than duplicating its initialization
727 -- expression, which was extracted above.
729 -- Note: Expr is empty if the address-clause is applied to in-mode
730 -- actuals (allowed by 13.1(22)).
732 if not Present
(Expr
)
734 (Is_Entity_Name
(Expression
(AC
))
735 and then Ekind
(Entity
(Expression
(AC
))) = E_Constant
736 and then Nkind
(Parent
(Entity
(Expression
(AC
)))) =
737 N_Object_Declaration
)
739 Expr
:= New_Copy_Tree
(Expression
(AC
));
741 Remove_Side_Effects
(Expr
);
744 if No
(Actions
(N
)) then
745 Set_Actions
(N
, New_List
);
748 Prepend_To
(Actions
(N
),
749 Make_Raise_Program_Error
(Loc
,
756 (RTE
(RE_Integer_Address
), Expr
),
758 Make_Attribute_Reference
(Loc
,
759 Prefix
=> New_Occurrence_Of
(E
, Loc
),
760 Attribute_Name
=> Name_Alignment
)),
761 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
762 Reason
=> PE_Misaligned_Address_Value
));
764 Warning_Msg
:= No_Error_Msg
;
765 Analyze
(First
(Actions
(N
)), Suppress
=> All_Checks
);
767 -- If the above raise action generated a warning message (for example
768 -- from Warn_On_Non_Local_Exception mode with the active restriction
769 -- No_Exception_Propagation).
771 if Warning_Msg
/= No_Error_Msg
then
773 -- If the expression has a known at compile time value, then
774 -- once we know the alignment of the type, we can check if the
775 -- exception will be raised or not, and if not, we don't need
776 -- the warning so we will kill the warning later on.
778 if Compile_Time_Known_Value
(Expr
) then
779 Alignment_Warnings
.Append
780 ((E
=> E
, A
=> Expr_Value
(Expr
), W
=> Warning_Msg
));
782 -- Add explanation of the warning generated by the check
786 ("\address value may be incompatible with alignment of "
796 -- If we have some missing run time component in configurable run time
797 -- mode then just skip the check (it is not required in any case).
799 when RE_Not_Available
=>
801 end Apply_Address_Clause_Check
;
803 -------------------------------------
804 -- Apply_Arithmetic_Overflow_Check --
805 -------------------------------------
807 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
809 -- Use old routine in almost all cases (the only case we are treating
810 -- specially is the case of a signed integer arithmetic op with the
811 -- overflow checking mode set to MINIMIZED or ELIMINATED).
813 if Overflow_Check_Mode
= Strict
814 or else not Is_Signed_Integer_Arithmetic_Op
(N
)
816 Apply_Arithmetic_Overflow_Strict
(N
);
818 -- Otherwise use the new routine for the case of a signed integer
819 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
820 -- mode is MINIMIZED or ELIMINATED.
823 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
825 end Apply_Arithmetic_Overflow_Check
;
827 --------------------------------------
828 -- Apply_Arithmetic_Overflow_Strict --
829 --------------------------------------
831 -- This routine is called only if the type is an integer type and an
832 -- arithmetic overflow check may be needed for op (add, subtract, or
833 -- multiply). This check is performed if Backend_Overflow_Checks_On_Target
834 -- is not enabled and Do_Overflow_Check is set. In this case we expand the
835 -- operation into a more complex sequence of tests that ensures that
836 -- overflow is properly caught.
838 -- This is used in CHECKED modes. It is identical to the code for this
839 -- cases before the big overflow earthquake, thus ensuring that in this
840 -- modes we have compatible behavior (and reliability) to what was there
841 -- before. It is also called for types other than signed integers, and if
842 -- the Do_Overflow_Check flag is off.
844 -- Note: we also call this routine if we decide in the MINIMIZED case
845 -- to give up and just generate an overflow check without any fuss.
847 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
) is
848 Loc
: constant Source_Ptr
:= Sloc
(N
);
849 Typ
: constant Entity_Id
:= Etype
(N
);
850 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
853 -- Nothing to do if Do_Overflow_Check not set or overflow checks
856 if not Do_Overflow_Check
(N
) then
860 -- An interesting special case. If the arithmetic operation appears as
861 -- the operand of a type conversion:
865 -- and all the following conditions apply:
867 -- arithmetic operation is for a signed integer type
868 -- target type type1 is a static integer subtype
869 -- range of x and y are both included in the range of type1
870 -- range of x op y is included in the range of type1
871 -- size of type1 is at least twice the result size of op
873 -- then we don't do an overflow check in any case. Instead, we transform
874 -- the operation so that we end up with:
876 -- type1 (type1 (x) op type1 (y))
878 -- This avoids intermediate overflow before the conversion. It is
879 -- explicitly permitted by RM 3.5.4(24):
881 -- For the execution of a predefined operation of a signed integer
882 -- type, the implementation need not raise Constraint_Error if the
883 -- result is outside the base range of the type, so long as the
884 -- correct result is produced.
886 -- It's hard to imagine that any programmer counts on the exception
887 -- being raised in this case, and in any case it's wrong coding to
888 -- have this expectation, given the RM permission. Furthermore, other
889 -- Ada compilers do allow such out of range results.
891 -- Note that we do this transformation even if overflow checking is
892 -- off, since this is precisely about giving the "right" result and
893 -- avoiding the need for an overflow check.
895 -- Note: this circuit is partially redundant with respect to the similar
896 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
897 -- with cases that do not come through here. We still need the following
898 -- processing even with the Exp_Ch4 code in place, since we want to be
899 -- sure not to generate the arithmetic overflow check in these cases
900 -- (Exp_Ch4 would have a hard time removing them once generated).
902 if Is_Signed_Integer_Type
(Typ
)
903 and then Nkind
(Parent
(N
)) = N_Type_Conversion
905 Conversion_Optimization
: declare
906 Target_Type
: constant Entity_Id
:=
907 Base_Type
(Entity
(Subtype_Mark
(Parent
(N
))));
921 if Is_Integer_Type
(Target_Type
)
922 and then RM_Size
(Root_Type
(Target_Type
)) >= 2 * RM_Size
(Rtyp
)
924 Tlo
:= Expr_Value
(Type_Low_Bound
(Target_Type
));
925 Thi
:= Expr_Value
(Type_High_Bound
(Target_Type
));
928 (Left_Opnd
(N
), LOK
, Llo
, Lhi
, Assume_Valid
=> True);
930 (Right_Opnd
(N
), ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
933 and then Tlo
<= Llo
and then Lhi
<= Thi
934 and then Tlo
<= Rlo
and then Rhi
<= Thi
936 Determine_Range
(N
, VOK
, Vlo
, Vhi
, Assume_Valid
=> True);
938 if VOK
and then Tlo
<= Vlo
and then Vhi
<= Thi
then
939 Rewrite
(Left_Opnd
(N
),
940 Make_Type_Conversion
(Loc
,
941 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
942 Expression
=> Relocate_Node
(Left_Opnd
(N
))));
944 Rewrite
(Right_Opnd
(N
),
945 Make_Type_Conversion
(Loc
,
946 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
947 Expression
=> Relocate_Node
(Right_Opnd
(N
))));
949 -- Rewrite the conversion operand so that the original
950 -- node is retained, in order to avoid the warning for
951 -- redundant conversions in Resolve_Type_Conversion.
953 Rewrite
(N
, Relocate_Node
(N
));
955 Set_Etype
(N
, Target_Type
);
957 Analyze_And_Resolve
(Left_Opnd
(N
), Target_Type
);
958 Analyze_And_Resolve
(Right_Opnd
(N
), Target_Type
);
960 -- Given that the target type is twice the size of the
961 -- source type, overflow is now impossible, so we can
962 -- safely kill the overflow check and return.
964 Set_Do_Overflow_Check
(N
, False);
969 end Conversion_Optimization
;
972 -- Now see if an overflow check is required
975 Siz
: constant Int
:= UI_To_Int
(Esize
(Rtyp
));
976 Dsiz
: constant Int
:= Siz
* 2;
983 -- Skip check if back end does overflow checks, or the overflow flag
984 -- is not set anyway, or we are not doing code expansion, or the
985 -- parent node is a type conversion whose operand is an arithmetic
986 -- operation on signed integers on which the expander can promote
987 -- later the operands to type Integer (see Expand_N_Type_Conversion).
989 if Backend_Overflow_Checks_On_Target
990 or else not Do_Overflow_Check
(N
)
991 or else not Expander_Active
992 or else (Present
(Parent
(N
))
993 and then Nkind
(Parent
(N
)) = N_Type_Conversion
994 and then Integer_Promotion_Possible
(Parent
(N
)))
999 -- Otherwise, generate the full general code for front end overflow
1000 -- detection, which works by doing arithmetic in a larger type:
1006 -- Typ (Checktyp (x) op Checktyp (y));
1008 -- where Typ is the type of the original expression, and Checktyp is
1009 -- an integer type of sufficient length to hold the largest possible
1012 -- If the size of check type exceeds the size of Long_Long_Integer,
1013 -- we use a different approach, expanding to:
1015 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
1017 -- where xxx is Add, Multiply or Subtract as appropriate
1019 -- Find check type if one exists
1021 if Dsiz
<= Standard_Integer_Size
then
1022 Ctyp
:= Standard_Integer
;
1024 elsif Dsiz
<= Standard_Long_Long_Integer_Size
then
1025 Ctyp
:= Standard_Long_Long_Integer
;
1027 -- No check type exists, use runtime call
1030 if Nkind
(N
) = N_Op_Add
then
1031 Cent
:= RE_Add_With_Ovflo_Check
;
1033 elsif Nkind
(N
) = N_Op_Multiply
then
1034 Cent
:= RE_Multiply_With_Ovflo_Check
;
1037 pragma Assert
(Nkind
(N
) = N_Op_Subtract
);
1038 Cent
:= RE_Subtract_With_Ovflo_Check
;
1043 Make_Function_Call
(Loc
,
1044 Name
=> New_Occurrence_Of
(RTE
(Cent
), Loc
),
1045 Parameter_Associations
=> New_List
(
1046 OK_Convert_To
(RTE
(RE_Integer_64
), Left_Opnd
(N
)),
1047 OK_Convert_To
(RTE
(RE_Integer_64
), Right_Opnd
(N
))))));
1049 Analyze_And_Resolve
(N
, Typ
);
1053 -- If we fall through, we have the case where we do the arithmetic
1054 -- in the next higher type and get the check by conversion. In these
1055 -- cases Ctyp is set to the type to be used as the check type.
1057 Opnod
:= Relocate_Node
(N
);
1059 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
1062 Set_Etype
(Opnd
, Ctyp
);
1063 Set_Analyzed
(Opnd
, True);
1064 Set_Left_Opnd
(Opnod
, Opnd
);
1066 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
1069 Set_Etype
(Opnd
, Ctyp
);
1070 Set_Analyzed
(Opnd
, True);
1071 Set_Right_Opnd
(Opnod
, Opnd
);
1073 -- The type of the operation changes to the base type of the check
1074 -- type, and we reset the overflow check indication, since clearly no
1075 -- overflow is possible now that we are using a double length type.
1076 -- We also set the Analyzed flag to avoid a recursive attempt to
1079 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
1080 Set_Do_Overflow_Check
(Opnod
, False);
1081 Set_Analyzed
(Opnod
, True);
1083 -- Now build the outer conversion
1085 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
1087 Set_Etype
(Opnd
, Typ
);
1089 -- In the discrete type case, we directly generate the range check
1090 -- for the outer operand. This range check will implement the
1091 -- required overflow check.
1093 if Is_Discrete_Type
(Typ
) then
1095 Generate_Range_Check
1096 (Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
1098 -- For other types, we enable overflow checking on the conversion,
1099 -- after setting the node as analyzed to prevent recursive attempts
1100 -- to expand the conversion node.
1103 Set_Analyzed
(Opnd
, True);
1104 Enable_Overflow_Check
(Opnd
);
1109 when RE_Not_Available
=>
1112 end Apply_Arithmetic_Overflow_Strict
;
1114 ----------------------------------------------------
1115 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1116 ----------------------------------------------------
1118 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
) is
1119 pragma Assert
(Is_Signed_Integer_Arithmetic_Op
(Op
));
1121 Loc
: constant Source_Ptr
:= Sloc
(Op
);
1122 P
: constant Node_Id
:= Parent
(Op
);
1124 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
1125 -- Operands and results are of this type when we convert
1127 Result_Type
: constant Entity_Id
:= Etype
(Op
);
1128 -- Original result type
1130 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1131 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
1134 -- Ranges of values for result
1137 -- Nothing to do if our parent is one of the following:
1139 -- Another signed integer arithmetic op
1140 -- A membership operation
1141 -- A comparison operation
1143 -- In all these cases, we will process at the higher level (and then
1144 -- this node will be processed during the downwards recursion that
1145 -- is part of the processing in Minimize_Eliminate_Overflows).
1147 if Is_Signed_Integer_Arithmetic_Op
(P
)
1148 or else Nkind
(P
) in N_Membership_Test
1149 or else Nkind
(P
) in N_Op_Compare
1151 -- This is also true for an alternative in a case expression
1153 or else Nkind
(P
) = N_Case_Expression_Alternative
1155 -- This is also true for a range operand in a membership test
1157 or else (Nkind
(P
) = N_Range
1158 and then Nkind
(Parent
(P
)) in N_Membership_Test
)
1160 -- If_Expressions and Case_Expressions are treated as arithmetic
1161 -- ops, but if they appear in an assignment or similar contexts
1162 -- there is no overflow check that starts from that parent node,
1163 -- so apply check now.
1165 if Nkind_In
(P
, N_If_Expression
, N_Case_Expression
)
1166 and then not Is_Signed_Integer_Arithmetic_Op
(Parent
(P
))
1174 -- Otherwise, we have a top level arithmetic operation node, and this
1175 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1176 -- modes. This is the case where we tell the machinery not to move into
1177 -- Bignum mode at this top level (of course the top level operation
1178 -- will still be in Bignum mode if either of its operands are of type
1181 Minimize_Eliminate_Overflows
(Op
, Lo
, Hi
, Top_Level
=> True);
1183 -- That call may but does not necessarily change the result type of Op.
1184 -- It is the job of this routine to undo such changes, so that at the
1185 -- top level, we have the proper type. This "undoing" is a point at
1186 -- which a final overflow check may be applied.
1188 -- If the result type was not fiddled we are all set. We go to base
1189 -- types here because things may have been rewritten to generate the
1190 -- base type of the operand types.
1192 if Base_Type
(Etype
(Op
)) = Base_Type
(Result_Type
) then
1197 elsif Is_RTE
(Etype
(Op
), RE_Bignum
) then
1199 -- We need a sequence that looks like:
1201 -- Rnn : Result_Type;
1204 -- M : Mark_Id := SS_Mark;
1206 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1210 -- This block is inserted (using Insert_Actions), and then the node
1211 -- is replaced with a reference to Rnn.
1213 -- If our parent is a conversion node then there is no point in
1214 -- generating a conversion to Result_Type. Instead, we let the parent
1215 -- handle this. Note that this special case is not just about
1216 -- optimization. Consider
1220 -- X := Long_Long_Integer'Base (A * (B ** C));
1222 -- Now the product may fit in Long_Long_Integer but not in Integer.
1223 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1224 -- overflow exception for this intermediate value.
1227 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
1228 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R', Op
);
1234 RHS
:= Convert_From_Bignum
(Op
);
1236 if Nkind
(P
) /= N_Type_Conversion
then
1237 Convert_To_And_Rewrite
(Result_Type
, RHS
);
1238 Rtype
:= Result_Type
;
1240 -- Interesting question, do we need a check on that conversion
1241 -- operation. Answer, not if we know the result is in range.
1242 -- At the moment we are not taking advantage of this. To be
1243 -- looked at later ???
1250 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
1251 Make_Assignment_Statement
(Loc
,
1252 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
1253 Expression
=> RHS
));
1255 Insert_Actions
(Op
, New_List
(
1256 Make_Object_Declaration
(Loc
,
1257 Defining_Identifier
=> Rnn
,
1258 Object_Definition
=> New_Occurrence_Of
(Rtype
, Loc
)),
1261 Rewrite
(Op
, New_Occurrence_Of
(Rnn
, Loc
));
1262 Analyze_And_Resolve
(Op
);
1265 -- Here we know the result is Long_Long_Integer'Base, or that it has
1266 -- been rewritten because the parent operation is a conversion. See
1267 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1271 (Etype
(Op
) = LLIB
or else Nkind
(Parent
(Op
)) = N_Type_Conversion
);
1273 -- All we need to do here is to convert the result to the proper
1274 -- result type. As explained above for the Bignum case, we can
1275 -- omit this if our parent is a type conversion.
1277 if Nkind
(P
) /= N_Type_Conversion
then
1278 Convert_To_And_Rewrite
(Result_Type
, Op
);
1281 Analyze_And_Resolve
(Op
);
1283 end Apply_Arithmetic_Overflow_Minimized_Eliminated
;
1285 ----------------------------
1286 -- Apply_Constraint_Check --
1287 ----------------------------
1289 procedure Apply_Constraint_Check
1292 No_Sliding
: Boolean := False)
1294 Desig_Typ
: Entity_Id
;
1297 -- No checks inside a generic (check the instantiations)
1299 if Inside_A_Generic
then
1303 -- Apply required constraint checks
1305 if Is_Scalar_Type
(Typ
) then
1306 Apply_Scalar_Range_Check
(N
, Typ
);
1308 elsif Is_Array_Type
(Typ
) then
1310 -- A useful optimization: an aggregate with only an others clause
1311 -- always has the right bounds.
1313 if Nkind
(N
) = N_Aggregate
1314 and then No
(Expressions
(N
))
1316 (First
(Choices
(First
(Component_Associations
(N
)))))
1322 if Is_Constrained
(Typ
) then
1323 Apply_Length_Check
(N
, Typ
);
1326 Apply_Range_Check
(N
, Typ
);
1329 Apply_Range_Check
(N
, Typ
);
1332 elsif (Is_Record_Type
(Typ
) or else Is_Private_Type
(Typ
))
1333 and then Has_Discriminants
(Base_Type
(Typ
))
1334 and then Is_Constrained
(Typ
)
1336 Apply_Discriminant_Check
(N
, Typ
);
1338 elsif Is_Access_Type
(Typ
) then
1340 Desig_Typ
:= Designated_Type
(Typ
);
1342 -- No checks necessary if expression statically null
1344 if Known_Null
(N
) then
1345 if Can_Never_Be_Null
(Typ
) then
1346 Install_Null_Excluding_Check
(N
);
1349 -- No sliding possible on access to arrays
1351 elsif Is_Array_Type
(Desig_Typ
) then
1352 if Is_Constrained
(Desig_Typ
) then
1353 Apply_Length_Check
(N
, Typ
);
1356 Apply_Range_Check
(N
, Typ
);
1358 -- Do not install a discriminant check for a constrained subtype
1359 -- created for an unconstrained nominal type because the subtype
1360 -- has the correct constraints by construction.
1362 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
1363 and then Is_Constrained
(Desig_Typ
)
1364 and then not Is_Constr_Subt_For_U_Nominal
(Desig_Typ
)
1366 Apply_Discriminant_Check
(N
, Typ
);
1369 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1370 -- this check if the constraint node is illegal, as shown by having
1371 -- an error posted. This additional guard prevents cascaded errors
1372 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1374 if Can_Never_Be_Null
(Typ
)
1375 and then not Can_Never_Be_Null
(Etype
(N
))
1376 and then not Error_Posted
(N
)
1378 Install_Null_Excluding_Check
(N
);
1381 end Apply_Constraint_Check
;
1383 ------------------------------
1384 -- Apply_Discriminant_Check --
1385 ------------------------------
1387 procedure Apply_Discriminant_Check
1390 Lhs
: Node_Id
:= Empty
)
1392 Loc
: constant Source_Ptr
:= Sloc
(N
);
1393 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1394 S_Typ
: Entity_Id
:= Etype
(N
);
1398 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean;
1399 -- A heap object with an indefinite subtype is constrained by its
1400 -- initial value, and assigning to it requires a constraint_check.
1401 -- The target may be an explicit dereference, or a renaming of one.
1403 function Is_Aliased_Unconstrained_Component
return Boolean;
1404 -- It is possible for an aliased component to have a nominal
1405 -- unconstrained subtype (through instantiation). If this is a
1406 -- discriminated component assigned in the expansion of an aggregate
1407 -- in an initialization, the check must be suppressed. This unusual
1408 -- situation requires a predicate of its own.
1410 ----------------------------------
1411 -- Denotes_Explicit_Dereference --
1412 ----------------------------------
1414 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean is
1417 Nkind
(Obj
) = N_Explicit_Dereference
1419 (Is_Entity_Name
(Obj
)
1420 and then Present
(Renamed_Object
(Entity
(Obj
)))
1421 and then Nkind
(Renamed_Object
(Entity
(Obj
))) =
1422 N_Explicit_Dereference
);
1423 end Denotes_Explicit_Dereference
;
1425 ----------------------------------------
1426 -- Is_Aliased_Unconstrained_Component --
1427 ----------------------------------------
1429 function Is_Aliased_Unconstrained_Component
return Boolean is
1434 if Nkind
(Lhs
) /= N_Selected_Component
then
1437 Comp
:= Entity
(Selector_Name
(Lhs
));
1438 Pref
:= Prefix
(Lhs
);
1441 if Ekind
(Comp
) /= E_Component
1442 or else not Is_Aliased
(Comp
)
1447 return not Comes_From_Source
(Pref
)
1448 and then In_Instance
1449 and then not Is_Constrained
(Etype
(Comp
));
1450 end Is_Aliased_Unconstrained_Component
;
1452 -- Start of processing for Apply_Discriminant_Check
1456 T_Typ
:= Designated_Type
(Typ
);
1461 -- If the expression is a function call that returns a limited object
1462 -- it cannot be copied. It is not clear how to perform the proper
1463 -- discriminant check in this case because the discriminant value must
1464 -- be retrieved from the constructed object itself.
1466 if Nkind
(N
) = N_Function_Call
1467 and then Is_Limited_Type
(Typ
)
1468 and then Is_Entity_Name
(Name
(N
))
1469 and then Returns_By_Ref
(Entity
(Name
(N
)))
1474 -- Only apply checks when generating code and discriminant checks are
1475 -- not suppressed. In GNATprove mode, we do not apply the checks, but we
1476 -- still analyze the expression to possibly issue errors on SPARK code
1477 -- when a run-time error can be detected at compile time.
1479 if not GNATprove_Mode
then
1480 if not Expander_Active
1481 or else Discriminant_Checks_Suppressed
(T_Typ
)
1487 -- No discriminant checks necessary for an access when expression is
1488 -- statically Null. This is not only an optimization, it is fundamental
1489 -- because otherwise discriminant checks may be generated in init procs
1490 -- for types containing an access to a not-yet-frozen record, causing a
1491 -- deadly forward reference.
1493 -- Also, if the expression is of an access type whose designated type is
1494 -- incomplete, then the access value must be null and we suppress the
1497 if Known_Null
(N
) then
1500 elsif Is_Access_Type
(S_Typ
) then
1501 S_Typ
:= Designated_Type
(S_Typ
);
1503 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1508 -- If an assignment target is present, then we need to generate the
1509 -- actual subtype if the target is a parameter or aliased object with
1510 -- an unconstrained nominal subtype.
1512 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1513 -- subtype to the parameter and dereference cases, since other aliased
1514 -- objects are unconstrained (unless the nominal subtype is explicitly
1518 and then (Present
(Param_Entity
(Lhs
))
1519 or else (Ada_Version
< Ada_2005
1520 and then not Is_Constrained
(T_Typ
)
1521 and then Is_Aliased_View
(Lhs
)
1522 and then not Is_Aliased_Unconstrained_Component
)
1523 or else (Ada_Version
>= Ada_2005
1524 and then not Is_Constrained
(T_Typ
)
1525 and then Denotes_Explicit_Dereference
(Lhs
)
1526 and then Nkind
(Original_Node
(Lhs
)) /=
1529 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1532 -- Nothing to do if the type is unconstrained (this is the case where
1533 -- the actual subtype in the RM sense of N is unconstrained and no check
1536 if not Is_Constrained
(T_Typ
) then
1539 -- Ada 2005: nothing to do if the type is one for which there is a
1540 -- partial view that is constrained.
1542 elsif Ada_Version
>= Ada_2005
1543 and then Object_Type_Has_Constrained_Partial_View
1544 (Typ
=> Base_Type
(T_Typ
),
1545 Scop
=> Current_Scope
)
1550 -- Nothing to do if the type is an Unchecked_Union
1552 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
1556 -- Suppress checks if the subtypes are the same. The check must be
1557 -- preserved in an assignment to a formal, because the constraint is
1558 -- given by the actual.
1560 if Nkind
(Original_Node
(N
)) /= N_Allocator
1562 or else not Is_Entity_Name
(Lhs
)
1563 or else No
(Param_Entity
(Lhs
)))
1566 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1567 and then not Is_Aliased_View
(Lhs
)
1572 -- We can also eliminate checks on allocators with a subtype mark that
1573 -- coincides with the context type. The context type may be a subtype
1574 -- without a constraint (common case, a generic actual).
1576 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1577 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1580 Alloc_Typ
: constant Entity_Id
:=
1581 Entity
(Expression
(Original_Node
(N
)));
1584 if Alloc_Typ
= T_Typ
1585 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1586 and then Is_Entity_Name
(
1587 Subtype_Indication
(Parent
(T_Typ
)))
1588 and then Alloc_Typ
= Base_Type
(T_Typ
))
1596 -- See if we have a case where the types are both constrained, and all
1597 -- the constraints are constants. In this case, we can do the check
1598 -- successfully at compile time.
1600 -- We skip this check for the case where the node is rewritten as
1601 -- an allocator, because it already carries the context subtype,
1602 -- and extracting the discriminants from the aggregate is messy.
1604 if Is_Constrained
(S_Typ
)
1605 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1615 -- S_Typ may not have discriminants in the case where it is a
1616 -- private type completed by a default discriminated type. In that
1617 -- case, we need to get the constraints from the underlying type.
1618 -- If the underlying type is unconstrained (i.e. has no default
1619 -- discriminants) no check is needed.
1621 if Has_Discriminants
(S_Typ
) then
1622 Discr
:= First_Discriminant
(S_Typ
);
1623 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1626 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1629 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1635 -- A further optimization: if T_Typ is derived from S_Typ
1636 -- without imposing a constraint, no check is needed.
1638 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1639 N_Full_Type_Declaration
1642 Type_Def
: constant Node_Id
:=
1643 Type_Definition
(Original_Node
(Parent
(T_Typ
)));
1645 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1646 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1647 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1655 -- Constraint may appear in full view of type
1657 if Ekind
(T_Typ
) = E_Private_Subtype
1658 and then Present
(Full_View
(T_Typ
))
1661 First_Elmt
(Discriminant_Constraint
(Full_View
(T_Typ
)));
1664 First_Elmt
(Discriminant_Constraint
(T_Typ
));
1667 while Present
(Discr
) loop
1668 ItemS
:= Node
(DconS
);
1669 ItemT
:= Node
(DconT
);
1671 -- For a discriminated component type constrained by the
1672 -- current instance of an enclosing type, there is no
1673 -- applicable discriminant check.
1675 if Nkind
(ItemT
) = N_Attribute_Reference
1676 and then Is_Access_Type
(Etype
(ItemT
))
1677 and then Is_Entity_Name
(Prefix
(ItemT
))
1678 and then Is_Type
(Entity
(Prefix
(ItemT
)))
1683 -- If the expressions for the discriminants are identical
1684 -- and it is side-effect free (for now just an entity),
1685 -- this may be a shared constraint, e.g. from a subtype
1686 -- without a constraint introduced as a generic actual.
1687 -- Examine other discriminants if any.
1690 and then Is_Entity_Name
(ItemS
)
1694 elsif not Is_OK_Static_Expression
(ItemS
)
1695 or else not Is_OK_Static_Expression
(ItemT
)
1699 elsif Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1700 if Do_Access
then -- needs run-time check.
1703 Apply_Compile_Time_Constraint_Error
1704 (N
, "incorrect value for discriminant&??",
1705 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1712 Next_Discriminant
(Discr
);
1721 -- In GNATprove mode, we do not apply the checks
1723 if GNATprove_Mode
then
1727 -- Here we need a discriminant check. First build the expression
1728 -- for the comparisons of the discriminants:
1730 -- (n.disc1 /= typ.disc1) or else
1731 -- (n.disc2 /= typ.disc2) or else
1733 -- (n.discn /= typ.discn)
1735 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1737 -- If Lhs is set and is a parameter, then the condition is guarded by:
1738 -- lhs'constrained and then (condition built above)
1740 if Present
(Param_Entity
(Lhs
)) then
1744 Make_Attribute_Reference
(Loc
,
1745 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1746 Attribute_Name
=> Name_Constrained
),
1747 Right_Opnd
=> Cond
);
1751 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1755 Make_Raise_Constraint_Error
(Loc
,
1757 Reason
=> CE_Discriminant_Check_Failed
));
1758 end Apply_Discriminant_Check
;
1760 -------------------------
1761 -- Apply_Divide_Checks --
1762 -------------------------
1764 procedure Apply_Divide_Checks
(N
: Node_Id
) is
1765 Loc
: constant Source_Ptr
:= Sloc
(N
);
1766 Typ
: constant Entity_Id
:= Etype
(N
);
1767 Left
: constant Node_Id
:= Left_Opnd
(N
);
1768 Right
: constant Node_Id
:= Right_Opnd
(N
);
1770 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1771 -- Current overflow checking mode
1781 pragma Warnings
(Off
, Lhi
);
1782 -- Don't actually use this value
1785 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1786 -- operating on signed integer types, then the only thing this routine
1787 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1788 -- procedure will (possibly later on during recursive downward calls),
1789 -- ensure that any needed overflow/division checks are properly applied.
1791 if Mode
in Minimized_Or_Eliminated
1792 and then Is_Signed_Integer_Type
(Typ
)
1794 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
1798 -- Proceed here in SUPPRESSED or CHECKED modes
1801 and then not Backend_Divide_Checks_On_Target
1802 and then Check_Needed
(Right
, Division_Check
)
1804 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
1806 -- Deal with division check
1808 if Do_Division_Check
(N
)
1809 and then not Division_Checks_Suppressed
(Typ
)
1811 Apply_Division_Check
(N
, Rlo
, Rhi
, ROK
);
1814 -- Deal with overflow check
1816 if Do_Overflow_Check
(N
)
1817 and then not Overflow_Checks_Suppressed
(Etype
(N
))
1819 Set_Do_Overflow_Check
(N
, False);
1821 -- Test for extremely annoying case of xxx'First divided by -1
1822 -- for division of signed integer types (only overflow case).
1824 if Nkind
(N
) = N_Op_Divide
1825 and then Is_Signed_Integer_Type
(Typ
)
1827 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
1828 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1830 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1832 ((not LOK
) or else (Llo
= LLB
))
1834 -- Ensure that expressions are not evaluated twice (once
1835 -- for their runtime checks and once for their regular
1838 Force_Evaluation
(Left
, Mode
=> Strict
);
1839 Force_Evaluation
(Right
, Mode
=> Strict
);
1842 Make_Raise_Constraint_Error
(Loc
,
1848 Duplicate_Subexpr_Move_Checks
(Left
),
1849 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1853 Left_Opnd
=> Duplicate_Subexpr
(Right
),
1854 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1))),
1856 Reason
=> CE_Overflow_Check_Failed
));
1861 end Apply_Divide_Checks
;
1863 --------------------------
1864 -- Apply_Division_Check --
1865 --------------------------
1867 procedure Apply_Division_Check
1873 pragma Assert
(Do_Division_Check
(N
));
1875 Loc
: constant Source_Ptr
:= Sloc
(N
);
1876 Right
: constant Node_Id
:= Right_Opnd
(N
);
1881 and then not Backend_Divide_Checks_On_Target
1882 and then Check_Needed
(Right
, Division_Check
)
1884 -- See if division by zero possible, and if so generate test. This
1885 -- part of the test is not controlled by the -gnato switch, since it
1886 -- is a Division_Check and not an Overflow_Check.
1888 and then Do_Division_Check
(N
)
1890 Set_Do_Division_Check
(N
, False);
1892 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1893 if Is_Floating_Point_Type
(Etype
(N
)) then
1894 Opnd
:= Make_Real_Literal
(Loc
, Ureal_0
);
1896 Opnd
:= Make_Integer_Literal
(Loc
, 0);
1900 Make_Raise_Constraint_Error
(Loc
,
1903 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1904 Right_Opnd
=> Opnd
),
1905 Reason
=> CE_Divide_By_Zero
));
1908 end Apply_Division_Check
;
1910 ----------------------------------
1911 -- Apply_Float_Conversion_Check --
1912 ----------------------------------
1914 -- Let F and I be the source and target types of the conversion. The RM
1915 -- specifies that a floating-point value X is rounded to the nearest
1916 -- integer, with halfway cases being rounded away from zero. The rounded
1917 -- value of X is checked against I'Range.
1919 -- The catch in the above paragraph is that there is no good way to know
1920 -- whether the round-to-integer operation resulted in overflow. A remedy is
1921 -- to perform a range check in the floating-point domain instead, however:
1923 -- (1) The bounds may not be known at compile time
1924 -- (2) The check must take into account rounding or truncation.
1925 -- (3) The range of type I may not be exactly representable in F.
1926 -- (4) For the rounding case, The end-points I'First - 0.5 and
1927 -- I'Last + 0.5 may or may not be in range, depending on the
1928 -- sign of I'First and I'Last.
1929 -- (5) X may be a NaN, which will fail any comparison
1931 -- The following steps correctly convert X with rounding:
1933 -- (1) If either I'First or I'Last is not known at compile time, use
1934 -- I'Base instead of I in the next three steps and perform a
1935 -- regular range check against I'Range after conversion.
1936 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1937 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1938 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1939 -- In other words, take one of the closest floating-point numbers
1940 -- (which is an integer value) to I'First, and see if it is in
1942 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1943 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1944 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1945 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1946 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1948 -- For the truncating case, replace steps (2) and (3) as follows:
1949 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1950 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1952 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1953 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1956 procedure Apply_Float_Conversion_Check
1958 Target_Typ
: Entity_Id
)
1960 LB
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1961 HB
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1962 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1963 Expr_Type
: constant Entity_Id
:= Base_Type
(Etype
(Ck_Node
));
1964 Target_Base
: constant Entity_Id
:=
1965 Implementation_Base_Type
(Target_Typ
);
1967 Par
: constant Node_Id
:= Parent
(Ck_Node
);
1968 pragma Assert
(Nkind
(Par
) = N_Type_Conversion
);
1969 -- Parent of check node, must be a type conversion
1971 Truncate
: constant Boolean := Float_Truncate
(Par
);
1972 Max_Bound
: constant Uint
:=
1974 (Machine_Radix_Value
(Expr_Type
),
1975 Machine_Mantissa_Value
(Expr_Type
) - 1) - 1;
1977 -- Largest bound, so bound plus or minus half is a machine number of F
1979 Ifirst
, Ilast
: Uint
;
1980 -- Bounds of integer type
1983 -- Bounds to check in floating-point domain
1985 Lo_OK
, Hi_OK
: Boolean;
1986 -- True iff Lo resp. Hi belongs to I'Range
1988 Lo_Chk
, Hi_Chk
: Node_Id
;
1989 -- Expressions that are False iff check fails
1991 Reason
: RT_Exception_Code
;
1994 -- We do not need checks if we are not generating code (i.e. the full
1995 -- expander is not active). In SPARK mode, we specifically don't want
1996 -- the frontend to expand these checks, which are dealt with directly
1997 -- in the formal verification backend.
1999 if not Expander_Active
then
2003 if not Compile_Time_Known_Value
(LB
)
2004 or not Compile_Time_Known_Value
(HB
)
2007 -- First check that the value falls in the range of the base type,
2008 -- to prevent overflow during conversion and then perform a
2009 -- regular range check against the (dynamic) bounds.
2011 pragma Assert
(Target_Base
/= Target_Typ
);
2013 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Par
);
2016 Apply_Float_Conversion_Check
(Ck_Node
, Target_Base
);
2017 Set_Etype
(Temp
, Target_Base
);
2019 Insert_Action
(Parent
(Par
),
2020 Make_Object_Declaration
(Loc
,
2021 Defining_Identifier
=> Temp
,
2022 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
),
2023 Expression
=> New_Copy_Tree
(Par
)),
2024 Suppress
=> All_Checks
);
2027 Make_Raise_Constraint_Error
(Loc
,
2030 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
2031 Right_Opnd
=> New_Occurrence_Of
(Target_Typ
, Loc
)),
2032 Reason
=> CE_Range_Check_Failed
));
2033 Rewrite
(Par
, New_Occurrence_Of
(Temp
, Loc
));
2039 -- Get the (static) bounds of the target type
2041 Ifirst
:= Expr_Value
(LB
);
2042 Ilast
:= Expr_Value
(HB
);
2044 -- A simple optimization: if the expression is a universal literal,
2045 -- we can do the comparison with the bounds and the conversion to
2046 -- an integer type statically. The range checks are unchanged.
2048 if Nkind
(Ck_Node
) = N_Real_Literal
2049 and then Etype
(Ck_Node
) = Universal_Real
2050 and then Is_Integer_Type
(Target_Typ
)
2051 and then Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
2054 Int_Val
: constant Uint
:= UR_To_Uint
(Realval
(Ck_Node
));
2057 if Int_Val
<= Ilast
and then Int_Val
>= Ifirst
then
2059 -- Conversion is safe
2061 Rewrite
(Parent
(Ck_Node
),
2062 Make_Integer_Literal
(Loc
, UI_To_Int
(Int_Val
)));
2063 Analyze_And_Resolve
(Parent
(Ck_Node
), Target_Typ
);
2069 -- Check against lower bound
2071 if Truncate
and then Ifirst
> 0 then
2072 Lo
:= Pred
(Expr_Type
, UR_From_Uint
(Ifirst
));
2076 Lo
:= Succ
(Expr_Type
, UR_From_Uint
(Ifirst
- 1));
2079 elsif abs (Ifirst
) < Max_Bound
then
2080 Lo
:= UR_From_Uint
(Ifirst
) - Ureal_Half
;
2081 Lo_OK
:= (Ifirst
> 0);
2084 Lo
:= Machine
(Expr_Type
, UR_From_Uint
(Ifirst
), Round_Even
, Ck_Node
);
2085 Lo_OK
:= (Lo
>= UR_From_Uint
(Ifirst
));
2090 -- Lo_Chk := (X >= Lo)
2092 Lo_Chk
:= Make_Op_Ge
(Loc
,
2093 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2094 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2097 -- Lo_Chk := (X > Lo)
2099 Lo_Chk
:= Make_Op_Gt
(Loc
,
2100 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2101 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2104 -- Check against higher bound
2106 if Truncate
and then Ilast
< 0 then
2107 Hi
:= Succ
(Expr_Type
, UR_From_Uint
(Ilast
));
2111 Hi
:= Pred
(Expr_Type
, UR_From_Uint
(Ilast
+ 1));
2114 elsif abs (Ilast
) < Max_Bound
then
2115 Hi
:= UR_From_Uint
(Ilast
) + Ureal_Half
;
2116 Hi_OK
:= (Ilast
< 0);
2118 Hi
:= Machine
(Expr_Type
, UR_From_Uint
(Ilast
), Round_Even
, Ck_Node
);
2119 Hi_OK
:= (Hi
<= UR_From_Uint
(Ilast
));
2124 -- Hi_Chk := (X <= Hi)
2126 Hi_Chk
:= Make_Op_Le
(Loc
,
2127 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2128 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2131 -- Hi_Chk := (X < Hi)
2133 Hi_Chk
:= Make_Op_Lt
(Loc
,
2134 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2135 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2138 -- If the bounds of the target type are the same as those of the base
2139 -- type, the check is an overflow check as a range check is not
2140 -- performed in these cases.
2142 if Expr_Value
(Type_Low_Bound
(Target_Base
)) = Ifirst
2143 and then Expr_Value
(Type_High_Bound
(Target_Base
)) = Ilast
2145 Reason
:= CE_Overflow_Check_Failed
;
2147 Reason
:= CE_Range_Check_Failed
;
2150 -- Raise CE if either conditions does not hold
2152 Insert_Action
(Ck_Node
,
2153 Make_Raise_Constraint_Error
(Loc
,
2154 Condition
=> Make_Op_Not
(Loc
, Make_And_Then
(Loc
, Lo_Chk
, Hi_Chk
)),
2156 end Apply_Float_Conversion_Check
;
2158 ------------------------
2159 -- Apply_Length_Check --
2160 ------------------------
2162 procedure Apply_Length_Check
2164 Target_Typ
: Entity_Id
;
2165 Source_Typ
: Entity_Id
:= Empty
)
2168 Apply_Selected_Length_Checks
2169 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2170 end Apply_Length_Check
;
2172 -------------------------------------
2173 -- Apply_Parameter_Aliasing_Checks --
2174 -------------------------------------
2176 procedure Apply_Parameter_Aliasing_Checks
2180 Loc
: constant Source_Ptr
:= Sloc
(Call
);
2182 function May_Cause_Aliasing
2183 (Formal_1
: Entity_Id
;
2184 Formal_2
: Entity_Id
) return Boolean;
2185 -- Determine whether two formal parameters can alias each other
2186 -- depending on their modes.
2188 function Original_Actual
(N
: Node_Id
) return Node_Id
;
2189 -- The expander may replace an actual with a temporary for the sake of
2190 -- side effect removal. The temporary may hide a potential aliasing as
2191 -- it does not share the address of the actual. This routine attempts
2192 -- to retrieve the original actual.
2194 procedure Overlap_Check
2195 (Actual_1
: Node_Id
;
2197 Formal_1
: Entity_Id
;
2198 Formal_2
: Entity_Id
;
2199 Check
: in out Node_Id
);
2200 -- Create a check to determine whether Actual_1 overlaps with Actual_2.
2201 -- If detailed exception messages are enabled, the check is augmented to
2202 -- provide information about the names of the corresponding formals. See
2203 -- the body for details. Actual_1 and Actual_2 denote the two actuals to
2204 -- be tested. Formal_1 and Formal_2 denote the corresponding formals.
2205 -- Check contains all and-ed simple tests generated so far or remains
2206 -- unchanged in the case of detailed exception messaged.
2208 ------------------------
2209 -- May_Cause_Aliasing --
2210 ------------------------
2212 function May_Cause_Aliasing
2213 (Formal_1
: Entity_Id
;
2214 Formal_2
: Entity_Id
) return Boolean
2217 -- The following combination cannot lead to aliasing
2219 -- Formal 1 Formal 2
2222 if Ekind
(Formal_1
) = E_In_Parameter
2224 Ekind
(Formal_2
) = E_In_Parameter
2228 -- The following combinations may lead to aliasing
2230 -- Formal 1 Formal 2
2240 end May_Cause_Aliasing
;
2242 ---------------------
2243 -- Original_Actual --
2244 ---------------------
2246 function Original_Actual
(N
: Node_Id
) return Node_Id
is
2248 if Nkind
(N
) = N_Type_Conversion
then
2249 return Expression
(N
);
2251 -- The expander created a temporary to capture the result of a type
2252 -- conversion where the expression is the real actual.
2254 elsif Nkind
(N
) = N_Identifier
2255 and then Present
(Original_Node
(N
))
2256 and then Nkind
(Original_Node
(N
)) = N_Type_Conversion
2258 return Expression
(Original_Node
(N
));
2262 end Original_Actual
;
2268 procedure Overlap_Check
2269 (Actual_1
: Node_Id
;
2271 Formal_1
: Entity_Id
;
2272 Formal_2
: Entity_Id
;
2273 Check
: in out Node_Id
)
2276 ID_Casing
: constant Casing_Type
:=
2277 Identifier_Casing
(Source_Index
(Current_Sem_Unit
));
2281 -- Actual_1'Overlaps_Storage (Actual_2)
2284 Make_Attribute_Reference
(Loc
,
2285 Prefix
=> New_Copy_Tree
(Original_Actual
(Actual_1
)),
2286 Attribute_Name
=> Name_Overlaps_Storage
,
2288 New_List
(New_Copy_Tree
(Original_Actual
(Actual_2
))));
2290 -- Generate the following check when detailed exception messages are
2293 -- if Actual_1'Overlaps_Storage (Actual_2) then
2294 -- raise Program_Error with <detailed message>;
2297 if Exception_Extra_Info
then
2300 -- Do not generate location information for internal calls
2302 if Comes_From_Source
(Call
) then
2303 Store_String_Chars
(Build_Location_String
(Loc
));
2304 Store_String_Char
(' ');
2307 Store_String_Chars
("aliased parameters, actuals for """);
2309 Get_Name_String
(Chars
(Formal_1
));
2310 Set_Casing
(ID_Casing
);
2311 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2313 Store_String_Chars
(""" and """);
2315 Get_Name_String
(Chars
(Formal_2
));
2316 Set_Casing
(ID_Casing
);
2317 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2319 Store_String_Chars
(""" overlap");
2321 Insert_Action
(Call
,
2322 Make_If_Statement
(Loc
,
2324 Then_Statements
=> New_List
(
2325 Make_Raise_Statement
(Loc
,
2327 New_Occurrence_Of
(Standard_Program_Error
, Loc
),
2328 Expression
=> Make_String_Literal
(Loc
, End_String
)))));
2330 -- Create a sequence of overlapping checks by and-ing them all
2340 Right_Opnd
=> Cond
);
2350 Formal_1
: Entity_Id
;
2351 Formal_2
: Entity_Id
;
2352 Orig_Act_1
: Node_Id
;
2353 Orig_Act_2
: Node_Id
;
2355 -- Start of processing for Apply_Parameter_Aliasing_Checks
2360 Actual_1
:= First_Actual
(Call
);
2361 Formal_1
:= First_Formal
(Subp
);
2362 while Present
(Actual_1
) and then Present
(Formal_1
) loop
2363 Orig_Act_1
:= Original_Actual
(Actual_1
);
2365 -- Ensure that the actual is an object that is not passed by value.
2366 -- Elementary types are always passed by value, therefore actuals of
2367 -- such types cannot lead to aliasing. An aggregate is an object in
2368 -- Ada 2012, but an actual that is an aggregate cannot overlap with
2369 -- another actual. A type that is By_Reference (such as an array of
2370 -- controlled types) is not subject to the check because any update
2371 -- will be done in place and a subsequent read will always see the
2372 -- correct value, see RM 6.2 (12/3).
2374 if Nkind
(Orig_Act_1
) = N_Aggregate
2375 or else (Nkind
(Orig_Act_1
) = N_Qualified_Expression
2376 and then Nkind
(Expression
(Orig_Act_1
)) = N_Aggregate
)
2380 elsif Is_Object_Reference
(Orig_Act_1
)
2381 and then not Is_Elementary_Type
(Etype
(Orig_Act_1
))
2382 and then not Is_By_Reference_Type
(Etype
(Orig_Act_1
))
2384 Actual_2
:= Next_Actual
(Actual_1
);
2385 Formal_2
:= Next_Formal
(Formal_1
);
2386 while Present
(Actual_2
) and then Present
(Formal_2
) loop
2387 Orig_Act_2
:= Original_Actual
(Actual_2
);
2389 -- The other actual we are testing against must also denote
2390 -- a non pass-by-value object. Generate the check only when
2391 -- the mode of the two formals may lead to aliasing.
2393 if Is_Object_Reference
(Orig_Act_2
)
2394 and then not Is_Elementary_Type
(Etype
(Orig_Act_2
))
2395 and then May_Cause_Aliasing
(Formal_1
, Formal_2
)
2397 Remove_Side_Effects
(Actual_1
);
2398 Remove_Side_Effects
(Actual_2
);
2401 (Actual_1
=> Actual_1
,
2402 Actual_2
=> Actual_2
,
2403 Formal_1
=> Formal_1
,
2404 Formal_2
=> Formal_2
,
2408 Next_Actual
(Actual_2
);
2409 Next_Formal
(Formal_2
);
2413 Next_Actual
(Actual_1
);
2414 Next_Formal
(Formal_1
);
2417 -- Place a simple check right before the call
2419 if Present
(Check
) and then not Exception_Extra_Info
then
2420 Insert_Action
(Call
,
2421 Make_Raise_Program_Error
(Loc
,
2423 Reason
=> PE_Aliased_Parameters
));
2425 end Apply_Parameter_Aliasing_Checks
;
2427 -------------------------------------
2428 -- Apply_Parameter_Validity_Checks --
2429 -------------------------------------
2431 procedure Apply_Parameter_Validity_Checks
(Subp
: Entity_Id
) is
2432 Subp_Decl
: Node_Id
;
2434 procedure Add_Validity_Check
2435 (Formal
: Entity_Id
;
2437 For_Result
: Boolean := False);
2438 -- Add a single 'Valid[_Scalar] check which verifies the initialization
2439 -- of Formal. Prag_Nam denotes the pre or post condition pragma name.
2440 -- Set flag For_Result when to verify the result of a function.
2442 ------------------------
2443 -- Add_Validity_Check --
2444 ------------------------
2446 procedure Add_Validity_Check
2447 (Formal
: Entity_Id
;
2449 For_Result
: Boolean := False)
2451 procedure Build_Pre_Post_Condition
(Expr
: Node_Id
);
2452 -- Create a pre/postcondition pragma that tests expression Expr
2454 ------------------------------
2455 -- Build_Pre_Post_Condition --
2456 ------------------------------
2458 procedure Build_Pre_Post_Condition
(Expr
: Node_Id
) is
2459 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2467 Pragma_Argument_Associations
=> New_List
(
2468 Make_Pragma_Argument_Association
(Loc
,
2469 Chars
=> Name_Check
,
2470 Expression
=> Expr
)));
2472 -- Add a message unless exception messages are suppressed
2474 if not Exception_Locations_Suppressed
then
2475 Append_To
(Pragma_Argument_Associations
(Prag
),
2476 Make_Pragma_Argument_Association
(Loc
,
2477 Chars
=> Name_Message
,
2479 Make_String_Literal
(Loc
,
2481 & Get_Name_String
(Prag_Nam
)
2483 & Build_Location_String
(Loc
))));
2486 -- Insert the pragma in the tree
2488 if Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
then
2489 Add_Global_Declaration
(Prag
);
2492 -- PPC pragmas associated with subprogram bodies must be inserted
2493 -- in the declarative part of the body.
2495 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
then
2496 Decls
:= Declarations
(Subp_Decl
);
2500 Set_Declarations
(Subp_Decl
, Decls
);
2503 Prepend_To
(Decls
, Prag
);
2506 -- For subprogram declarations insert the PPC pragma right after
2507 -- the declarative node.
2510 Insert_After_And_Analyze
(Subp_Decl
, Prag
);
2512 end Build_Pre_Post_Condition
;
2516 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2517 Typ
: constant Entity_Id
:= Etype
(Formal
);
2521 -- Start of processing for Add_Validity_Check
2524 -- For scalars, generate 'Valid test
2526 if Is_Scalar_Type
(Typ
) then
2529 -- For any non-scalar with scalar parts, generate 'Valid_Scalars test
2531 elsif Scalar_Part_Present
(Typ
) then
2532 Nam
:= Name_Valid_Scalars
;
2534 -- No test needed for other cases (no scalars to test)
2540 -- Step 1: Create the expression to verify the validity of the
2543 Check
:= New_Occurrence_Of
(Formal
, Loc
);
2545 -- When processing a function result, use 'Result. Generate
2550 Make_Attribute_Reference
(Loc
,
2552 Attribute_Name
=> Name_Result
);
2556 -- Context['Result]'Valid[_Scalars]
2559 Make_Attribute_Reference
(Loc
,
2561 Attribute_Name
=> Nam
);
2563 -- Step 2: Create a pre or post condition pragma
2565 Build_Pre_Post_Condition
(Check
);
2566 end Add_Validity_Check
;
2571 Subp_Spec
: Node_Id
;
2573 -- Start of processing for Apply_Parameter_Validity_Checks
2576 -- Extract the subprogram specification and declaration nodes
2578 Subp_Spec
:= Parent
(Subp
);
2580 if Nkind
(Subp_Spec
) = N_Defining_Program_Unit_Name
then
2581 Subp_Spec
:= Parent
(Subp_Spec
);
2584 Subp_Decl
:= Parent
(Subp_Spec
);
2586 if not Comes_From_Source
(Subp
)
2588 -- Do not process formal subprograms because the corresponding actual
2589 -- will receive the proper checks when the instance is analyzed.
2591 or else Is_Formal_Subprogram
(Subp
)
2593 -- Do not process imported subprograms since pre and postconditions
2594 -- are never verified on routines coming from a different language.
2596 or else Is_Imported
(Subp
)
2597 or else Is_Intrinsic_Subprogram
(Subp
)
2599 -- The PPC pragmas generated by this routine do not correspond to
2600 -- source aspects, therefore they cannot be applied to abstract
2603 or else Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
2605 -- Do not consider subprogram renaminds because the renamed entity
2606 -- already has the proper PPC pragmas.
2608 or else Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
2610 -- Do not process null procedures because there is no benefit of
2611 -- adding the checks to a no action routine.
2613 or else (Nkind
(Subp_Spec
) = N_Procedure_Specification
2614 and then Null_Present
(Subp_Spec
))
2619 -- Inspect all the formals applying aliasing and scalar initialization
2620 -- checks where applicable.
2622 Formal
:= First_Formal
(Subp
);
2623 while Present
(Formal
) loop
2625 -- Generate the following scalar initialization checks for each
2626 -- formal parameter:
2628 -- mode IN - Pre => Formal'Valid[_Scalars]
2629 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2630 -- mode OUT - Post => Formal'Valid[_Scalars]
2632 if Check_Validity_Of_Parameters
then
2633 if Ekind_In
(Formal
, E_In_Parameter
, E_In_Out_Parameter
) then
2634 Add_Validity_Check
(Formal
, Name_Precondition
, False);
2637 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
2638 Add_Validity_Check
(Formal
, Name_Postcondition
, False);
2642 Next_Formal
(Formal
);
2645 -- Generate following scalar initialization check for function result:
2647 -- Post => Subp'Result'Valid[_Scalars]
2649 if Check_Validity_Of_Parameters
and then Ekind
(Subp
) = E_Function
then
2650 Add_Validity_Check
(Subp
, Name_Postcondition
, True);
2652 end Apply_Parameter_Validity_Checks
;
2654 ---------------------------
2655 -- Apply_Predicate_Check --
2656 ---------------------------
2658 procedure Apply_Predicate_Check
2661 Fun
: Entity_Id
:= Empty
)
2666 if Predicate_Checks_Suppressed
(Empty
) then
2669 elsif Predicates_Ignored
(Typ
) then
2672 elsif Present
(Predicate_Function
(Typ
)) then
2674 while Present
(S
) and then not Is_Subprogram
(S
) loop
2678 -- A predicate check does not apply within internally generated
2679 -- subprograms, such as TSS functions.
2681 if Within_Internal_Subprogram
then
2684 -- If the check appears within the predicate function itself, it
2685 -- means that the user specified a check whose formal is the
2686 -- predicated subtype itself, rather than some covering type. This
2687 -- is likely to be a common error, and thus deserves a warning.
2689 elsif Present
(S
) and then S
= Predicate_Function
(Typ
) then
2691 ("predicate check includes a call to& that requires a "
2692 & "predicate check??", Parent
(N
), Fun
);
2694 ("\this will result in infinite recursion??", Parent
(N
));
2696 if Is_First_Subtype
(Typ
) then
2698 ("\use an explicit subtype of& to carry the predicate",
2703 Make_Raise_Storage_Error
(Sloc
(N
),
2704 Reason
=> SE_Infinite_Recursion
));
2706 -- Here for normal case of predicate active
2709 -- If the type has a static predicate and the expression is known
2710 -- at compile time, see if the expression satisfies the predicate.
2712 Check_Expression_Against_Static_Predicate
(N
, Typ
);
2714 if not Expander_Active
then
2718 -- For an entity of the type, generate a call to the predicate
2719 -- function, unless its type is an actual subtype, which is not
2720 -- visible outside of the enclosing subprogram.
2722 if Is_Entity_Name
(N
)
2723 and then not Is_Actual_Subtype
(Typ
)
2726 Make_Predicate_Check
2727 (Typ
, New_Occurrence_Of
(Entity
(N
), Sloc
(N
))));
2729 -- If the expression is not an entity it may have side effects,
2730 -- and the following call will create an object declaration for
2731 -- it. We disable checks during its analysis, to prevent an
2732 -- infinite recursion.
2734 -- If the prefix is an aggregate in an assignment, apply the
2735 -- check to the LHS after assignment, rather than create a
2736 -- redundant temporary. This is only necessary in rare cases
2737 -- of array types (including strings) initialized with an
2738 -- aggregate with an "others" clause, either coming from source
2739 -- or generated by an Initialize_Scalars pragma.
2741 elsif Nkind
(N
) = N_Aggregate
2742 and then Nkind
(Parent
(N
)) = N_Assignment_Statement
2744 Insert_Action_After
(Parent
(N
),
2745 Make_Predicate_Check
2746 (Typ
, Duplicate_Subexpr
(Name
(Parent
(N
)))));
2750 Make_Predicate_Check
2751 (Typ
, Duplicate_Subexpr
(N
)), Suppress
=> All_Checks
);
2755 end Apply_Predicate_Check
;
2757 -----------------------
2758 -- Apply_Range_Check --
2759 -----------------------
2761 procedure Apply_Range_Check
2763 Target_Typ
: Entity_Id
;
2764 Source_Typ
: Entity_Id
:= Empty
)
2767 Apply_Selected_Range_Checks
2768 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2769 end Apply_Range_Check
;
2771 ------------------------------
2772 -- Apply_Scalar_Range_Check --
2773 ------------------------------
2775 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
2776 -- off if it is already set on.
2778 procedure Apply_Scalar_Range_Check
2780 Target_Typ
: Entity_Id
;
2781 Source_Typ
: Entity_Id
:= Empty
;
2782 Fixed_Int
: Boolean := False)
2784 Parnt
: constant Node_Id
:= Parent
(Expr
);
2786 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
2787 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
2789 Is_Subscr_Ref
: Boolean;
2790 -- Set true if Expr is a subscript
2792 Is_Unconstrained_Subscr_Ref
: Boolean;
2793 -- Set true if Expr is a subscript of an unconstrained array. In this
2794 -- case we do not attempt to do an analysis of the value against the
2795 -- range of the subscript, since we don't know the actual subtype.
2798 -- Set to True if Expr should be regarded as a real value even though
2799 -- the type of Expr might be discrete.
2801 procedure Bad_Value
(Warn
: Boolean := False);
2802 -- Procedure called if value is determined to be out of range. Warn is
2803 -- True to force a warning instead of an error, even when SPARK_Mode is
2810 procedure Bad_Value
(Warn
: Boolean := False) is
2812 Apply_Compile_Time_Constraint_Error
2813 (Expr
, "value not in range of}??", CE_Range_Check_Failed
,
2819 -- Start of processing for Apply_Scalar_Range_Check
2822 -- Return if check obviously not needed
2825 -- Not needed inside generic
2829 -- Not needed if previous error
2831 or else Target_Typ
= Any_Type
2832 or else Nkind
(Expr
) = N_Error
2834 -- Not needed for non-scalar type
2836 or else not Is_Scalar_Type
(Target_Typ
)
2838 -- Not needed if we know node raises CE already
2840 or else Raises_Constraint_Error
(Expr
)
2845 -- Now, see if checks are suppressed
2848 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
2850 if Is_Subscr_Ref
then
2851 Arr
:= Prefix
(Parnt
);
2852 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
2854 if Is_Access_Type
(Arr_Typ
) then
2855 Arr_Typ
:= Designated_Type
(Arr_Typ
);
2859 if not Do_Range_Check
(Expr
) then
2861 -- Subscript reference. Check for Index_Checks suppressed
2863 if Is_Subscr_Ref
then
2865 -- Check array type and its base type
2867 if Index_Checks_Suppressed
(Arr_Typ
)
2868 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
2872 -- Check array itself if it is an entity name
2874 elsif Is_Entity_Name
(Arr
)
2875 and then Index_Checks_Suppressed
(Entity
(Arr
))
2879 -- Check expression itself if it is an entity name
2881 elsif Is_Entity_Name
(Expr
)
2882 and then Index_Checks_Suppressed
(Entity
(Expr
))
2887 -- All other cases, check for Range_Checks suppressed
2890 -- Check target type and its base type
2892 if Range_Checks_Suppressed
(Target_Typ
)
2893 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
2897 -- Check expression itself if it is an entity name
2899 elsif Is_Entity_Name
(Expr
)
2900 and then Range_Checks_Suppressed
(Entity
(Expr
))
2904 -- If Expr is part of an assignment statement, then check left
2905 -- side of assignment if it is an entity name.
2907 elsif Nkind
(Parnt
) = N_Assignment_Statement
2908 and then Is_Entity_Name
(Name
(Parnt
))
2909 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
2916 -- Do not set range checks if they are killed
2918 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
2919 and then Kill_Range_Check
(Expr
)
2924 -- Do not set range checks for any values from System.Scalar_Values
2925 -- since the whole idea of such values is to avoid checking them.
2927 if Is_Entity_Name
(Expr
)
2928 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
2933 -- Now see if we need a check
2935 if No
(Source_Typ
) then
2936 S_Typ
:= Etype
(Expr
);
2938 S_Typ
:= Source_Typ
;
2941 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
2945 Is_Unconstrained_Subscr_Ref
:=
2946 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
2948 -- Special checks for floating-point type
2950 if Is_Floating_Point_Type
(S_Typ
) then
2952 -- Always do a range check if the source type includes infinities and
2953 -- the target type does not include infinities. We do not do this if
2954 -- range checks are killed.
2955 -- If the expression is a literal and the bounds of the type are
2956 -- static constants it may be possible to optimize the check.
2958 if Has_Infinities
(S_Typ
)
2959 and then not Has_Infinities
(Target_Typ
)
2961 -- If the expression is a literal and the bounds of the type are
2962 -- static constants it may be possible to optimize the check.
2964 if Nkind
(Expr
) = N_Real_Literal
then
2966 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
2967 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
2970 if Compile_Time_Known_Value
(Tlo
)
2971 and then Compile_Time_Known_Value
(Thi
)
2972 and then Expr_Value_R
(Expr
) >= Expr_Value_R
(Tlo
)
2973 and then Expr_Value_R
(Expr
) <= Expr_Value_R
(Thi
)
2977 Enable_Range_Check
(Expr
);
2982 Enable_Range_Check
(Expr
);
2987 -- Return if we know expression is definitely in the range of the target
2988 -- type as determined by Determine_Range. Right now we only do this for
2989 -- discrete types, and not fixed-point or floating-point types.
2991 -- The additional less-precise tests below catch these cases
2993 -- In GNATprove_Mode, also deal with the case of a conversion from
2994 -- floating-point to integer. It is only possible because analysis
2995 -- in GNATprove rules out the possibility of a NaN or infinite value.
2997 -- Note: skip this if we are given a source_typ, since the point of
2998 -- supplying a Source_Typ is to stop us looking at the expression.
2999 -- We could sharpen this test to be out parameters only ???
3001 if Is_Discrete_Type
(Target_Typ
)
3002 and then (Is_Discrete_Type
(Etype
(Expr
))
3003 or else (GNATprove_Mode
3004 and then Is_Floating_Point_Type
(Etype
(Expr
))))
3005 and then not Is_Unconstrained_Subscr_Ref
3006 and then No
(Source_Typ
)
3009 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
3010 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
3013 if Compile_Time_Known_Value
(Tlo
)
3014 and then Compile_Time_Known_Value
(Thi
)
3017 OK
: Boolean := False; -- initialize to prevent warning
3018 Hiv
: constant Uint
:= Expr_Value
(Thi
);
3019 Lov
: constant Uint
:= Expr_Value
(Tlo
);
3020 Hi
: Uint
:= No_Uint
;
3021 Lo
: Uint
:= No_Uint
;
3024 -- If range is null, we for sure have a constraint error (we
3025 -- don't even need to look at the value involved, since all
3026 -- possible values will raise CE).
3030 -- When SPARK_Mode is On, force a warning instead of
3031 -- an error in that case, as this likely corresponds
3032 -- to deactivated code.
3034 Bad_Value
(Warn
=> SPARK_Mode
= On
);
3036 -- In GNATprove mode, we enable the range check so that
3037 -- GNATprove will issue a message if it cannot be proved.
3039 if GNATprove_Mode
then
3040 Enable_Range_Check
(Expr
);
3046 -- Otherwise determine range of value
3048 if Is_Discrete_Type
(Etype
(Expr
)) then
3050 (Expr
, OK
, Lo
, Hi
, Assume_Valid
=> True);
3052 -- When converting a float to an integer type, determine the
3053 -- range in real first, and then convert the bounds using
3054 -- UR_To_Uint which correctly rounds away from zero when
3055 -- half way between two integers, as required by normal
3056 -- Ada 95 rounding semantics. It is only possible because
3057 -- analysis in GNATprove rules out the possibility of a NaN
3058 -- or infinite value.
3060 elsif GNATprove_Mode
3061 and then Is_Floating_Point_Type
(Etype
(Expr
))
3069 (Expr
, OK
, Lor
, Hir
, Assume_Valid
=> True);
3072 Lo
:= UR_To_Uint
(Lor
);
3073 Hi
:= UR_To_Uint
(Hir
);
3080 -- If definitely in range, all OK
3082 if Lo
>= Lov
and then Hi
<= Hiv
then
3085 -- If definitely not in range, warn
3087 elsif Lov
> Hi
or else Hiv
< Lo
then
3089 -- Ignore out of range values for System.Priority in
3090 -- CodePeer mode since the actual target compiler may
3091 -- provide a wider range.
3093 if not CodePeer_Mode
3094 or else Target_Typ
/= RTE
(RE_Priority
)
3101 -- Otherwise we don't know
3113 Is_Floating_Point_Type
(S_Typ
)
3114 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
3116 -- Check if we can determine at compile time whether Expr is in the
3117 -- range of the target type. Note that if S_Typ is within the bounds
3118 -- of Target_Typ then this must be the case. This check is meaningful
3119 -- only if this is not a conversion between integer and real types.
3121 if not Is_Unconstrained_Subscr_Ref
3122 and then Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
3124 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
3126 -- Also check if the expression itself is in the range of the
3127 -- target type if it is a known at compile time value. We skip
3128 -- this test if S_Typ is set since for OUT and IN OUT parameters
3129 -- the Expr itself is not relevant to the checking.
3133 and then Is_In_Range
(Expr
, Target_Typ
,
3134 Assume_Valid
=> True,
3135 Fixed_Int
=> Fixed_Int
,
3136 Int_Real
=> Int_Real
)))
3140 elsif Is_Out_Of_Range
(Expr
, Target_Typ
,
3141 Assume_Valid
=> True,
3142 Fixed_Int
=> Fixed_Int
,
3143 Int_Real
=> Int_Real
)
3148 -- Floating-point case
3149 -- In the floating-point case, we only do range checks if the type is
3150 -- constrained. We definitely do NOT want range checks for unconstrained
3151 -- types, since we want to have infinities, except when
3152 -- Check_Float_Overflow is set.
3154 elsif Is_Floating_Point_Type
(S_Typ
) then
3155 if Is_Constrained
(S_Typ
) or else Check_Float_Overflow
then
3156 Enable_Range_Check
(Expr
);
3159 -- For all other cases we enable a range check unconditionally
3162 Enable_Range_Check
(Expr
);
3165 end Apply_Scalar_Range_Check
;
3167 ----------------------------------
3168 -- Apply_Selected_Length_Checks --
3169 ----------------------------------
3171 procedure Apply_Selected_Length_Checks
3173 Target_Typ
: Entity_Id
;
3174 Source_Typ
: Entity_Id
;
3175 Do_Static
: Boolean)
3177 Checks_On
: constant Boolean :=
3178 not Index_Checks_Suppressed
(Target_Typ
)
3180 not Length_Checks_Suppressed
(Target_Typ
);
3182 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
3186 R_Result
: Check_Result
;
3189 -- Only apply checks when generating code
3191 -- Note: this means that we lose some useful warnings if the expander
3194 if not Expander_Active
then
3199 Selected_Length_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
3201 for J
in 1 .. 2 loop
3202 R_Cno
:= R_Result
(J
);
3203 exit when No
(R_Cno
);
3205 -- A length check may mention an Itype which is attached to a
3206 -- subsequent node. At the top level in a package this can cause
3207 -- an order-of-elaboration problem, so we make sure that the itype
3208 -- is referenced now.
3210 if Ekind
(Current_Scope
) = E_Package
3211 and then Is_Compilation_Unit
(Current_Scope
)
3213 Ensure_Defined
(Target_Typ
, Ck_Node
);
3215 if Present
(Source_Typ
) then
3216 Ensure_Defined
(Source_Typ
, Ck_Node
);
3218 elsif Is_Itype
(Etype
(Ck_Node
)) then
3219 Ensure_Defined
(Etype
(Ck_Node
), Ck_Node
);
3223 -- If the item is a conditional raise of constraint error, then have
3224 -- a look at what check is being performed and ???
3226 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
3227 and then Present
(Condition
(R_Cno
))
3229 Cond
:= Condition
(R_Cno
);
3231 -- Case where node does not now have a dynamic check
3233 if not Has_Dynamic_Length_Check
(Ck_Node
) then
3235 -- If checks are on, just insert the check
3238 Insert_Action
(Ck_Node
, R_Cno
);
3240 if not Do_Static
then
3241 Set_Has_Dynamic_Length_Check
(Ck_Node
);
3244 -- If checks are off, then analyze the length check after
3245 -- temporarily attaching it to the tree in case the relevant
3246 -- condition can be evaluated at compile time. We still want a
3247 -- compile time warning in this case.
3250 Set_Parent
(R_Cno
, Ck_Node
);
3255 -- Output a warning if the condition is known to be True
3257 if Is_Entity_Name
(Cond
)
3258 and then Entity
(Cond
) = Standard_True
3260 Apply_Compile_Time_Constraint_Error
3261 (Ck_Node
, "wrong length for array of}??",
3262 CE_Length_Check_Failed
,
3266 -- If we were only doing a static check, or if checks are not
3267 -- on, then we want to delete the check, since it is not needed.
3268 -- We do this by replacing the if statement by a null statement
3270 elsif Do_Static
or else not Checks_On
then
3271 Remove_Warning_Messages
(R_Cno
);
3272 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3276 Install_Static_Check
(R_Cno
, Loc
);
3279 end Apply_Selected_Length_Checks
;
3281 ---------------------------------
3282 -- Apply_Selected_Range_Checks --
3283 ---------------------------------
3285 procedure Apply_Selected_Range_Checks
3287 Target_Typ
: Entity_Id
;
3288 Source_Typ
: Entity_Id
;
3289 Do_Static
: Boolean)
3291 Checks_On
: constant Boolean :=
3292 not Index_Checks_Suppressed
(Target_Typ
)
3294 not Range_Checks_Suppressed
(Target_Typ
);
3296 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
3300 R_Result
: Check_Result
;
3303 -- Only apply checks when generating code. In GNATprove mode, we do not
3304 -- apply the checks, but we still call Selected_Range_Checks to possibly
3305 -- issue errors on SPARK code when a run-time error can be detected at
3308 if not GNATprove_Mode
then
3309 if not Expander_Active
or not Checks_On
then
3315 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
3317 if GNATprove_Mode
then
3321 for J
in 1 .. 2 loop
3322 R_Cno
:= R_Result
(J
);
3323 exit when No
(R_Cno
);
3325 -- The range check requires runtime evaluation. Depending on what its
3326 -- triggering condition is, the check may be converted into a compile
3327 -- time constraint check.
3329 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
3330 and then Present
(Condition
(R_Cno
))
3332 Cond
:= Condition
(R_Cno
);
3334 -- Insert the range check before the related context. Note that
3335 -- this action analyses the triggering condition.
3337 Insert_Action
(Ck_Node
, R_Cno
);
3339 -- This old code doesn't make sense, why is the context flagged as
3340 -- requiring dynamic range checks now in the middle of generating
3343 if not Do_Static
then
3344 Set_Has_Dynamic_Range_Check
(Ck_Node
);
3347 -- The triggering condition evaluates to True, the range check
3348 -- can be converted into a compile time constraint check.
3350 if Is_Entity_Name
(Cond
)
3351 and then Entity
(Cond
) = Standard_True
3353 -- Since an N_Range is technically not an expression, we have
3354 -- to set one of the bounds to C_E and then just flag the
3355 -- N_Range. The warning message will point to the lower bound
3356 -- and complain about a range, which seems OK.
3358 if Nkind
(Ck_Node
) = N_Range
then
3359 Apply_Compile_Time_Constraint_Error
3360 (Low_Bound
(Ck_Node
),
3361 "static range out of bounds of}??",
3362 CE_Range_Check_Failed
,
3366 Set_Raises_Constraint_Error
(Ck_Node
);
3369 Apply_Compile_Time_Constraint_Error
3371 "static value out of range of}??",
3372 CE_Range_Check_Failed
,
3377 -- If we were only doing a static check, or if checks are not
3378 -- on, then we want to delete the check, since it is not needed.
3379 -- We do this by replacing the if statement by a null statement
3381 elsif Do_Static
then
3382 Remove_Warning_Messages
(R_Cno
);
3383 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3386 -- The range check raises Constraint_Error explicitly
3389 Install_Static_Check
(R_Cno
, Loc
);
3392 end Apply_Selected_Range_Checks
;
3394 -------------------------------
3395 -- Apply_Static_Length_Check --
3396 -------------------------------
3398 procedure Apply_Static_Length_Check
3400 Target_Typ
: Entity_Id
;
3401 Source_Typ
: Entity_Id
:= Empty
)
3404 Apply_Selected_Length_Checks
3405 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
3406 end Apply_Static_Length_Check
;
3408 -------------------------------------
3409 -- Apply_Subscript_Validity_Checks --
3410 -------------------------------------
3412 procedure Apply_Subscript_Validity_Checks
(Expr
: Node_Id
) is
3416 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
3418 -- Loop through subscripts
3420 Sub
:= First
(Expressions
(Expr
));
3421 while Present
(Sub
) loop
3423 -- Check one subscript. Note that we do not worry about enumeration
3424 -- type with holes, since we will convert the value to a Pos value
3425 -- for the subscript, and that convert will do the necessary validity
3428 Ensure_Valid
(Sub
, Holes_OK
=> True);
3430 -- Move to next subscript
3434 end Apply_Subscript_Validity_Checks
;
3436 ----------------------------------
3437 -- Apply_Type_Conversion_Checks --
3438 ----------------------------------
3440 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
3441 Target_Type
: constant Entity_Id
:= Etype
(N
);
3442 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
3443 Expr
: constant Node_Id
:= Expression
(N
);
3445 Expr_Type
: constant Entity_Id
:= Underlying_Type
(Etype
(Expr
));
3446 -- Note: if Etype (Expr) is a private type without discriminants, its
3447 -- full view might have discriminants with defaults, so we need the
3448 -- full view here to retrieve the constraints.
3451 if Inside_A_Generic
then
3454 -- Skip these checks if serious errors detected, there are some nasty
3455 -- situations of incomplete trees that blow things up.
3457 elsif Serious_Errors_Detected
> 0 then
3460 -- Never generate discriminant checks for Unchecked_Union types
3462 elsif Present
(Expr_Type
)
3463 and then Is_Unchecked_Union
(Expr_Type
)
3467 -- Scalar type conversions of the form Target_Type (Expr) require a
3468 -- range check if we cannot be sure that Expr is in the base type of
3469 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3470 -- are not quite the same condition from an implementation point of
3471 -- view, but clearly the second includes the first.
3473 elsif Is_Scalar_Type
(Target_Type
) then
3475 Conv_OK
: constant Boolean := Conversion_OK
(N
);
3476 -- If the Conversion_OK flag on the type conversion is set and no
3477 -- floating-point type is involved in the type conversion then
3478 -- fixed-point values must be read as integral values.
3480 Float_To_Int
: constant Boolean :=
3481 Is_Floating_Point_Type
(Expr_Type
)
3482 and then Is_Integer_Type
(Target_Type
);
3485 if not Overflow_Checks_Suppressed
(Target_Base
)
3486 and then not Overflow_Checks_Suppressed
(Target_Type
)
3488 In_Subrange_Of
(Expr_Type
, Target_Base
, Fixed_Int
=> Conv_OK
)
3489 and then not Float_To_Int
3491 -- A small optimization: the attribute 'Pos applied to an
3492 -- enumeration type has a known range, even though its type is
3493 -- Universal_Integer. So in numeric conversions it is usually
3494 -- within range of the target integer type. Use the static
3495 -- bounds of the base types to check. Disable this optimization
3496 -- in case of a generic formal discrete type, because we don't
3497 -- necessarily know the upper bound yet.
3499 if Nkind
(Expr
) = N_Attribute_Reference
3500 and then Attribute_Name
(Expr
) = Name_Pos
3501 and then Is_Enumeration_Type
(Etype
(Prefix
(Expr
)))
3502 and then not Is_Generic_Type
(Etype
(Prefix
(Expr
)))
3503 and then Is_Integer_Type
(Target_Type
)
3506 Enum_T
: constant Entity_Id
:=
3507 Root_Type
(Etype
(Prefix
(Expr
)));
3508 Int_T
: constant Entity_Id
:= Base_Type
(Target_Type
);
3509 Last_I
: constant Uint
:=
3510 Intval
(High_Bound
(Scalar_Range
(Int_T
)));
3514 -- Character types have no explicit literals, so we use
3515 -- the known number of characters in the type.
3517 if Root_Type
(Enum_T
) = Standard_Character
then
3518 Last_E
:= UI_From_Int
(255);
3520 elsif Enum_T
= Standard_Wide_Character
3521 or else Enum_T
= Standard_Wide_Wide_Character
3523 Last_E
:= UI_From_Int
(65535);
3528 (Entity
(High_Bound
(Scalar_Range
(Enum_T
))));
3531 if Last_E
<= Last_I
then
3535 Activate_Overflow_Check
(N
);
3540 Activate_Overflow_Check
(N
);
3544 if not Range_Checks_Suppressed
(Target_Type
)
3545 and then not Range_Checks_Suppressed
(Expr_Type
)
3548 and then not GNATprove_Mode
3550 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
3553 -- Conversions involving fixed-point types are expanded
3554 -- separately, and do not need a Range_Check flag, except
3555 -- in GNATprove_Mode, where the explicit constraint check
3556 -- will not be generated.
3559 or else not Is_Fixed_Point_Type
(Expr_Type
)
3561 Apply_Scalar_Range_Check
3562 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
3565 Set_Do_Range_Check
(Expression
(N
), False);
3568 -- If the target type has predicates, we need to indicate
3569 -- the need for a check, even if Determine_Range finds that
3570 -- the value is within bounds. This may be the case e.g for
3571 -- a division with a constant denominator.
3573 if Has_Predicates
(Target_Type
) then
3574 Enable_Range_Check
(Expr
);
3580 elsif Comes_From_Source
(N
)
3581 and then not Discriminant_Checks_Suppressed
(Target_Type
)
3582 and then Is_Record_Type
(Target_Type
)
3583 and then Is_Derived_Type
(Target_Type
)
3584 and then not Is_Tagged_Type
(Target_Type
)
3585 and then not Is_Constrained
(Target_Type
)
3586 and then Present
(Stored_Constraint
(Target_Type
))
3588 -- An unconstrained derived type may have inherited discriminant.
3589 -- Build an actual discriminant constraint list using the stored
3590 -- constraint, to verify that the expression of the parent type
3591 -- satisfies the constraints imposed by the (unconstrained) derived
3592 -- type. This applies to value conversions, not to view conversions
3596 Loc
: constant Source_Ptr
:= Sloc
(N
);
3598 Constraint
: Elmt_Id
;
3599 Discr_Value
: Node_Id
;
3602 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
3603 Old_Constraints
: constant Elist_Id
:=
3604 Discriminant_Constraint
(Expr_Type
);
3607 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
3608 while Present
(Constraint
) loop
3609 Discr_Value
:= Node
(Constraint
);
3611 if Is_Entity_Name
(Discr_Value
)
3612 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
3614 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
3617 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
3619 -- Parent is constrained by new discriminant. Obtain
3620 -- Value of original discriminant in expression. If the
3621 -- new discriminant has been used to constrain more than
3622 -- one of the stored discriminants, this will provide the
3623 -- required consistency check.
3626 (Make_Selected_Component
(Loc
,
3628 Duplicate_Subexpr_No_Checks
3629 (Expr
, Name_Req
=> True),
3631 Make_Identifier
(Loc
, Chars
(Discr
))),
3635 -- Discriminant of more remote ancestor ???
3640 -- Derived type definition has an explicit value for this
3641 -- stored discriminant.
3645 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
3649 Next_Elmt
(Constraint
);
3652 -- Use the unconstrained expression type to retrieve the
3653 -- discriminants of the parent, and apply momentarily the
3654 -- discriminant constraint synthesized above.
3656 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
3657 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
3658 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
3661 Make_Raise_Constraint_Error
(Loc
,
3663 Reason
=> CE_Discriminant_Check_Failed
));
3666 -- For arrays, checks are set now, but conversions are applied during
3667 -- expansion, to take into accounts changes of representation. The
3668 -- checks become range checks on the base type or length checks on the
3669 -- subtype, depending on whether the target type is unconstrained or
3670 -- constrained. Note that the range check is put on the expression of a
3671 -- type conversion, while the length check is put on the type conversion
3674 elsif Is_Array_Type
(Target_Type
) then
3675 if Is_Constrained
(Target_Type
) then
3676 Set_Do_Length_Check
(N
);
3678 Set_Do_Range_Check
(Expr
);
3681 end Apply_Type_Conversion_Checks
;
3683 ----------------------------------------------
3684 -- Apply_Universal_Integer_Attribute_Checks --
3685 ----------------------------------------------
3687 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
3688 Loc
: constant Source_Ptr
:= Sloc
(N
);
3689 Typ
: constant Entity_Id
:= Etype
(N
);
3692 if Inside_A_Generic
then
3695 -- Nothing to do if checks are suppressed
3697 elsif Range_Checks_Suppressed
(Typ
)
3698 and then Overflow_Checks_Suppressed
(Typ
)
3702 -- Nothing to do if the attribute does not come from source. The
3703 -- internal attributes we generate of this type do not need checks,
3704 -- and furthermore the attempt to check them causes some circular
3705 -- elaboration orders when dealing with packed types.
3707 elsif not Comes_From_Source
(N
) then
3710 -- If the prefix is a selected component that depends on a discriminant
3711 -- the check may improperly expose a discriminant instead of using
3712 -- the bounds of the object itself. Set the type of the attribute to
3713 -- the base type of the context, so that a check will be imposed when
3714 -- needed (e.g. if the node appears as an index).
3716 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
3717 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
3718 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
3720 Set_Etype
(N
, Base_Type
(Typ
));
3722 -- Otherwise, replace the attribute node with a type conversion node
3723 -- whose expression is the attribute, retyped to universal integer, and
3724 -- whose subtype mark is the target type. The call to analyze this
3725 -- conversion will set range and overflow checks as required for proper
3726 -- detection of an out of range value.
3729 Set_Etype
(N
, Universal_Integer
);
3730 Set_Analyzed
(N
, True);
3733 Make_Type_Conversion
(Loc
,
3734 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
3735 Expression
=> Relocate_Node
(N
)));
3737 Analyze_And_Resolve
(N
, Typ
);
3740 end Apply_Universal_Integer_Attribute_Checks
;
3742 -------------------------------------
3743 -- Atomic_Synchronization_Disabled --
3744 -------------------------------------
3746 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3747 -- using a bogus check called Atomic_Synchronization. This is to make it
3748 -- more convenient to get exactly the same semantics as [Un]Suppress.
3750 function Atomic_Synchronization_Disabled
(E
: Entity_Id
) return Boolean is
3752 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3753 -- looks enabled, since it is never disabled.
3755 if Debug_Flag_Dot_E
then
3758 -- If debug flag d.d is set then always return True, i.e. all atomic
3759 -- sync looks disabled, since it always tests True.
3761 elsif Debug_Flag_Dot_D
then
3764 -- If entity present, then check result for that entity
3766 elsif Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3767 return Is_Check_Suppressed
(E
, Atomic_Synchronization
);
3769 -- Otherwise result depends on current scope setting
3772 return Scope_Suppress
.Suppress
(Atomic_Synchronization
);
3774 end Atomic_Synchronization_Disabled
;
3776 -------------------------------
3777 -- Build_Discriminant_Checks --
3778 -------------------------------
3780 function Build_Discriminant_Checks
3782 T_Typ
: Entity_Id
) return Node_Id
3784 Loc
: constant Source_Ptr
:= Sloc
(N
);
3787 Disc_Ent
: Entity_Id
;
3791 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
;
3793 --------------------------------
3794 -- Aggregate_Discriminant_Val --
3795 --------------------------------
3797 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
is
3801 -- The aggregate has been normalized with named associations. We use
3802 -- the Chars field to locate the discriminant to take into account
3803 -- discriminants in derived types, which carry the same name as those
3806 Assoc
:= First
(Component_Associations
(N
));
3807 while Present
(Assoc
) loop
3808 if Chars
(First
(Choices
(Assoc
))) = Chars
(Disc
) then
3809 return Expression
(Assoc
);
3815 -- Discriminant must have been found in the loop above
3817 raise Program_Error
;
3818 end Aggregate_Discriminant_Val
;
3820 -- Start of processing for Build_Discriminant_Checks
3823 -- Loop through discriminants evolving the condition
3826 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
3828 -- For a fully private type, use the discriminants of the parent type
3830 if Is_Private_Type
(T_Typ
)
3831 and then No
(Full_View
(T_Typ
))
3833 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
3835 Disc_Ent
:= First_Discriminant
(T_Typ
);
3838 while Present
(Disc
) loop
3839 Dval
:= Node
(Disc
);
3841 if Nkind
(Dval
) = N_Identifier
3842 and then Ekind
(Entity
(Dval
)) = E_Discriminant
3844 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
3846 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
3849 -- If we have an Unchecked_Union node, we can infer the discriminants
3852 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
3854 Get_Discriminant_Value
(
3855 First_Discriminant
(T_Typ
),
3857 Stored_Constraint
(T_Typ
)));
3859 elsif Nkind
(N
) = N_Aggregate
then
3861 Duplicate_Subexpr_No_Checks
3862 (Aggregate_Discriminant_Val
(Disc_Ent
));
3866 Make_Selected_Component
(Loc
,
3868 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
3869 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
3871 Set_Is_In_Discriminant_Check
(Dref
);
3874 Evolve_Or_Else
(Cond
,
3877 Right_Opnd
=> Dval
));
3880 Next_Discriminant
(Disc_Ent
);
3884 end Build_Discriminant_Checks
;
3890 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
3897 function Left_Expression
(Op
: Node_Id
) return Node_Id
;
3898 -- Return the relevant expression from the left operand of the given
3899 -- short circuit form: this is LO itself, except if LO is a qualified
3900 -- expression, a type conversion, or an expression with actions, in
3901 -- which case this is Left_Expression (Expression (LO)).
3903 ---------------------
3904 -- Left_Expression --
3905 ---------------------
3907 function Left_Expression
(Op
: Node_Id
) return Node_Id
is
3908 LE
: Node_Id
:= Left_Opnd
(Op
);
3910 while Nkind_In
(LE
, N_Qualified_Expression
,
3912 N_Expression_With_Actions
)
3914 LE
:= Expression
(LE
);
3918 end Left_Expression
;
3920 -- Start of processing for Check_Needed
3923 -- Always check if not simple entity
3925 if Nkind
(Nod
) not in N_Has_Entity
3926 or else not Comes_From_Source
(Nod
)
3931 -- Look up tree for short circuit
3938 -- Done if out of subexpression (note that we allow generated stuff
3939 -- such as itype declarations in this context, to keep the loop going
3940 -- since we may well have generated such stuff in complex situations.
3941 -- Also done if no parent (probably an error condition, but no point
3942 -- in behaving nasty if we find it).
3945 or else (K
not in N_Subexpr
and then Comes_From_Source
(P
))
3949 -- Or/Or Else case, where test is part of the right operand, or is
3950 -- part of one of the actions associated with the right operand, and
3951 -- the left operand is an equality test.
3953 elsif K
= N_Op_Or
then
3954 exit when N
= Right_Opnd
(P
)
3955 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
3957 elsif K
= N_Or_Else
then
3958 exit when (N
= Right_Opnd
(P
)
3961 and then List_Containing
(N
) = Actions
(P
)))
3962 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
3964 -- Similar test for the And/And then case, where the left operand
3965 -- is an inequality test.
3967 elsif K
= N_Op_And
then
3968 exit when N
= Right_Opnd
(P
)
3969 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
3971 elsif K
= N_And_Then
then
3972 exit when (N
= Right_Opnd
(P
)
3975 and then List_Containing
(N
) = Actions
(P
)))
3976 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
3982 -- If we fall through the loop, then we have a conditional with an
3983 -- appropriate test as its left operand, so look further.
3985 L
:= Left_Expression
(P
);
3987 -- L is an "=" or "/=" operator: extract its operands
3989 R
:= Right_Opnd
(L
);
3992 -- Left operand of test must match original variable
3994 if Nkind
(L
) not in N_Has_Entity
or else Entity
(L
) /= Entity
(Nod
) then
3998 -- Right operand of test must be key value (zero or null)
4001 when Access_Check
=>
4002 if not Known_Null
(R
) then
4006 when Division_Check
=>
4007 if not Compile_Time_Known_Value
(R
)
4008 or else Expr_Value
(R
) /= Uint_0
4014 raise Program_Error
;
4017 -- Here we have the optimizable case, warn if not short-circuited
4019 if K
= N_Op_And
or else K
= N_Op_Or
then
4020 Error_Msg_Warn
:= SPARK_Mode
/= On
;
4023 when Access_Check
=>
4024 if GNATprove_Mode
then
4026 ("Constraint_Error might have been raised (access check)",
4030 ("Constraint_Error may be raised (access check)??",
4034 when Division_Check
=>
4035 if GNATprove_Mode
then
4037 ("Constraint_Error might have been raised (zero divide)",
4041 ("Constraint_Error may be raised (zero divide)??",
4046 raise Program_Error
;
4049 if K
= N_Op_And
then
4050 Error_Msg_N
-- CODEFIX
4051 ("use `AND THEN` instead of AND??", P
);
4053 Error_Msg_N
-- CODEFIX
4054 ("use `OR ELSE` instead of OR??", P
);
4057 -- If not short-circuited, we need the check
4061 -- If short-circuited, we can omit the check
4068 -----------------------------------
4069 -- Check_Valid_Lvalue_Subscripts --
4070 -----------------------------------
4072 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
4074 -- Skip this if range checks are suppressed
4076 if Range_Checks_Suppressed
(Etype
(Expr
)) then
4079 -- Only do this check for expressions that come from source. We assume
4080 -- that expander generated assignments explicitly include any necessary
4081 -- checks. Note that this is not just an optimization, it avoids
4082 -- infinite recursions.
4084 elsif not Comes_From_Source
(Expr
) then
4087 -- For a selected component, check the prefix
4089 elsif Nkind
(Expr
) = N_Selected_Component
then
4090 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
4093 -- Case of indexed component
4095 elsif Nkind
(Expr
) = N_Indexed_Component
then
4096 Apply_Subscript_Validity_Checks
(Expr
);
4098 -- Prefix may itself be or contain an indexed component, and these
4099 -- subscripts need checking as well.
4101 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
4103 end Check_Valid_Lvalue_Subscripts
;
4105 ----------------------------------
4106 -- Null_Exclusion_Static_Checks --
4107 ----------------------------------
4109 procedure Null_Exclusion_Static_Checks
4111 Comp
: Node_Id
:= Empty
;
4112 Array_Comp
: Boolean := False)
4114 Has_Null
: constant Boolean := Has_Null_Exclusion
(N
);
4115 Kind
: constant Node_Kind
:= Nkind
(N
);
4116 Error_Nod
: Node_Id
;
4122 (Nkind_In
(Kind
, N_Component_Declaration
,
4123 N_Discriminant_Specification
,
4124 N_Function_Specification
,
4125 N_Object_Declaration
,
4126 N_Parameter_Specification
));
4128 if Kind
= N_Function_Specification
then
4129 Typ
:= Etype
(Defining_Entity
(N
));
4131 Typ
:= Etype
(Defining_Identifier
(N
));
4135 when N_Component_Declaration
=>
4136 if Present
(Access_Definition
(Component_Definition
(N
))) then
4137 Error_Nod
:= Component_Definition
(N
);
4139 Error_Nod
:= Subtype_Indication
(Component_Definition
(N
));
4142 when N_Discriminant_Specification
=>
4143 Error_Nod
:= Discriminant_Type
(N
);
4145 when N_Function_Specification
=>
4146 Error_Nod
:= Result_Definition
(N
);
4148 when N_Object_Declaration
=>
4149 Error_Nod
:= Object_Definition
(N
);
4151 when N_Parameter_Specification
=>
4152 Error_Nod
:= Parameter_Type
(N
);
4155 raise Program_Error
;
4160 -- Enforce legality rule 3.10 (13): A null exclusion can only be
4161 -- applied to an access [sub]type.
4163 if not Is_Access_Type
(Typ
) then
4165 ("`NOT NULL` allowed only for an access type", Error_Nod
);
4167 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
4168 -- be applied to a [sub]type that does not exclude null already.
4170 elsif Can_Never_Be_Null
(Typ
) and then Comes_From_Source
(Typ
) then
4172 ("`NOT NULL` not allowed (& already excludes null)",
4177 -- Check that null-excluding objects are always initialized, except for
4178 -- deferred constants, for which the expression will appear in the full
4181 if Kind
= N_Object_Declaration
4182 and then No
(Expression
(N
))
4183 and then not Constant_Present
(N
)
4184 and then not No_Initialization
(N
)
4186 if Present
(Comp
) then
4188 -- Specialize the warning message to indicate that we are dealing
4189 -- with an uninitialized composite object that has a defaulted
4190 -- null-excluding component.
4192 Error_Msg_Name_1
:= Chars
(Defining_Identifier
(Comp
));
4193 Error_Msg_Name_2
:= Chars
(Defining_Identifier
(N
));
4196 (Compile_Time_Constraint_Error
4199 "(Ada 2005) null-excluding component % of object % must "
4200 & "be initialized??",
4201 Ent
=> Defining_Identifier
(Comp
)));
4203 -- This is a case of an array with null-excluding components, so
4204 -- indicate that in the warning.
4206 elsif Array_Comp
then
4208 (Compile_Time_Constraint_Error
4211 "(Ada 2005) null-excluding array components must "
4212 & "be initialized??",
4213 Ent
=> Defining_Identifier
(N
)));
4215 -- Normal case of object of a null-excluding access type
4218 -- Add an expression that assigns null. This node is needed by
4219 -- Apply_Compile_Time_Constraint_Error, which will replace this
4220 -- with a Constraint_Error node.
4222 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
4223 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
4225 Apply_Compile_Time_Constraint_Error
4226 (N
=> Expression
(N
),
4228 "(Ada 2005) null-excluding objects must be initialized??",
4229 Reason
=> CE_Null_Not_Allowed
);
4233 -- Check that a null-excluding component, formal or object is not being
4234 -- assigned a null value. Otherwise generate a warning message and
4235 -- replace Expression (N) by an N_Constraint_Error node.
4237 if Kind
/= N_Function_Specification
then
4238 Expr
:= Expression
(N
);
4240 if Present
(Expr
) and then Known_Null
(Expr
) then
4242 when N_Component_Declaration
4243 | N_Discriminant_Specification
4245 Apply_Compile_Time_Constraint_Error
4248 "(Ada 2005) null not allowed in null-excluding "
4250 Reason
=> CE_Null_Not_Allowed
);
4252 when N_Object_Declaration
=>
4253 Apply_Compile_Time_Constraint_Error
4256 "(Ada 2005) null not allowed in null-excluding "
4258 Reason
=> CE_Null_Not_Allowed
);
4260 when N_Parameter_Specification
=>
4261 Apply_Compile_Time_Constraint_Error
4264 "(Ada 2005) null not allowed in null-excluding "
4266 Reason
=> CE_Null_Not_Allowed
);
4273 end Null_Exclusion_Static_Checks
;
4275 ----------------------------------
4276 -- Conditional_Statements_Begin --
4277 ----------------------------------
4279 procedure Conditional_Statements_Begin
is
4281 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
4283 -- If stack overflows, kill all checks, that way we know to simply reset
4284 -- the number of saved checks to zero on return. This should never occur
4287 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
4290 -- In the normal case, we just make a new stack entry saving the current
4291 -- number of saved checks for a later restore.
4294 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
4296 if Debug_Flag_CC
then
4297 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
4301 end Conditional_Statements_Begin
;
4303 --------------------------------
4304 -- Conditional_Statements_End --
4305 --------------------------------
4307 procedure Conditional_Statements_End
is
4309 pragma Assert
(Saved_Checks_TOS
> 0);
4311 -- If the saved checks stack overflowed, then we killed all checks, so
4312 -- setting the number of saved checks back to zero is correct. This
4313 -- should never occur in practice.
4315 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
4316 Num_Saved_Checks
:= 0;
4318 -- In the normal case, restore the number of saved checks from the top
4322 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
4324 if Debug_Flag_CC
then
4325 w
("Conditional_Statements_End: Num_Saved_Checks = ",
4330 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
4331 end Conditional_Statements_End
;
4333 -------------------------
4334 -- Convert_From_Bignum --
4335 -------------------------
4337 function Convert_From_Bignum
(N
: Node_Id
) return Node_Id
is
4338 Loc
: constant Source_Ptr
:= Sloc
(N
);
4341 pragma Assert
(Is_RTE
(Etype
(N
), RE_Bignum
));
4343 -- Construct call From Bignum
4346 Make_Function_Call
(Loc
,
4348 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
4349 Parameter_Associations
=> New_List
(Relocate_Node
(N
)));
4350 end Convert_From_Bignum
;
4352 -----------------------
4353 -- Convert_To_Bignum --
4354 -----------------------
4356 function Convert_To_Bignum
(N
: Node_Id
) return Node_Id
is
4357 Loc
: constant Source_Ptr
:= Sloc
(N
);
4360 -- Nothing to do if Bignum already except call Relocate_Node
4362 if Is_RTE
(Etype
(N
), RE_Bignum
) then
4363 return Relocate_Node
(N
);
4365 -- Otherwise construct call to To_Bignum, converting the operand to the
4366 -- required Long_Long_Integer form.
4369 pragma Assert
(Is_Signed_Integer_Type
(Etype
(N
)));
4371 Make_Function_Call
(Loc
,
4373 New_Occurrence_Of
(RTE
(RE_To_Bignum
), Loc
),
4374 Parameter_Associations
=> New_List
(
4375 Convert_To
(Standard_Long_Long_Integer
, Relocate_Node
(N
))));
4377 end Convert_To_Bignum
;
4379 ---------------------
4380 -- Determine_Range --
4381 ---------------------
4383 Cache_Size
: constant := 2 ** 10;
4384 type Cache_Index
is range 0 .. Cache_Size
- 1;
4385 -- Determine size of below cache (power of 2 is more efficient)
4387 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
4388 Determine_Range_Cache_V
: array (Cache_Index
) of Boolean;
4389 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
4390 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
4391 Determine_Range_Cache_Lo_R
: array (Cache_Index
) of Ureal
;
4392 Determine_Range_Cache_Hi_R
: array (Cache_Index
) of Ureal
;
4393 -- The above arrays are used to implement a small direct cache for
4394 -- Determine_Range and Determine_Range_R calls. Because of the way these
4395 -- subprograms recursively traces subexpressions, and because overflow
4396 -- checking calls the routine on the way up the tree, a quadratic behavior
4397 -- can otherwise be encountered in large expressions. The cache entry for
4398 -- node N is stored in the (N mod Cache_Size) entry, and can be validated
4399 -- by checking the actual node value stored there. The Range_Cache_V array
4400 -- records the setting of Assume_Valid for the cache entry.
4402 procedure Determine_Range
4407 Assume_Valid
: Boolean := False)
4409 Typ
: Entity_Id
:= Etype
(N
);
4410 -- Type to use, may get reset to base type for possibly invalid entity
4414 -- Lo and Hi bounds of left operand
4416 Lo_Right
: Uint
:= No_Uint
;
4417 Hi_Right
: Uint
:= No_Uint
;
4418 -- Lo and Hi bounds of right (or only) operand
4421 -- Temp variable used to hold a bound node
4424 -- High bound of base type of expression
4428 -- Refined values for low and high bounds, after tightening
4431 -- Used in lower level calls to indicate if call succeeded
4433 Cindex
: Cache_Index
;
4434 -- Used to search cache
4439 function OK_Operands
return Boolean;
4440 -- Used for binary operators. Determines the ranges of the left and
4441 -- right operands, and if they are both OK, returns True, and puts
4442 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4448 function OK_Operands
return Boolean is
4451 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
4458 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4462 -- Start of processing for Determine_Range
4465 -- Prevent junk warnings by initializing range variables
4472 -- For temporary constants internally generated to remove side effects
4473 -- we must use the corresponding expression to determine the range of
4474 -- the expression. But note that the expander can also generate
4475 -- constants in other cases, including deferred constants.
4477 if Is_Entity_Name
(N
)
4478 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
4479 and then Ekind
(Entity
(N
)) = E_Constant
4480 and then Is_Internal_Name
(Chars
(Entity
(N
)))
4482 if Present
(Expression
(Parent
(Entity
(N
)))) then
4484 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
4486 elsif Present
(Full_View
(Entity
(N
))) then
4488 (Expression
(Parent
(Full_View
(Entity
(N
)))),
4489 OK
, Lo
, Hi
, Assume_Valid
);
4497 -- If type is not defined, we can't determine its range
4501 -- We don't deal with anything except discrete types
4503 or else not Is_Discrete_Type
(Typ
)
4505 -- Don't deal with enumerated types with non-standard representation
4507 or else (Is_Enumeration_Type
(Typ
)
4508 and then Present
(Enum_Pos_To_Rep
(Base_Type
(Typ
))))
4510 -- Ignore type for which an error has been posted, since range in
4511 -- this case may well be a bogosity deriving from the error. Also
4512 -- ignore if error posted on the reference node.
4514 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
4520 -- For all other cases, we can determine the range
4524 -- If value is compile time known, then the possible range is the one
4525 -- value that we know this expression definitely has.
4527 if Compile_Time_Known_Value
(N
) then
4528 Lo
:= Expr_Value
(N
);
4533 -- Return if already in the cache
4535 Cindex
:= Cache_Index
(N
mod Cache_Size
);
4537 if Determine_Range_Cache_N
(Cindex
) = N
4539 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
4541 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
4542 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
4546 -- Otherwise, start by finding the bounds of the type of the expression,
4547 -- the value cannot be outside this range (if it is, then we have an
4548 -- overflow situation, which is a separate check, we are talking here
4549 -- only about the expression value).
4551 -- First a check, never try to find the bounds of a generic type, since
4552 -- these bounds are always junk values, and it is only valid to look at
4553 -- the bounds in an instance.
4555 if Is_Generic_Type
(Typ
) then
4560 -- First step, change to use base type unless we know the value is valid
4562 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
4563 or else Assume_No_Invalid_Values
4564 or else Assume_Valid
4566 -- If this is a known valid constant with a nonstatic value, it may
4567 -- have inherited a narrower subtype from its initial value; use this
4568 -- saved subtype (see sem_ch3.adb).
4570 if Is_Entity_Name
(N
)
4571 and then Ekind
(Entity
(N
)) = E_Constant
4572 and then Present
(Actual_Subtype
(Entity
(N
)))
4574 Typ
:= Actual_Subtype
(Entity
(N
));
4579 Typ
:= Underlying_Type
(Base_Type
(Typ
));
4582 -- Retrieve the base type. Handle the case where the base type is a
4583 -- private enumeration type.
4585 Btyp
:= Base_Type
(Typ
);
4587 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
4588 Btyp
:= Full_View
(Btyp
);
4591 -- We use the actual bound unless it is dynamic, in which case use the
4592 -- corresponding base type bound if possible. If we can't get a bound
4593 -- then we figure we can't determine the range (a peculiar case, that
4594 -- perhaps cannot happen, but there is no point in bombing in this
4595 -- optimization circuit.
4597 -- First the low bound
4599 Bound
:= Type_Low_Bound
(Typ
);
4601 if Compile_Time_Known_Value
(Bound
) then
4602 Lo
:= Expr_Value
(Bound
);
4604 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
4605 Lo
:= Expr_Value
(Type_Low_Bound
(Btyp
));
4612 -- Now the high bound
4614 Bound
:= Type_High_Bound
(Typ
);
4616 -- We need the high bound of the base type later on, and this should
4617 -- always be compile time known. Again, it is not clear that this
4618 -- can ever be false, but no point in bombing.
4620 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
4621 Hbound
:= Expr_Value
(Type_High_Bound
(Btyp
));
4629 -- If we have a static subtype, then that may have a tighter bound so
4630 -- use the upper bound of the subtype instead in this case.
4632 if Compile_Time_Known_Value
(Bound
) then
4633 Hi
:= Expr_Value
(Bound
);
4636 -- We may be able to refine this value in certain situations. If any
4637 -- refinement is possible, then Lor and Hir are set to possibly tighter
4638 -- bounds, and OK1 is set to True.
4642 -- For unary plus, result is limited by range of operand
4646 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4648 -- For unary minus, determine range of operand, and negate it
4652 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4659 -- For binary addition, get range of each operand and do the
4660 -- addition to get the result range.
4664 Lor
:= Lo_Left
+ Lo_Right
;
4665 Hir
:= Hi_Left
+ Hi_Right
;
4668 -- Division is tricky. The only case we consider is where the right
4669 -- operand is a positive constant, and in this case we simply divide
4670 -- the bounds of the left operand
4674 if Lo_Right
= Hi_Right
4675 and then Lo_Right
> 0
4677 Lor
:= Lo_Left
/ Lo_Right
;
4678 Hir
:= Hi_Left
/ Lo_Right
;
4684 -- For binary subtraction, get range of each operand and do the worst
4685 -- case subtraction to get the result range.
4687 when N_Op_Subtract
=>
4689 Lor
:= Lo_Left
- Hi_Right
;
4690 Hir
:= Hi_Left
- Lo_Right
;
4693 -- For MOD, if right operand is a positive constant, then result must
4694 -- be in the allowable range of mod results.
4698 if Lo_Right
= Hi_Right
4699 and then Lo_Right
/= 0
4701 if Lo_Right
> 0 then
4703 Hir
:= Lo_Right
- 1;
4705 else -- Lo_Right < 0
4706 Lor
:= Lo_Right
+ 1;
4715 -- For REM, if right operand is a positive constant, then result must
4716 -- be in the allowable range of mod results.
4720 if Lo_Right
= Hi_Right
and then Lo_Right
/= 0 then
4722 Dval
: constant Uint
:= (abs Lo_Right
) - 1;
4725 -- The sign of the result depends on the sign of the
4726 -- dividend (but not on the sign of the divisor, hence
4727 -- the abs operation above).
4747 -- Attribute reference cases
4749 when N_Attribute_Reference
=>
4750 case Attribute_Name
(N
) is
4752 -- For Pos/Val attributes, we can refine the range using the
4753 -- possible range of values of the attribute expression.
4759 (First
(Expressions
(N
)), OK1
, Lor
, Hir
, Assume_Valid
);
4761 -- For Length attribute, use the bounds of the corresponding
4762 -- index type to refine the range.
4766 Atyp
: Entity_Id
:= Etype
(Prefix
(N
));
4774 if Is_Access_Type
(Atyp
) then
4775 Atyp
:= Designated_Type
(Atyp
);
4778 -- For string literal, we know exact value
4780 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
4782 Lo
:= String_Literal_Length
(Atyp
);
4783 Hi
:= String_Literal_Length
(Atyp
);
4787 -- Otherwise check for expression given
4789 if No
(Expressions
(N
)) then
4793 UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
4796 Indx
:= First_Index
(Atyp
);
4797 for J
in 2 .. Inum
loop
4798 Indx
:= Next_Index
(Indx
);
4801 -- If the index type is a formal type or derived from
4802 -- one, the bounds are not static.
4804 if Is_Generic_Type
(Root_Type
(Etype
(Indx
))) then
4810 (Type_Low_Bound
(Etype
(Indx
)), OK1
, LL
, LU
,
4815 (Type_High_Bound
(Etype
(Indx
)), OK1
, UL
, UU
,
4820 -- The maximum value for Length is the biggest
4821 -- possible gap between the values of the bounds.
4822 -- But of course, this value cannot be negative.
4824 Hir
:= UI_Max
(Uint_0
, UU
- LL
+ 1);
4826 -- For constrained arrays, the minimum value for
4827 -- Length is taken from the actual value of the
4828 -- bounds, since the index will be exactly of this
4831 if Is_Constrained
(Atyp
) then
4832 Lor
:= UI_Max
(Uint_0
, UL
- LU
+ 1);
4834 -- For an unconstrained array, the minimum value
4835 -- for length is always zero.
4844 -- No special handling for other attributes
4845 -- Probably more opportunities exist here???
4852 when N_Type_Conversion
=>
4854 -- For type conversion from one discrete type to another, we can
4855 -- refine the range using the converted value.
4857 if Is_Discrete_Type
(Etype
(Expression
(N
))) then
4858 Determine_Range
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4860 -- When converting a float to an integer type, determine the range
4861 -- in real first, and then convert the bounds using UR_To_Uint
4862 -- which correctly rounds away from zero when half way between two
4863 -- integers, as required by normal Ada 95 rounding semantics. It
4864 -- is only possible because analysis in GNATprove rules out the
4865 -- possibility of a NaN or infinite value.
4867 elsif GNATprove_Mode
4868 and then Is_Floating_Point_Type
(Etype
(Expression
(N
)))
4871 Lor_Real
, Hir_Real
: Ureal
;
4873 Determine_Range_R
(Expression
(N
), OK1
, Lor_Real
, Hir_Real
,
4877 Lor
:= UR_To_Uint
(Lor_Real
);
4878 Hir
:= UR_To_Uint
(Hir_Real
);
4886 -- Nothing special to do for all other expression kinds
4894 -- At this stage, if OK1 is true, then we know that the actual result of
4895 -- the computed expression is in the range Lor .. Hir. We can use this
4896 -- to restrict the possible range of results.
4900 -- If the refined value of the low bound is greater than the type
4901 -- low bound, then reset it to the more restrictive value. However,
4902 -- we do NOT do this for the case of a modular type where the
4903 -- possible upper bound on the value is above the base type high
4904 -- bound, because that means the result could wrap.
4907 and then not (Is_Modular_Integer_Type
(Typ
) and then Hir
> Hbound
)
4912 -- Similarly, if the refined value of the high bound is less than the
4913 -- value so far, then reset it to the more restrictive value. Again,
4914 -- we do not do this if the refined low bound is negative for a
4915 -- modular type, since this would wrap.
4918 and then not (Is_Modular_Integer_Type
(Typ
) and then Lor
< Uint_0
)
4924 -- Set cache entry for future call and we are all done
4926 Determine_Range_Cache_N
(Cindex
) := N
;
4927 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
4928 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
4929 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
4932 -- If any exception occurs, it means that we have some bug in the compiler,
4933 -- possibly triggered by a previous error, or by some unforeseen peculiar
4934 -- occurrence. However, this is only an optimization attempt, so there is
4935 -- really no point in crashing the compiler. Instead we just decide, too
4936 -- bad, we can't figure out a range in this case after all.
4941 -- Debug flag K disables this behavior (useful for debugging)
4943 if Debug_Flag_K
then
4951 end Determine_Range
;
4953 -----------------------
4954 -- Determine_Range_R --
4955 -----------------------
4957 procedure Determine_Range_R
4962 Assume_Valid
: Boolean := False)
4964 Typ
: Entity_Id
:= Etype
(N
);
4965 -- Type to use, may get reset to base type for possibly invalid entity
4969 -- Lo and Hi bounds of left operand
4971 Lo_Right
: Ureal
:= No_Ureal
;
4972 Hi_Right
: Ureal
:= No_Ureal
;
4973 -- Lo and Hi bounds of right (or only) operand
4976 -- Temp variable used to hold a bound node
4979 -- High bound of base type of expression
4983 -- Refined values for low and high bounds, after tightening
4986 -- Used in lower level calls to indicate if call succeeded
4988 Cindex
: Cache_Index
;
4989 -- Used to search cache
4994 function OK_Operands
return Boolean;
4995 -- Used for binary operators. Determines the ranges of the left and
4996 -- right operands, and if they are both OK, returns True, and puts
4997 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4999 function Round_Machine
(B
: Ureal
) return Ureal
;
5000 -- B is a real bound. Round it using mode Round_Even.
5006 function OK_Operands
return Boolean is
5009 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
5016 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
5024 function Round_Machine
(B
: Ureal
) return Ureal
is
5026 return Machine
(Typ
, B
, Round_Even
, N
);
5029 -- Start of processing for Determine_Range_R
5032 -- Prevent junk warnings by initializing range variables
5039 -- For temporary constants internally generated to remove side effects
5040 -- we must use the corresponding expression to determine the range of
5041 -- the expression. But note that the expander can also generate
5042 -- constants in other cases, including deferred constants.
5044 if Is_Entity_Name
(N
)
5045 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
5046 and then Ekind
(Entity
(N
)) = E_Constant
5047 and then Is_Internal_Name
(Chars
(Entity
(N
)))
5049 if Present
(Expression
(Parent
(Entity
(N
)))) then
5051 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
5053 elsif Present
(Full_View
(Entity
(N
))) then
5055 (Expression
(Parent
(Full_View
(Entity
(N
)))),
5056 OK
, Lo
, Hi
, Assume_Valid
);
5065 -- If type is not defined, we can't determine its range
5069 -- We don't deal with anything except IEEE floating-point types
5071 or else not Is_Floating_Point_Type
(Typ
)
5072 or else Float_Rep
(Typ
) /= IEEE_Binary
5074 -- Ignore type for which an error has been posted, since range in
5075 -- this case may well be a bogosity deriving from the error. Also
5076 -- ignore if error posted on the reference node.
5078 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
5084 -- For all other cases, we can determine the range
5088 -- If value is compile time known, then the possible range is the one
5089 -- value that we know this expression definitely has.
5091 if Compile_Time_Known_Value
(N
) then
5092 Lo
:= Expr_Value_R
(N
);
5097 -- Return if already in the cache
5099 Cindex
:= Cache_Index
(N
mod Cache_Size
);
5101 if Determine_Range_Cache_N
(Cindex
) = N
5103 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
5105 Lo
:= Determine_Range_Cache_Lo_R
(Cindex
);
5106 Hi
:= Determine_Range_Cache_Hi_R
(Cindex
);
5110 -- Otherwise, start by finding the bounds of the type of the expression,
5111 -- the value cannot be outside this range (if it is, then we have an
5112 -- overflow situation, which is a separate check, we are talking here
5113 -- only about the expression value).
5115 -- First a check, never try to find the bounds of a generic type, since
5116 -- these bounds are always junk values, and it is only valid to look at
5117 -- the bounds in an instance.
5119 if Is_Generic_Type
(Typ
) then
5124 -- First step, change to use base type unless we know the value is valid
5126 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
5127 or else Assume_No_Invalid_Values
5128 or else Assume_Valid
5132 Typ
:= Underlying_Type
(Base_Type
(Typ
));
5135 -- Retrieve the base type. Handle the case where the base type is a
5138 Btyp
:= Base_Type
(Typ
);
5140 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
5141 Btyp
:= Full_View
(Btyp
);
5144 -- We use the actual bound unless it is dynamic, in which case use the
5145 -- corresponding base type bound if possible. If we can't get a bound
5146 -- then we figure we can't determine the range (a peculiar case, that
5147 -- perhaps cannot happen, but there is no point in bombing in this
5148 -- optimization circuit).
5150 -- First the low bound
5152 Bound
:= Type_Low_Bound
(Typ
);
5154 if Compile_Time_Known_Value
(Bound
) then
5155 Lo
:= Expr_Value_R
(Bound
);
5157 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
5158 Lo
:= Expr_Value_R
(Type_Low_Bound
(Btyp
));
5165 -- Now the high bound
5167 Bound
:= Type_High_Bound
(Typ
);
5169 -- We need the high bound of the base type later on, and this should
5170 -- always be compile time known. Again, it is not clear that this
5171 -- can ever be false, but no point in bombing.
5173 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
5174 Hbound
:= Expr_Value_R
(Type_High_Bound
(Btyp
));
5182 -- If we have a static subtype, then that may have a tighter bound so
5183 -- use the upper bound of the subtype instead in this case.
5185 if Compile_Time_Known_Value
(Bound
) then
5186 Hi
:= Expr_Value_R
(Bound
);
5189 -- We may be able to refine this value in certain situations. If any
5190 -- refinement is possible, then Lor and Hir are set to possibly tighter
5191 -- bounds, and OK1 is set to True.
5195 -- For unary plus, result is limited by range of operand
5199 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
5201 -- For unary minus, determine range of operand, and negate it
5205 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
5212 -- For binary addition, get range of each operand and do the
5213 -- addition to get the result range.
5217 Lor
:= Round_Machine
(Lo_Left
+ Lo_Right
);
5218 Hir
:= Round_Machine
(Hi_Left
+ Hi_Right
);
5221 -- For binary subtraction, get range of each operand and do the worst
5222 -- case subtraction to get the result range.
5224 when N_Op_Subtract
=>
5226 Lor
:= Round_Machine
(Lo_Left
- Hi_Right
);
5227 Hir
:= Round_Machine
(Hi_Left
- Lo_Right
);
5230 -- For multiplication, get range of each operand and do the
5231 -- four multiplications to get the result range.
5233 when N_Op_Multiply
=>
5236 M1
: constant Ureal
:= Round_Machine
(Lo_Left
* Lo_Right
);
5237 M2
: constant Ureal
:= Round_Machine
(Lo_Left
* Hi_Right
);
5238 M3
: constant Ureal
:= Round_Machine
(Hi_Left
* Lo_Right
);
5239 M4
: constant Ureal
:= Round_Machine
(Hi_Left
* Hi_Right
);
5242 Lor
:= UR_Min
(UR_Min
(M1
, M2
), UR_Min
(M3
, M4
));
5243 Hir
:= UR_Max
(UR_Max
(M1
, M2
), UR_Max
(M3
, M4
));
5247 -- For division, consider separately the cases where the right
5248 -- operand is positive or negative. Otherwise, the right operand
5249 -- can be arbitrarily close to zero, so the result is likely to
5250 -- be unbounded in one direction, do not attempt to compute it.
5255 -- Right operand is positive
5257 if Lo_Right
> Ureal_0
then
5259 -- If the low bound of the left operand is negative, obtain
5260 -- the overall low bound by dividing it by the smallest
5261 -- value of the right operand, and otherwise by the largest
5262 -- value of the right operand.
5264 if Lo_Left
< Ureal_0
then
5265 Lor
:= Round_Machine
(Lo_Left
/ Lo_Right
);
5267 Lor
:= Round_Machine
(Lo_Left
/ Hi_Right
);
5270 -- If the high bound of the left operand is negative, obtain
5271 -- the overall high bound by dividing it by the largest
5272 -- value of the right operand, and otherwise by the
5273 -- smallest value of the right operand.
5275 if Hi_Left
< Ureal_0
then
5276 Hir
:= Round_Machine
(Hi_Left
/ Hi_Right
);
5278 Hir
:= Round_Machine
(Hi_Left
/ Lo_Right
);
5281 -- Right operand is negative
5283 elsif Hi_Right
< Ureal_0
then
5285 -- If the low bound of the left operand is negative, obtain
5286 -- the overall low bound by dividing it by the largest
5287 -- value of the right operand, and otherwise by the smallest
5288 -- value of the right operand.
5290 if Lo_Left
< Ureal_0
then
5291 Lor
:= Round_Machine
(Lo_Left
/ Hi_Right
);
5293 Lor
:= Round_Machine
(Lo_Left
/ Lo_Right
);
5296 -- If the high bound of the left operand is negative, obtain
5297 -- the overall high bound by dividing it by the smallest
5298 -- value of the right operand, and otherwise by the
5299 -- largest value of the right operand.
5301 if Hi_Left
< Ureal_0
then
5302 Hir
:= Round_Machine
(Hi_Left
/ Lo_Right
);
5304 Hir
:= Round_Machine
(Hi_Left
/ Hi_Right
);
5312 when N_Type_Conversion
=>
5314 -- For type conversion from one floating-point type to another, we
5315 -- can refine the range using the converted value.
5317 if Is_Floating_Point_Type
(Etype
(Expression
(N
))) then
5318 Determine_Range_R
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
5320 -- When converting an integer to a floating-point type, determine
5321 -- the range in integer first, and then convert the bounds.
5323 elsif Is_Discrete_Type
(Etype
(Expression
(N
))) then
5330 (Expression
(N
), OK1
, Lor_Int
, Hir_Int
, Assume_Valid
);
5333 Lor
:= Round_Machine
(UR_From_Uint
(Lor_Int
));
5334 Hir
:= Round_Machine
(UR_From_Uint
(Hir_Int
));
5342 -- Nothing special to do for all other expression kinds
5350 -- At this stage, if OK1 is true, then we know that the actual result of
5351 -- the computed expression is in the range Lor .. Hir. We can use this
5352 -- to restrict the possible range of results.
5356 -- If the refined value of the low bound is greater than the type
5357 -- low bound, then reset it to the more restrictive value.
5363 -- Similarly, if the refined value of the high bound is less than the
5364 -- value so far, then reset it to the more restrictive value.
5371 -- Set cache entry for future call and we are all done
5373 Determine_Range_Cache_N
(Cindex
) := N
;
5374 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
5375 Determine_Range_Cache_Lo_R
(Cindex
) := Lo
;
5376 Determine_Range_Cache_Hi_R
(Cindex
) := Hi
;
5379 -- If any exception occurs, it means that we have some bug in the compiler,
5380 -- possibly triggered by a previous error, or by some unforeseen peculiar
5381 -- occurrence. However, this is only an optimization attempt, so there is
5382 -- really no point in crashing the compiler. Instead we just decide, too
5383 -- bad, we can't figure out a range in this case after all.
5388 -- Debug flag K disables this behavior (useful for debugging)
5390 if Debug_Flag_K
then
5398 end Determine_Range_R
;
5400 ------------------------------------
5401 -- Discriminant_Checks_Suppressed --
5402 ------------------------------------
5404 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5407 if Is_Unchecked_Union
(E
) then
5409 elsif Checks_May_Be_Suppressed
(E
) then
5410 return Is_Check_Suppressed
(E
, Discriminant_Check
);
5414 return Scope_Suppress
.Suppress
(Discriminant_Check
);
5415 end Discriminant_Checks_Suppressed
;
5417 --------------------------------
5418 -- Division_Checks_Suppressed --
5419 --------------------------------
5421 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5423 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
5424 return Is_Check_Suppressed
(E
, Division_Check
);
5426 return Scope_Suppress
.Suppress
(Division_Check
);
5428 end Division_Checks_Suppressed
;
5430 --------------------------------------
5431 -- Duplicated_Tag_Checks_Suppressed --
5432 --------------------------------------
5434 function Duplicated_Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5436 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
5437 return Is_Check_Suppressed
(E
, Duplicated_Tag_Check
);
5439 return Scope_Suppress
.Suppress
(Duplicated_Tag_Check
);
5441 end Duplicated_Tag_Checks_Suppressed
;
5443 -----------------------------------
5444 -- Elaboration_Checks_Suppressed --
5445 -----------------------------------
5447 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5449 -- The complication in this routine is that if we are in the dynamic
5450 -- model of elaboration, we also check All_Checks, since All_Checks
5451 -- does not set Elaboration_Check explicitly.
5454 if Kill_Elaboration_Checks
(E
) then
5457 elsif Checks_May_Be_Suppressed
(E
) then
5458 if Is_Check_Suppressed
(E
, Elaboration_Check
) then
5461 elsif Dynamic_Elaboration_Checks
then
5462 return Is_Check_Suppressed
(E
, All_Checks
);
5470 if Scope_Suppress
.Suppress
(Elaboration_Check
) then
5473 elsif Dynamic_Elaboration_Checks
then
5474 return Scope_Suppress
.Suppress
(All_Checks
);
5479 end Elaboration_Checks_Suppressed
;
5481 ---------------------------
5482 -- Enable_Overflow_Check --
5483 ---------------------------
5485 procedure Enable_Overflow_Check
(N
: Node_Id
) is
5486 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
5487 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
5495 Do_Ovflow_Check
: Boolean;
5498 if Debug_Flag_CC
then
5499 w
("Enable_Overflow_Check for node ", Int
(N
));
5500 Write_Str
(" Source location = ");
5505 -- No check if overflow checks suppressed for type of node
5507 if Overflow_Checks_Suppressed
(Etype
(N
)) then
5510 -- Nothing to do for unsigned integer types, which do not overflow
5512 elsif Is_Modular_Integer_Type
(Typ
) then
5516 -- This is the point at which processing for STRICT mode diverges
5517 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
5518 -- probably more extreme that it needs to be, but what is going on here
5519 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
5520 -- to leave the processing for STRICT mode untouched. There were
5521 -- two reasons for this. First it avoided any incompatible change of
5522 -- behavior. Second, it guaranteed that STRICT mode continued to be
5525 -- The big difference is that in STRICT mode there is a fair amount of
5526 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
5527 -- know that no check is needed. We skip all that in the two new modes,
5528 -- since really overflow checking happens over a whole subtree, and we
5529 -- do the corresponding optimizations later on when applying the checks.
5531 if Mode
in Minimized_Or_Eliminated
then
5532 if not (Overflow_Checks_Suppressed
(Etype
(N
)))
5533 and then not (Is_Entity_Name
(N
)
5534 and then Overflow_Checks_Suppressed
(Entity
(N
)))
5536 Activate_Overflow_Check
(N
);
5539 if Debug_Flag_CC
then
5540 w
("Minimized/Eliminated mode");
5546 -- Remainder of processing is for STRICT case, and is unchanged from
5547 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
5549 -- Nothing to do if the range of the result is known OK. We skip this
5550 -- for conversions, since the caller already did the check, and in any
5551 -- case the condition for deleting the check for a type conversion is
5554 if Nkind
(N
) /= N_Type_Conversion
then
5555 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
5557 -- Note in the test below that we assume that the range is not OK
5558 -- if a bound of the range is equal to that of the type. That's not
5559 -- quite accurate but we do this for the following reasons:
5561 -- a) The way that Determine_Range works, it will typically report
5562 -- the bounds of the value as being equal to the bounds of the
5563 -- type, because it either can't tell anything more precise, or
5564 -- does not think it is worth the effort to be more precise.
5566 -- b) It is very unusual to have a situation in which this would
5567 -- generate an unnecessary overflow check (an example would be
5568 -- a subtype with a range 0 .. Integer'Last - 1 to which the
5569 -- literal value one is added).
5571 -- c) The alternative is a lot of special casing in this routine
5572 -- which would partially duplicate Determine_Range processing.
5575 Do_Ovflow_Check
:= True;
5577 -- Note that the following checks are quite deliberately > and <
5578 -- rather than >= and <= as explained above.
5580 if Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
5582 Hi
< Expr_Value
(Type_High_Bound
(Typ
))
5584 Do_Ovflow_Check
:= False;
5586 -- Despite the comments above, it is worth dealing specially with
5587 -- division specially. The only case where integer division can
5588 -- overflow is (largest negative number) / (-1). So we will do
5589 -- an extra range analysis to see if this is possible.
5591 elsif Nkind
(N
) = N_Op_Divide
then
5593 (Left_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
5595 if OK
and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
)) then
5596 Do_Ovflow_Check
:= False;
5600 (Right_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
5602 if OK
and then (Lo
> Uint_Minus_1
5606 Do_Ovflow_Check
:= False;
5611 -- If no overflow check required, we are done
5613 if not Do_Ovflow_Check
then
5614 if Debug_Flag_CC
then
5615 w
("No overflow check required");
5623 -- If not in optimizing mode, set flag and we are done. We are also done
5624 -- (and just set the flag) if the type is not a discrete type, since it
5625 -- is not worth the effort to eliminate checks for other than discrete
5626 -- types. In addition, we take this same path if we have stored the
5627 -- maximum number of checks possible already (a very unlikely situation,
5628 -- but we do not want to blow up).
5630 if Optimization_Level
= 0
5631 or else not Is_Discrete_Type
(Etype
(N
))
5632 or else Num_Saved_Checks
= Saved_Checks
'Last
5634 Activate_Overflow_Check
(N
);
5636 if Debug_Flag_CC
then
5637 w
("Optimization off");
5643 -- Otherwise evaluate and check the expression
5648 Target_Type
=> Empty
,
5654 if Debug_Flag_CC
then
5655 w
("Called Find_Check");
5659 w
(" Check_Num = ", Chk
);
5660 w
(" Ent = ", Int
(Ent
));
5661 Write_Str
(" Ofs = ");
5666 -- If check is not of form to optimize, then set flag and we are done
5669 Activate_Overflow_Check
(N
);
5673 -- If check is already performed, then return without setting flag
5676 if Debug_Flag_CC
then
5677 w
("Check suppressed!");
5683 -- Here we will make a new entry for the new check
5685 Activate_Overflow_Check
(N
);
5686 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
5687 Saved_Checks
(Num_Saved_Checks
) :=
5692 Target_Type
=> Empty
);
5694 if Debug_Flag_CC
then
5695 w
("Make new entry, check number = ", Num_Saved_Checks
);
5696 w
(" Entity = ", Int
(Ent
));
5697 Write_Str
(" Offset = ");
5699 w
(" Check_Type = O");
5700 w
(" Target_Type = Empty");
5703 -- If we get an exception, then something went wrong, probably because of
5704 -- an error in the structure of the tree due to an incorrect program. Or
5705 -- it may be a bug in the optimization circuit. In either case the safest
5706 -- thing is simply to set the check flag unconditionally.
5710 Activate_Overflow_Check
(N
);
5712 if Debug_Flag_CC
then
5713 w
(" exception occurred, overflow flag set");
5717 end Enable_Overflow_Check
;
5719 ------------------------
5720 -- Enable_Range_Check --
5721 ------------------------
5723 procedure Enable_Range_Check
(N
: Node_Id
) is
5732 -- Return if unchecked type conversion with range check killed. In this
5733 -- case we never set the flag (that's what Kill_Range_Check is about).
5735 if Nkind
(N
) = N_Unchecked_Type_Conversion
5736 and then Kill_Range_Check
(N
)
5741 -- Do not set range check flag if parent is assignment statement or
5742 -- object declaration with Suppress_Assignment_Checks flag set
5744 if Nkind_In
(Parent
(N
), N_Assignment_Statement
, N_Object_Declaration
)
5745 and then Suppress_Assignment_Checks
(Parent
(N
))
5750 -- Check for various cases where we should suppress the range check
5752 -- No check if range checks suppressed for type of node
5754 if Present
(Etype
(N
)) and then Range_Checks_Suppressed
(Etype
(N
)) then
5757 -- No check if node is an entity name, and range checks are suppressed
5758 -- for this entity, or for the type of this entity.
5760 elsif Is_Entity_Name
(N
)
5761 and then (Range_Checks_Suppressed
(Entity
(N
))
5762 or else Range_Checks_Suppressed
(Etype
(Entity
(N
))))
5766 -- No checks if index of array, and index checks are suppressed for
5767 -- the array object or the type of the array.
5769 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
then
5771 Pref
: constant Node_Id
:= Prefix
(Parent
(N
));
5773 if Is_Entity_Name
(Pref
)
5774 and then Index_Checks_Suppressed
(Entity
(Pref
))
5777 elsif Index_Checks_Suppressed
(Etype
(Pref
)) then
5783 -- Debug trace output
5785 if Debug_Flag_CC
then
5786 w
("Enable_Range_Check for node ", Int
(N
));
5787 Write_Str
(" Source location = ");
5792 -- If not in optimizing mode, set flag and we are done. We are also done
5793 -- (and just set the flag) if the type is not a discrete type, since it
5794 -- is not worth the effort to eliminate checks for other than discrete
5795 -- types. In addition, we take this same path if we have stored the
5796 -- maximum number of checks possible already (a very unlikely situation,
5797 -- but we do not want to blow up).
5799 if Optimization_Level
= 0
5800 or else No
(Etype
(N
))
5801 or else not Is_Discrete_Type
(Etype
(N
))
5802 or else Num_Saved_Checks
= Saved_Checks
'Last
5804 Activate_Range_Check
(N
);
5806 if Debug_Flag_CC
then
5807 w
("Optimization off");
5813 -- Otherwise find out the target type
5817 -- For assignment, use left side subtype
5819 if Nkind
(P
) = N_Assignment_Statement
5820 and then Expression
(P
) = N
5822 Ttyp
:= Etype
(Name
(P
));
5824 -- For indexed component, use subscript subtype
5826 elsif Nkind
(P
) = N_Indexed_Component
then
5833 Atyp
:= Etype
(Prefix
(P
));
5835 if Is_Access_Type
(Atyp
) then
5836 Atyp
:= Designated_Type
(Atyp
);
5838 -- If the prefix is an access to an unconstrained array,
5839 -- perform check unconditionally: it depends on the bounds of
5840 -- an object and we cannot currently recognize whether the test
5841 -- may be redundant.
5843 if not Is_Constrained
(Atyp
) then
5844 Activate_Range_Check
(N
);
5848 -- Ditto if prefix is simply an unconstrained array. We used
5849 -- to think this case was OK, if the prefix was not an explicit
5850 -- dereference, but we have now seen a case where this is not
5851 -- true, so it is safer to just suppress the optimization in this
5852 -- case. The back end is getting better at eliminating redundant
5853 -- checks in any case, so the loss won't be important.
5855 elsif Is_Array_Type
(Atyp
)
5856 and then not Is_Constrained
(Atyp
)
5858 Activate_Range_Check
(N
);
5862 Indx
:= First_Index
(Atyp
);
5863 Subs
:= First
(Expressions
(P
));
5866 Ttyp
:= Etype
(Indx
);
5875 -- For now, ignore all other cases, they are not so interesting
5878 if Debug_Flag_CC
then
5879 w
(" target type not found, flag set");
5882 Activate_Range_Check
(N
);
5886 -- Evaluate and check the expression
5891 Target_Type
=> Ttyp
,
5897 if Debug_Flag_CC
then
5898 w
("Called Find_Check");
5899 w
("Target_Typ = ", Int
(Ttyp
));
5903 w
(" Check_Num = ", Chk
);
5904 w
(" Ent = ", Int
(Ent
));
5905 Write_Str
(" Ofs = ");
5910 -- If check is not of form to optimize, then set flag and we are done
5913 if Debug_Flag_CC
then
5914 w
(" expression not of optimizable type, flag set");
5917 Activate_Range_Check
(N
);
5921 -- If check is already performed, then return without setting flag
5924 if Debug_Flag_CC
then
5925 w
("Check suppressed!");
5931 -- Here we will make a new entry for the new check
5933 Activate_Range_Check
(N
);
5934 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
5935 Saved_Checks
(Num_Saved_Checks
) :=
5940 Target_Type
=> Ttyp
);
5942 if Debug_Flag_CC
then
5943 w
("Make new entry, check number = ", Num_Saved_Checks
);
5944 w
(" Entity = ", Int
(Ent
));
5945 Write_Str
(" Offset = ");
5947 w
(" Check_Type = R");
5948 w
(" Target_Type = ", Int
(Ttyp
));
5949 pg
(Union_Id
(Ttyp
));
5952 -- If we get an exception, then something went wrong, probably because of
5953 -- an error in the structure of the tree due to an incorrect program. Or
5954 -- it may be a bug in the optimization circuit. In either case the safest
5955 -- thing is simply to set the check flag unconditionally.
5959 Activate_Range_Check
(N
);
5961 if Debug_Flag_CC
then
5962 w
(" exception occurred, range flag set");
5966 end Enable_Range_Check
;
5972 procedure Ensure_Valid
5974 Holes_OK
: Boolean := False;
5975 Related_Id
: Entity_Id
:= Empty
;
5976 Is_Low_Bound
: Boolean := False;
5977 Is_High_Bound
: Boolean := False)
5979 Typ
: constant Entity_Id
:= Etype
(Expr
);
5982 -- Ignore call if we are not doing any validity checking
5984 if not Validity_Checks_On
then
5987 -- Ignore call if range or validity checks suppressed on entity or type
5989 elsif Range_Or_Validity_Checks_Suppressed
(Expr
) then
5992 -- No check required if expression is from the expander, we assume the
5993 -- expander will generate whatever checks are needed. Note that this is
5994 -- not just an optimization, it avoids infinite recursions.
5996 -- Unchecked conversions must be checked, unless they are initialized
5997 -- scalar values, as in a component assignment in an init proc.
5999 -- In addition, we force a check if Force_Validity_Checks is set
6001 elsif not Comes_From_Source
(Expr
)
6003 (Nkind
(Expr
) = N_Identifier
6004 and then Present
(Renamed_Object
(Entity
(Expr
)))
6005 and then Comes_From_Source
(Renamed_Object
(Entity
(Expr
))))
6006 and then not Force_Validity_Checks
6007 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
6008 or else Kill_Range_Check
(Expr
))
6012 -- No check required if expression is known to have valid value
6014 elsif Expr_Known_Valid
(Expr
) then
6017 -- No check needed within a generated predicate function. Validity
6018 -- of input value will have been checked earlier.
6020 elsif Ekind
(Current_Scope
) = E_Function
6021 and then Is_Predicate_Function
(Current_Scope
)
6025 -- Ignore case of enumeration with holes where the flag is set not to
6026 -- worry about holes, since no special validity check is needed
6028 elsif Is_Enumeration_Type
(Typ
)
6029 and then Has_Non_Standard_Rep
(Typ
)
6034 -- No check required on the left-hand side of an assignment
6036 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
6037 and then Expr
= Name
(Parent
(Expr
))
6041 -- No check on a universal real constant. The context will eventually
6042 -- convert it to a machine number for some target type, or report an
6045 elsif Nkind
(Expr
) = N_Real_Literal
6046 and then Etype
(Expr
) = Universal_Real
6050 -- If the expression denotes a component of a packed boolean array,
6051 -- no possible check applies. We ignore the old ACATS chestnuts that
6052 -- involve Boolean range True..True.
6054 -- Note: validity checks are generated for expressions that yield a
6055 -- scalar type, when it is possible to create a value that is outside of
6056 -- the type. If this is a one-bit boolean no such value exists. This is
6057 -- an optimization, and it also prevents compiler blowing up during the
6058 -- elaboration of improperly expanded packed array references.
6060 elsif Nkind
(Expr
) = N_Indexed_Component
6061 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Expr
)))
6062 and then Root_Type
(Etype
(Expr
)) = Standard_Boolean
6066 -- For an expression with actions, we want to insert the validity check
6067 -- on the final Expression.
6069 elsif Nkind
(Expr
) = N_Expression_With_Actions
then
6070 Ensure_Valid
(Expression
(Expr
));
6073 -- An annoying special case. If this is an out parameter of a scalar
6074 -- type, then the value is not going to be accessed, therefore it is
6075 -- inappropriate to do any validity check at the call site.
6078 -- Only need to worry about scalar types
6080 if Is_Scalar_Type
(Typ
) then
6090 -- Find actual argument (which may be a parameter association)
6091 -- and the parent of the actual argument (the call statement)
6096 if Nkind
(P
) = N_Parameter_Association
then
6101 -- Only need to worry if we are argument of a procedure call
6102 -- since functions don't have out parameters. If this is an
6103 -- indirect or dispatching call, get signature from the
6106 if Nkind
(P
) = N_Procedure_Call_Statement
then
6107 L
:= Parameter_Associations
(P
);
6109 if Is_Entity_Name
(Name
(P
)) then
6110 E
:= Entity
(Name
(P
));
6112 pragma Assert
(Nkind
(Name
(P
)) = N_Explicit_Dereference
);
6113 E
:= Etype
(Name
(P
));
6116 -- Only need to worry if there are indeed actuals, and if
6117 -- this could be a procedure call, otherwise we cannot get a
6118 -- match (either we are not an argument, or the mode of the
6119 -- formal is not OUT). This test also filters out the
6122 if Is_Non_Empty_List
(L
) and then Is_Subprogram
(E
) then
6124 -- This is the loop through parameters, looking for an
6125 -- OUT parameter for which we are the argument.
6127 F
:= First_Formal
(E
);
6129 while Present
(F
) loop
6130 if Ekind
(F
) = E_Out_Parameter
and then A
= N
then
6143 -- If this is a boolean expression, only its elementary operands need
6144 -- checking: if they are valid, a boolean or short-circuit operation
6145 -- with them will be valid as well.
6147 if Base_Type
(Typ
) = Standard_Boolean
6149 (Nkind
(Expr
) in N_Op
or else Nkind
(Expr
) in N_Short_Circuit
)
6154 -- If we fall through, a validity check is required
6156 Insert_Valid_Check
(Expr
, Related_Id
, Is_Low_Bound
, Is_High_Bound
);
6158 if Is_Entity_Name
(Expr
)
6159 and then Safe_To_Capture_Value
(Expr
, Entity
(Expr
))
6161 Set_Is_Known_Valid
(Entity
(Expr
));
6165 ----------------------
6166 -- Expr_Known_Valid --
6167 ----------------------
6169 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
6170 Typ
: constant Entity_Id
:= Etype
(Expr
);
6173 -- Non-scalar types are always considered valid, since they never give
6174 -- rise to the issues of erroneous or bounded error behavior that are
6175 -- the concern. In formal reference manual terms the notion of validity
6176 -- only applies to scalar types. Note that even when packed arrays are
6177 -- represented using modular types, they are still arrays semantically,
6178 -- so they are also always valid (in particular, the unused bits can be
6179 -- random rubbish without affecting the validity of the array value).
6181 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Impl_Type
(Typ
) then
6184 -- If no validity checking, then everything is considered valid
6186 elsif not Validity_Checks_On
then
6189 -- Floating-point types are considered valid unless floating-point
6190 -- validity checks have been specifically turned on.
6192 elsif Is_Floating_Point_Type
(Typ
)
6193 and then not Validity_Check_Floating_Point
6197 -- If the expression is the value of an object that is known to be
6198 -- valid, then clearly the expression value itself is valid.
6200 elsif Is_Entity_Name
(Expr
)
6201 and then Is_Known_Valid
(Entity
(Expr
))
6203 -- Exclude volatile variables
6205 and then not Treat_As_Volatile
(Entity
(Expr
))
6209 -- References to discriminants are always considered valid. The value
6210 -- of a discriminant gets checked when the object is built. Within the
6211 -- record, we consider it valid, and it is important to do so, since
6212 -- otherwise we can try to generate bogus validity checks which
6213 -- reference discriminants out of scope. Discriminants of concurrent
6214 -- types are excluded for the same reason.
6216 elsif Is_Entity_Name
(Expr
)
6217 and then Denotes_Discriminant
(Expr
, Check_Concurrent
=> True)
6221 -- If the type is one for which all values are known valid, then we are
6222 -- sure that the value is valid except in the slightly odd case where
6223 -- the expression is a reference to a variable whose size has been
6224 -- explicitly set to a value greater than the object size.
6226 elsif Is_Known_Valid
(Typ
) then
6227 if Is_Entity_Name
(Expr
)
6228 and then Ekind
(Entity
(Expr
)) = E_Variable
6229 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
6236 -- Integer and character literals always have valid values, where
6237 -- appropriate these will be range checked in any case.
6239 elsif Nkind_In
(Expr
, N_Integer_Literal
, N_Character_Literal
) then
6242 -- If we have a type conversion or a qualification of a known valid
6243 -- value, then the result will always be valid.
6245 elsif Nkind_In
(Expr
, N_Type_Conversion
, N_Qualified_Expression
) then
6246 return Expr_Known_Valid
(Expression
(Expr
));
6248 -- Case of expression is a non-floating-point operator. In this case we
6249 -- can assume the result is valid the generated code for the operator
6250 -- will include whatever checks are needed (e.g. range checks) to ensure
6251 -- validity. This assumption does not hold for the floating-point case,
6252 -- since floating-point operators can generate Infinite or NaN results
6253 -- which are considered invalid.
6255 -- Historical note: in older versions, the exemption of floating-point
6256 -- types from this assumption was done only in cases where the parent
6257 -- was an assignment, function call or parameter association. Presumably
6258 -- the idea was that in other contexts, the result would be checked
6259 -- elsewhere, but this list of cases was missing tests (at least the
6260 -- N_Object_Declaration case, as shown by a reported missing validity
6261 -- check), and it is not clear why function calls but not procedure
6262 -- calls were tested for. It really seems more accurate and much
6263 -- safer to recognize that expressions which are the result of a
6264 -- floating-point operator can never be assumed to be valid.
6266 elsif Nkind
(Expr
) in N_Op
and then not Is_Floating_Point_Type
(Typ
) then
6269 -- The result of a membership test is always valid, since it is true or
6270 -- false, there are no other possibilities.
6272 elsif Nkind
(Expr
) in N_Membership_Test
then
6275 -- For all other cases, we do not know the expression is valid
6280 end Expr_Known_Valid
;
6286 procedure Find_Check
6288 Check_Type
: Character;
6289 Target_Type
: Entity_Id
;
6290 Entry_OK
: out Boolean;
6291 Check_Num
: out Nat
;
6292 Ent
: out Entity_Id
;
6295 function Within_Range_Of
6296 (Target_Type
: Entity_Id
;
6297 Check_Type
: Entity_Id
) return Boolean;
6298 -- Given a requirement for checking a range against Target_Type, and
6299 -- and a range Check_Type against which a check has already been made,
6300 -- determines if the check against check type is sufficient to ensure
6301 -- that no check against Target_Type is required.
6303 ---------------------
6304 -- Within_Range_Of --
6305 ---------------------
6307 function Within_Range_Of
6308 (Target_Type
: Entity_Id
;
6309 Check_Type
: Entity_Id
) return Boolean
6312 if Target_Type
= Check_Type
then
6317 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
6318 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
6319 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
6320 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
6324 or else (Compile_Time_Known_Value
(Tlo
)
6326 Compile_Time_Known_Value
(Clo
)
6328 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
6331 or else (Compile_Time_Known_Value
(Thi
)
6333 Compile_Time_Known_Value
(Chi
)
6335 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
6343 end Within_Range_Of
;
6345 -- Start of processing for Find_Check
6348 -- Establish default, in case no entry is found
6352 -- Case of expression is simple entity reference
6354 if Is_Entity_Name
(Expr
) then
6355 Ent
:= Entity
(Expr
);
6358 -- Case of expression is entity + known constant
6360 elsif Nkind
(Expr
) = N_Op_Add
6361 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
6362 and then Is_Entity_Name
(Left_Opnd
(Expr
))
6364 Ent
:= Entity
(Left_Opnd
(Expr
));
6365 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
6367 -- Case of expression is entity - known constant
6369 elsif Nkind
(Expr
) = N_Op_Subtract
6370 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
6371 and then Is_Entity_Name
(Left_Opnd
(Expr
))
6373 Ent
:= Entity
(Left_Opnd
(Expr
));
6374 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
6376 -- Any other expression is not of the right form
6385 -- Come here with expression of appropriate form, check if entity is an
6386 -- appropriate one for our purposes.
6388 if (Ekind
(Ent
) = E_Variable
6389 or else Is_Constant_Object
(Ent
))
6390 and then not Is_Library_Level_Entity
(Ent
)
6398 -- See if there is matching check already
6400 for J
in reverse 1 .. Num_Saved_Checks
loop
6402 SC
: Saved_Check
renames Saved_Checks
(J
);
6404 if SC
.Killed
= False
6405 and then SC
.Entity
= Ent
6406 and then SC
.Offset
= Ofs
6407 and then SC
.Check_Type
= Check_Type
6408 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
6416 -- If we fall through entry was not found
6421 ---------------------------------
6422 -- Generate_Discriminant_Check --
6423 ---------------------------------
6425 -- Note: the code for this procedure is derived from the
6426 -- Emit_Discriminant_Check Routine in trans.c.
6428 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
6429 Loc
: constant Source_Ptr
:= Sloc
(N
);
6430 Pref
: constant Node_Id
:= Prefix
(N
);
6431 Sel
: constant Node_Id
:= Selector_Name
(N
);
6433 Orig_Comp
: constant Entity_Id
:=
6434 Original_Record_Component
(Entity
(Sel
));
6435 -- The original component to be checked
6437 Discr_Fct
: constant Entity_Id
:=
6438 Discriminant_Checking_Func
(Orig_Comp
);
6439 -- The discriminant checking function
6442 -- One discriminant to be checked in the type
6444 Real_Discr
: Entity_Id
;
6445 -- Actual discriminant in the call
6447 Pref_Type
: Entity_Id
;
6448 -- Type of relevant prefix (ignoring private/access stuff)
6451 -- List of arguments for function call
6454 -- Keep track of the formal corresponding to the actual we build for
6455 -- each discriminant, in order to be able to perform the necessary type
6459 -- Selected component reference for checking function argument
6462 Pref_Type
:= Etype
(Pref
);
6464 -- Force evaluation of the prefix, so that it does not get evaluated
6465 -- twice (once for the check, once for the actual reference). Such a
6466 -- double evaluation is always a potential source of inefficiency, and
6467 -- is functionally incorrect in the volatile case, or when the prefix
6468 -- may have side effects. A nonvolatile entity or a component of a
6469 -- nonvolatile entity requires no evaluation.
6471 if Is_Entity_Name
(Pref
) then
6472 if Treat_As_Volatile
(Entity
(Pref
)) then
6473 Force_Evaluation
(Pref
, Name_Req
=> True);
6476 elsif Treat_As_Volatile
(Etype
(Pref
)) then
6477 Force_Evaluation
(Pref
, Name_Req
=> True);
6479 elsif Nkind
(Pref
) = N_Selected_Component
6480 and then Is_Entity_Name
(Prefix
(Pref
))
6485 Force_Evaluation
(Pref
, Name_Req
=> True);
6488 -- For a tagged type, use the scope of the original component to
6489 -- obtain the type, because ???
6491 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
6492 Pref_Type
:= Scope
(Orig_Comp
);
6494 -- For an untagged derived type, use the discriminants of the parent
6495 -- which have been renamed in the derivation, possibly by a one-to-many
6496 -- discriminant constraint. For untagged type, initially get the Etype
6500 if Is_Derived_Type
(Pref_Type
)
6501 and then Number_Discriminants
(Pref_Type
) /=
6502 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
6504 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
6508 -- We definitely should have a checking function, This routine should
6509 -- not be called if no discriminant checking function is present.
6511 pragma Assert
(Present
(Discr_Fct
));
6513 -- Create the list of the actual parameters for the call. This list
6514 -- is the list of the discriminant fields of the record expression to
6515 -- be discriminant checked.
6518 Formal
:= First_Formal
(Discr_Fct
);
6519 Discr
:= First_Discriminant
(Pref_Type
);
6520 while Present
(Discr
) loop
6522 -- If we have a corresponding discriminant field, and a parent
6523 -- subtype is present, then we want to use the corresponding
6524 -- discriminant since this is the one with the useful value.
6526 if Present
(Corresponding_Discriminant
(Discr
))
6527 and then Ekind
(Pref_Type
) = E_Record_Type
6528 and then Present
(Parent_Subtype
(Pref_Type
))
6530 Real_Discr
:= Corresponding_Discriminant
(Discr
);
6532 Real_Discr
:= Discr
;
6535 -- Construct the reference to the discriminant
6538 Make_Selected_Component
(Loc
,
6540 Unchecked_Convert_To
(Pref_Type
,
6541 Duplicate_Subexpr
(Pref
)),
6542 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
6544 -- Manually analyze and resolve this selected component. We really
6545 -- want it just as it appears above, and do not want the expander
6546 -- playing discriminal games etc with this reference. Then we append
6547 -- the argument to the list we are gathering.
6549 Set_Etype
(Scomp
, Etype
(Real_Discr
));
6550 Set_Analyzed
(Scomp
, True);
6551 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
6553 Next_Formal_With_Extras
(Formal
);
6554 Next_Discriminant
(Discr
);
6557 -- Now build and insert the call
6560 Make_Raise_Constraint_Error
(Loc
,
6562 Make_Function_Call
(Loc
,
6563 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
6564 Parameter_Associations
=> Args
),
6565 Reason
=> CE_Discriminant_Check_Failed
));
6566 end Generate_Discriminant_Check
;
6568 ---------------------------
6569 -- Generate_Index_Checks --
6570 ---------------------------
6572 procedure Generate_Index_Checks
(N
: Node_Id
) is
6574 function Entity_Of_Prefix
return Entity_Id
;
6575 -- Returns the entity of the prefix of N (or Empty if not found)
6577 ----------------------
6578 -- Entity_Of_Prefix --
6579 ----------------------
6581 function Entity_Of_Prefix
return Entity_Id
is
6586 while not Is_Entity_Name
(P
) loop
6587 if not Nkind_In
(P
, N_Selected_Component
,
6588 N_Indexed_Component
)
6597 end Entity_Of_Prefix
;
6601 Loc
: constant Source_Ptr
:= Sloc
(N
);
6602 A
: constant Node_Id
:= Prefix
(N
);
6603 A_Ent
: constant Entity_Id
:= Entity_Of_Prefix
;
6606 -- Start of processing for Generate_Index_Checks
6609 -- Ignore call if the prefix is not an array since we have a serious
6610 -- error in the sources. Ignore it also if index checks are suppressed
6611 -- for array object or type.
6613 if not Is_Array_Type
(Etype
(A
))
6614 or else (Present
(A_Ent
) and then Index_Checks_Suppressed
(A_Ent
))
6615 or else Index_Checks_Suppressed
(Etype
(A
))
6619 -- The indexed component we are dealing with contains 'Loop_Entry in its
6620 -- prefix. This case arises when analysis has determined that constructs
6623 -- Prefix'Loop_Entry (Expr)
6624 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
6626 -- require rewriting for error detection purposes. A side effect of this
6627 -- action is the generation of index checks that mention 'Loop_Entry.
6628 -- Delay the generation of the check until 'Loop_Entry has been properly
6629 -- expanded. This is done in Expand_Loop_Entry_Attributes.
6631 elsif Nkind
(Prefix
(N
)) = N_Attribute_Reference
6632 and then Attribute_Name
(Prefix
(N
)) = Name_Loop_Entry
6637 -- Generate a raise of constraint error with the appropriate reason and
6638 -- a condition of the form:
6640 -- Base_Type (Sub) not in Array'Range (Subscript)
6642 -- Note that the reason we generate the conversion to the base type here
6643 -- is that we definitely want the range check to take place, even if it
6644 -- looks like the subtype is OK. Optimization considerations that allow
6645 -- us to omit the check have already been taken into account in the
6646 -- setting of the Do_Range_Check flag earlier on.
6648 Sub
:= First
(Expressions
(N
));
6650 -- Handle string literals
6652 if Ekind
(Etype
(A
)) = E_String_Literal_Subtype
then
6653 if Do_Range_Check
(Sub
) then
6654 Set_Do_Range_Check
(Sub
, False);
6656 -- For string literals we obtain the bounds of the string from the
6657 -- associated subtype.
6660 Make_Raise_Constraint_Error
(Loc
,
6664 Convert_To
(Base_Type
(Etype
(Sub
)),
6665 Duplicate_Subexpr_Move_Checks
(Sub
)),
6667 Make_Attribute_Reference
(Loc
,
6668 Prefix
=> New_Occurrence_Of
(Etype
(A
), Loc
),
6669 Attribute_Name
=> Name_Range
)),
6670 Reason
=> CE_Index_Check_Failed
));
6677 A_Idx
: Node_Id
:= Empty
;
6684 A_Idx
:= First_Index
(Etype
(A
));
6686 while Present
(Sub
) loop
6687 if Do_Range_Check
(Sub
) then
6688 Set_Do_Range_Check
(Sub
, False);
6690 -- Force evaluation except for the case of a simple name of
6691 -- a nonvolatile entity.
6693 if not Is_Entity_Name
(Sub
)
6694 or else Treat_As_Volatile
(Entity
(Sub
))
6696 Force_Evaluation
(Sub
);
6699 if Nkind
(A_Idx
) = N_Range
then
6702 elsif Nkind
(A_Idx
) = N_Identifier
6703 or else Nkind
(A_Idx
) = N_Expanded_Name
6705 A_Range
:= Scalar_Range
(Entity
(A_Idx
));
6707 else pragma Assert
(Nkind
(A_Idx
) = N_Subtype_Indication
);
6708 A_Range
:= Range_Expression
(Constraint
(A_Idx
));
6711 -- For array objects with constant bounds we can generate
6712 -- the index check using the bounds of the type of the index
6715 and then Ekind
(A_Ent
) = E_Variable
6716 and then Is_Constant_Bound
(Low_Bound
(A_Range
))
6717 and then Is_Constant_Bound
(High_Bound
(A_Range
))
6720 Make_Attribute_Reference
(Loc
,
6722 New_Occurrence_Of
(Etype
(A_Idx
), Loc
),
6723 Attribute_Name
=> Name_Range
);
6725 -- For arrays with non-constant bounds we cannot generate
6726 -- the index check using the bounds of the type of the index
6727 -- since it may reference discriminants of some enclosing
6728 -- type. We obtain the bounds directly from the prefix
6735 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
6739 Make_Attribute_Reference
(Loc
,
6741 Duplicate_Subexpr_Move_Checks
(A
, Name_Req
=> True),
6742 Attribute_Name
=> Name_Range
,
6743 Expressions
=> Num
);
6747 Make_Raise_Constraint_Error
(Loc
,
6751 Convert_To
(Base_Type
(Etype
(Sub
)),
6752 Duplicate_Subexpr_Move_Checks
(Sub
)),
6753 Right_Opnd
=> Range_N
),
6754 Reason
=> CE_Index_Check_Failed
));
6757 A_Idx
:= Next_Index
(A_Idx
);
6763 end Generate_Index_Checks
;
6765 --------------------------
6766 -- Generate_Range_Check --
6767 --------------------------
6769 procedure Generate_Range_Check
6771 Target_Type
: Entity_Id
;
6772 Reason
: RT_Exception_Code
)
6774 Loc
: constant Source_Ptr
:= Sloc
(N
);
6775 Source_Type
: constant Entity_Id
:= Etype
(N
);
6776 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
6777 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
6779 procedure Convert_And_Check_Range
;
6780 -- Convert the conversion operand to the target base type and save in
6781 -- a temporary. Then check the converted value against the range of the
6784 -----------------------------
6785 -- Convert_And_Check_Range --
6786 -----------------------------
6788 procedure Convert_And_Check_Range
is
6789 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
6790 Conv_Node
: Node_Id
;
6793 -- For enumeration types with non-standard representation this is a
6794 -- direct conversion from the enumeration type to the target integer
6795 -- type, which is treated by the back end as a normal integer type
6796 -- conversion, treating the enumeration type as an integer, which is
6797 -- exactly what we want. We set Conversion_OK to make sure that the
6798 -- analyzer does not complain about what otherwise might be an
6799 -- illegal conversion.
6801 if Is_Enumeration_Type
(Source_Base_Type
)
6802 and then Present
(Enum_Pos_To_Rep
(Source_Base_Type
))
6803 and then Is_Integer_Type
(Target_Base_Type
)
6807 (Typ
=> Target_Base_Type
,
6808 Expr
=> Duplicate_Subexpr
(N
));
6814 Make_Type_Conversion
(Loc
,
6815 Subtype_Mark
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
6816 Expression
=> Duplicate_Subexpr
(N
));
6819 -- We make a temporary to hold the value of the converted value
6820 -- (converted to the base type), and then do the test against this
6821 -- temporary. The conversion itself is replaced by an occurrence of
6822 -- Tnn and followed by the explicit range check. Note that checks
6823 -- are suppressed for this code, since we don't want a recursive
6824 -- range check popping up.
6826 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
6827 -- [constraint_error when Tnn not in Target_Type]
6829 Insert_Actions
(N
, New_List
(
6830 Make_Object_Declaration
(Loc
,
6831 Defining_Identifier
=> Tnn
,
6832 Object_Definition
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
6833 Constant_Present
=> True,
6834 Expression
=> Conv_Node
),
6836 Make_Raise_Constraint_Error
(Loc
,
6839 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
6840 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
6842 Suppress
=> All_Checks
);
6844 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
6846 -- Set the type of N, because the declaration for Tnn might not
6847 -- be analyzed yet, as is the case if N appears within a record
6848 -- declaration, as a discriminant constraint or expression.
6850 Set_Etype
(N
, Target_Base_Type
);
6851 end Convert_And_Check_Range
;
6853 -- Start of processing for Generate_Range_Check
6856 -- First special case, if the source type is already within the range
6857 -- of the target type, then no check is needed (probably we should have
6858 -- stopped Do_Range_Check from being set in the first place, but better
6859 -- late than never in preventing junk code and junk flag settings.
6861 if In_Subrange_Of
(Source_Type
, Target_Type
)
6863 -- We do NOT apply this if the source node is a literal, since in this
6864 -- case the literal has already been labeled as having the subtype of
6868 (Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
, N_Character_Literal
)
6871 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
6873 Set_Do_Range_Check
(N
, False);
6877 -- Here a check is needed. If the expander is not active, or if we are
6878 -- in GNATProve mode, then simply set the Do_Range_Check flag and we
6879 -- are done. In both these cases, we just want to see the range check
6880 -- flag set, we do not want to generate the explicit range check code.
6882 if GNATprove_Mode
or else not Expander_Active
then
6883 Set_Do_Range_Check
(N
, True);
6887 -- Here we will generate an explicit range check, so we don't want to
6888 -- set the Do_Range check flag, since the range check is taken care of
6889 -- by the code we will generate.
6891 Set_Do_Range_Check
(N
, False);
6893 -- Force evaluation of the node, so that it does not get evaluated twice
6894 -- (once for the check, once for the actual reference). Such a double
6895 -- evaluation is always a potential source of inefficiency, and is
6896 -- functionally incorrect in the volatile case.
6898 -- We skip the evaluation of attribute references because, after these
6899 -- runtime checks are generated, the expander may need to rewrite this
6900 -- node (for example, see Attribute_Max_Size_In_Storage_Elements in
6901 -- Expand_N_Attribute_Reference).
6903 if Nkind
(N
) /= N_Attribute_Reference
6904 and then (not Is_Entity_Name
(N
)
6905 or else Treat_As_Volatile
(Entity
(N
)))
6907 Force_Evaluation
(N
, Mode
=> Strict
);
6910 -- The easiest case is when Source_Base_Type and Target_Base_Type are
6911 -- the same since in this case we can simply do a direct check of the
6912 -- value of N against the bounds of Target_Type.
6914 -- [constraint_error when N not in Target_Type]
6916 -- Note: this is by far the most common case, for example all cases of
6917 -- checks on the RHS of assignments are in this category, but not all
6918 -- cases are like this. Notably conversions can involve two types.
6920 if Source_Base_Type
= Target_Base_Type
then
6922 -- Insert the explicit range check. Note that we suppress checks for
6923 -- this code, since we don't want a recursive range check popping up.
6926 Make_Raise_Constraint_Error
(Loc
,
6929 Left_Opnd
=> Duplicate_Subexpr
(N
),
6930 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
6932 Suppress
=> All_Checks
);
6934 -- Next test for the case where the target type is within the bounds
6935 -- of the base type of the source type, since in this case we can
6936 -- simply convert these bounds to the base type of T to do the test.
6938 -- [constraint_error when N not in
6939 -- Source_Base_Type (Target_Type'First)
6941 -- Source_Base_Type(Target_Type'Last))]
6943 -- The conversions will always work and need no check
6945 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
6946 -- of converting from an enumeration value to an integer type, such as
6947 -- occurs for the case of generating a range check on Enum'Val(Exp)
6948 -- (which used to be handled by gigi). This is OK, since the conversion
6949 -- itself does not require a check.
6951 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
6953 -- Insert the explicit range check. Note that we suppress checks for
6954 -- this code, since we don't want a recursive range check popping up.
6956 if Is_Discrete_Type
(Source_Base_Type
)
6958 Is_Discrete_Type
(Target_Base_Type
)
6961 Make_Raise_Constraint_Error
(Loc
,
6964 Left_Opnd
=> Duplicate_Subexpr
(N
),
6969 Unchecked_Convert_To
(Source_Base_Type
,
6970 Make_Attribute_Reference
(Loc
,
6972 New_Occurrence_Of
(Target_Type
, Loc
),
6973 Attribute_Name
=> Name_First
)),
6976 Unchecked_Convert_To
(Source_Base_Type
,
6977 Make_Attribute_Reference
(Loc
,
6979 New_Occurrence_Of
(Target_Type
, Loc
),
6980 Attribute_Name
=> Name_Last
)))),
6982 Suppress
=> All_Checks
);
6984 -- For conversions involving at least one type that is not discrete,
6985 -- first convert to target type and then generate the range check.
6986 -- This avoids problems with values that are close to a bound of the
6987 -- target type that would fail a range check when done in a larger
6988 -- source type before converting but would pass if converted with
6989 -- rounding and then checked (such as in float-to-float conversions).
6992 Convert_And_Check_Range
;
6995 -- Note that at this stage we now that the Target_Base_Type is not in
6996 -- the range of the Source_Base_Type (since even the Target_Type itself
6997 -- is not in this range). It could still be the case that Source_Type is
6998 -- in range of the target base type since we have not checked that case.
7000 -- If that is the case, we can freely convert the source to the target,
7001 -- and then test the target result against the bounds.
7003 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
7004 Convert_And_Check_Range
;
7006 -- At this stage, we know that we have two scalar types, which are
7007 -- directly convertible, and where neither scalar type has a base
7008 -- range that is in the range of the other scalar type.
7010 -- The only way this can happen is with a signed and unsigned type.
7011 -- So test for these two cases:
7014 -- Case of the source is unsigned and the target is signed
7016 if Is_Unsigned_Type
(Source_Base_Type
)
7017 and then not Is_Unsigned_Type
(Target_Base_Type
)
7019 -- If the source is unsigned and the target is signed, then we
7020 -- know that the source is not shorter than the target (otherwise
7021 -- the source base type would be in the target base type range).
7023 -- In other words, the unsigned type is either the same size as
7024 -- the target, or it is larger. It cannot be smaller.
7027 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
7029 -- We only need to check the low bound if the low bound of the
7030 -- target type is non-negative. If the low bound of the target
7031 -- type is negative, then we know that we will fit fine.
7033 -- If the high bound of the target type is negative, then we
7034 -- know we have a constraint error, since we can't possibly
7035 -- have a negative source.
7037 -- With these two checks out of the way, we can do the check
7038 -- using the source type safely
7040 -- This is definitely the most annoying case.
7042 -- [constraint_error
7043 -- when (Target_Type'First >= 0
7045 -- N < Source_Base_Type (Target_Type'First))
7046 -- or else Target_Type'Last < 0
7047 -- or else N > Source_Base_Type (Target_Type'Last)];
7049 -- We turn off all checks since we know that the conversions
7050 -- will work fine, given the guards for negative values.
7053 Make_Raise_Constraint_Error
(Loc
,
7059 Left_Opnd
=> Make_Op_Ge
(Loc
,
7061 Make_Attribute_Reference
(Loc
,
7063 New_Occurrence_Of
(Target_Type
, Loc
),
7064 Attribute_Name
=> Name_First
),
7065 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
7069 Left_Opnd
=> Duplicate_Subexpr
(N
),
7071 Convert_To
(Source_Base_Type
,
7072 Make_Attribute_Reference
(Loc
,
7074 New_Occurrence_Of
(Target_Type
, Loc
),
7075 Attribute_Name
=> Name_First
)))),
7080 Make_Attribute_Reference
(Loc
,
7081 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
7082 Attribute_Name
=> Name_Last
),
7083 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
7087 Left_Opnd
=> Duplicate_Subexpr
(N
),
7089 Convert_To
(Source_Base_Type
,
7090 Make_Attribute_Reference
(Loc
,
7091 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
7092 Attribute_Name
=> Name_Last
)))),
7095 Suppress
=> All_Checks
);
7097 -- Only remaining possibility is that the source is signed and
7098 -- the target is unsigned.
7101 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
7102 and then Is_Unsigned_Type
(Target_Base_Type
));
7104 -- If the source is signed and the target is unsigned, then we
7105 -- know that the target is not shorter than the source (otherwise
7106 -- the target base type would be in the source base type range).
7108 -- In other words, the unsigned type is either the same size as
7109 -- the target, or it is larger. It cannot be smaller.
7111 -- Clearly we have an error if the source value is negative since
7112 -- no unsigned type can have negative values. If the source type
7113 -- is non-negative, then the check can be done using the target
7116 -- Tnn : constant Target_Base_Type (N) := Target_Type;
7118 -- [constraint_error
7119 -- when N < 0 or else Tnn not in Target_Type];
7121 -- We turn off all checks for the conversion of N to the target
7122 -- base type, since we generate the explicit check to ensure that
7123 -- the value is non-negative
7126 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
7129 Insert_Actions
(N
, New_List
(
7130 Make_Object_Declaration
(Loc
,
7131 Defining_Identifier
=> Tnn
,
7132 Object_Definition
=>
7133 New_Occurrence_Of
(Target_Base_Type
, Loc
),
7134 Constant_Present
=> True,
7136 Make_Unchecked_Type_Conversion
(Loc
,
7138 New_Occurrence_Of
(Target_Base_Type
, Loc
),
7139 Expression
=> Duplicate_Subexpr
(N
))),
7141 Make_Raise_Constraint_Error
(Loc
,
7146 Left_Opnd
=> Duplicate_Subexpr
(N
),
7147 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
7151 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
7153 New_Occurrence_Of
(Target_Type
, Loc
))),
7156 Suppress
=> All_Checks
);
7158 -- Set the Etype explicitly, because Insert_Actions may have
7159 -- placed the declaration in the freeze list for an enclosing
7160 -- construct, and thus it is not analyzed yet.
7162 Set_Etype
(Tnn
, Target_Base_Type
);
7163 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
7167 end Generate_Range_Check
;
7173 function Get_Check_Id
(N
: Name_Id
) return Check_Id
is
7175 -- For standard check name, we can do a direct computation
7177 if N
in First_Check_Name
.. Last_Check_Name
then
7178 return Check_Id
(N
- (First_Check_Name
- 1));
7180 -- For non-standard names added by pragma Check_Name, search table
7183 for J
in All_Checks
+ 1 .. Check_Names
.Last
loop
7184 if Check_Names
.Table
(J
) = N
then
7190 -- No matching name found
7195 ---------------------
7196 -- Get_Discriminal --
7197 ---------------------
7199 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
7200 Loc
: constant Source_Ptr
:= Sloc
(E
);
7205 -- The bound can be a bona fide parameter of a protected operation,
7206 -- rather than a prival encoded as an in-parameter.
7208 if No
(Discriminal_Link
(Entity
(Bound
))) then
7212 -- Climb the scope stack looking for an enclosing protected type. If
7213 -- we run out of scopes, return the bound itself.
7216 while Present
(Sc
) loop
7217 if Sc
= Standard_Standard
then
7219 elsif Ekind
(Sc
) = E_Protected_Type
then
7226 D
:= First_Discriminant
(Sc
);
7227 while Present
(D
) loop
7228 if Chars
(D
) = Chars
(Bound
) then
7229 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
7232 Next_Discriminant
(D
);
7236 end Get_Discriminal
;
7238 ----------------------
7239 -- Get_Range_Checks --
7240 ----------------------
7242 function Get_Range_Checks
7244 Target_Typ
: Entity_Id
;
7245 Source_Typ
: Entity_Id
:= Empty
;
7246 Warn_Node
: Node_Id
:= Empty
) return Check_Result
7250 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Warn_Node
);
7251 end Get_Range_Checks
;
7257 function Guard_Access
7260 Ck_Node
: Node_Id
) return Node_Id
7263 if Nkind
(Cond
) = N_Or_Else
then
7264 Set_Paren_Count
(Cond
, 1);
7267 if Nkind
(Ck_Node
) = N_Allocator
then
7275 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
7276 Right_Opnd
=> Make_Null
(Loc
)),
7277 Right_Opnd
=> Cond
);
7281 -----------------------------
7282 -- Index_Checks_Suppressed --
7283 -----------------------------
7285 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7287 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7288 return Is_Check_Suppressed
(E
, Index_Check
);
7290 return Scope_Suppress
.Suppress
(Index_Check
);
7292 end Index_Checks_Suppressed
;
7298 procedure Initialize
is
7300 for J
in Determine_Range_Cache_N
'Range loop
7301 Determine_Range_Cache_N
(J
) := Empty
;
7306 for J
in Int
range 1 .. All_Checks
loop
7307 Check_Names
.Append
(Name_Id
(Int
(First_Check_Name
) + J
- 1));
7311 -------------------------
7312 -- Insert_Range_Checks --
7313 -------------------------
7315 procedure Insert_Range_Checks
7316 (Checks
: Check_Result
;
7318 Suppress_Typ
: Entity_Id
;
7319 Static_Sloc
: Source_Ptr
:= No_Location
;
7320 Flag_Node
: Node_Id
:= Empty
;
7321 Do_Before
: Boolean := False)
7323 Checks_On
: constant Boolean :=
7324 not Index_Checks_Suppressed
(Suppress_Typ
)
7326 not Range_Checks_Suppressed
(Suppress_Typ
);
7328 Check_Node
: Node_Id
;
7329 Internal_Flag_Node
: Node_Id
:= Flag_Node
;
7330 Internal_Static_Sloc
: Source_Ptr
:= Static_Sloc
;
7333 -- For now we just return if Checks_On is false, however this should be
7334 -- enhanced to check for an always True value in the condition and to
7335 -- generate a compilation warning???
7337 if not Expander_Active
or not Checks_On
then
7341 if Static_Sloc
= No_Location
then
7342 Internal_Static_Sloc
:= Sloc
(Node
);
7345 if No
(Flag_Node
) then
7346 Internal_Flag_Node
:= Node
;
7349 for J
in 1 .. 2 loop
7350 exit when No
(Checks
(J
));
7352 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
7353 and then Present
(Condition
(Checks
(J
)))
7355 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
7356 Check_Node
:= Checks
(J
);
7357 Mark_Rewrite_Insertion
(Check_Node
);
7360 Insert_Before_And_Analyze
(Node
, Check_Node
);
7362 Insert_After_And_Analyze
(Node
, Check_Node
);
7365 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
7370 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
7371 Reason
=> CE_Range_Check_Failed
);
7372 Mark_Rewrite_Insertion
(Check_Node
);
7375 Insert_Before_And_Analyze
(Node
, Check_Node
);
7377 Insert_After_And_Analyze
(Node
, Check_Node
);
7381 end Insert_Range_Checks
;
7383 ------------------------
7384 -- Insert_Valid_Check --
7385 ------------------------
7387 procedure Insert_Valid_Check
7389 Related_Id
: Entity_Id
:= Empty
;
7390 Is_Low_Bound
: Boolean := False;
7391 Is_High_Bound
: Boolean := False)
7393 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
7394 Typ
: constant Entity_Id
:= Etype
(Expr
);
7398 -- Do not insert if checks off, or if not checking validity or if
7399 -- expression is known to be valid.
7401 if not Validity_Checks_On
7402 or else Range_Or_Validity_Checks_Suppressed
(Expr
)
7403 or else Expr_Known_Valid
(Expr
)
7407 -- Do not insert checks within a predicate function. This will arise
7408 -- if the current unit and the predicate function are being compiled
7409 -- with validity checks enabled.
7411 elsif Present
(Predicate_Function
(Typ
))
7412 and then Current_Scope
= Predicate_Function
(Typ
)
7416 -- If the expression is a packed component of a modular type of the
7417 -- right size, the data is always valid.
7419 elsif Nkind
(Expr
) = N_Selected_Component
7420 and then Present
(Component_Clause
(Entity
(Selector_Name
(Expr
))))
7421 and then Is_Modular_Integer_Type
(Typ
)
7422 and then Modulus
(Typ
) = 2 ** Esize
(Entity
(Selector_Name
(Expr
)))
7426 -- Do not generate a validity check when inside a generic unit as this
7427 -- is an expansion activity.
7429 elsif Inside_A_Generic
then
7433 -- If we have a checked conversion, then validity check applies to
7434 -- the expression inside the conversion, not the result, since if
7435 -- the expression inside is valid, then so is the conversion result.
7438 while Nkind
(Exp
) = N_Type_Conversion
loop
7439 Exp
:= Expression
(Exp
);
7442 -- Do not generate a check for a variable which already validates the
7443 -- value of an assignable object.
7445 if Is_Validation_Variable_Reference
(Exp
) then
7455 -- If the expression denotes an assignable object, capture its value
7456 -- in a variable and replace the original expression by the variable.
7457 -- This approach has several effects:
7459 -- 1) The evaluation of the object results in only one read in the
7460 -- case where the object is atomic or volatile.
7462 -- Var ... := Object; -- read
7464 -- 2) The captured value is the one verified by attribute 'Valid.
7465 -- As a result the object is not evaluated again, which would
7466 -- result in an unwanted read in the case where the object is
7467 -- atomic or volatile.
7469 -- if not Var'Valid then -- OK, no read of Object
7471 -- if not Object'Valid then -- Wrong, extra read of Object
7473 -- 3) The captured value replaces the original object reference.
7474 -- As a result the object is not evaluated again, in the same
7477 -- ... Var ... -- OK, no read of Object
7479 -- ... Object ... -- Wrong, extra read of Object
7481 -- 4) The use of a variable to capture the value of the object
7482 -- allows the propagation of any changes back to the original
7485 -- procedure Call (Val : in out ...);
7487 -- Var : ... := Object; -- read Object
7488 -- if not Var'Valid then -- validity check
7489 -- Call (Var); -- modify Var
7490 -- Object := Var; -- update Object
7492 if Is_Variable
(Exp
) then
7493 Var_Id
:= Make_Temporary
(Loc
, 'T', Exp
);
7495 -- Because we could be dealing with a transient scope which would
7496 -- cause our object declaration to remain unanalyzed we must do
7497 -- some manual decoration.
7499 Set_Ekind
(Var_Id
, E_Variable
);
7500 Set_Etype
(Var_Id
, Typ
);
7503 Make_Object_Declaration
(Loc
,
7504 Defining_Identifier
=> Var_Id
,
7505 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
7506 Expression
=> New_Copy_Tree
(Exp
)),
7507 Suppress
=> Validity_Check
);
7509 Set_Validated_Object
(Var_Id
, New_Copy_Tree
(Exp
));
7510 Rewrite
(Exp
, New_Occurrence_Of
(Var_Id
, Loc
));
7511 PV
:= New_Occurrence_Of
(Var_Id
, Loc
);
7513 -- Copy the Do_Range_Check flag over to the new Exp, so it doesn't
7514 -- get lost. Floating point types are handled elsewhere.
7516 if not Is_Floating_Point_Type
(Typ
) then
7517 Set_Do_Range_Check
(Exp
, Do_Range_Check
(Original_Node
(Exp
)));
7520 -- Otherwise the expression does not denote a variable. Force its
7521 -- evaluation by capturing its value in a constant. Generate:
7523 -- Temp : constant ... := Exp;
7528 Related_Id
=> Related_Id
,
7529 Is_Low_Bound
=> Is_Low_Bound
,
7530 Is_High_Bound
=> Is_High_Bound
);
7532 PV
:= New_Copy_Tree
(Exp
);
7535 -- A rather specialized test. If PV is an analyzed expression which
7536 -- is an indexed component of a packed array that has not been
7537 -- properly expanded, turn off its Analyzed flag to make sure it
7538 -- gets properly reexpanded. If the prefix is an access value,
7539 -- the dereference will be added later.
7541 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
7542 -- an analyze with the old parent pointer. This may point e.g. to
7543 -- a subprogram call, which deactivates this expansion.
7546 and then Nkind
(PV
) = N_Indexed_Component
7547 and then Is_Array_Type
(Etype
(Prefix
(PV
)))
7548 and then Present
(Packed_Array_Impl_Type
(Etype
(Prefix
(PV
))))
7550 Set_Analyzed
(PV
, False);
7553 -- Build the raise CE node to check for validity. We build a type
7554 -- qualification for the prefix, since it may not be of the form of
7555 -- a name, and we don't care in this context!
7558 Make_Raise_Constraint_Error
(Loc
,
7562 Make_Attribute_Reference
(Loc
,
7564 Attribute_Name
=> Name_Valid
)),
7565 Reason
=> CE_Invalid_Data
);
7567 -- Insert the validity check. Note that we do this with validity
7568 -- checks turned off, to avoid recursion, we do not want validity
7569 -- checks on the validity checking code itself.
7571 Insert_Action
(Expr
, CE
, Suppress
=> Validity_Check
);
7573 -- If the expression is a reference to an element of a bit-packed
7574 -- array, then it is rewritten as a renaming declaration. If the
7575 -- expression is an actual in a call, it has not been expanded,
7576 -- waiting for the proper point at which to do it. The same happens
7577 -- with renamings, so that we have to force the expansion now. This
7578 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
7581 if Is_Entity_Name
(Exp
)
7582 and then Nkind
(Parent
(Entity
(Exp
))) =
7583 N_Object_Renaming_Declaration
7586 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
7588 if Nkind
(Old_Exp
) = N_Indexed_Component
7589 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
7591 Expand_Packed_Element_Reference
(Old_Exp
);
7596 end Insert_Valid_Check
;
7598 -------------------------------------
7599 -- Is_Signed_Integer_Arithmetic_Op --
7600 -------------------------------------
7602 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean is
7616 return Is_Signed_Integer_Type
(Etype
(N
));
7618 when N_Case_Expression
7621 return Is_Signed_Integer_Type
(Etype
(N
));
7626 end Is_Signed_Integer_Arithmetic_Op
;
7628 ----------------------------------
7629 -- Install_Null_Excluding_Check --
7630 ----------------------------------
7632 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
7633 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
7634 Typ
: constant Entity_Id
:= Etype
(N
);
7636 function Safe_To_Capture_In_Parameter_Value
return Boolean;
7637 -- Determines if it is safe to capture Known_Non_Null status for an
7638 -- the entity referenced by node N. The caller ensures that N is indeed
7639 -- an entity name. It is safe to capture the non-null status for an IN
7640 -- parameter when the reference occurs within a declaration that is sure
7641 -- to be executed as part of the declarative region.
7643 procedure Mark_Non_Null
;
7644 -- After installation of check, if the node in question is an entity
7645 -- name, then mark this entity as non-null if possible.
7647 function Safe_To_Capture_In_Parameter_Value
return Boolean is
7648 E
: constant Entity_Id
:= Entity
(N
);
7649 S
: constant Entity_Id
:= Current_Scope
;
7653 if Ekind
(E
) /= E_In_Parameter
then
7657 -- Two initial context checks. We must be inside a subprogram body
7658 -- with declarations and reference must not appear in nested scopes.
7660 if (Ekind
(S
) /= E_Function
and then Ekind
(S
) /= E_Procedure
)
7661 or else Scope
(E
) /= S
7666 S_Par
:= Parent
(Parent
(S
));
7668 if Nkind
(S_Par
) /= N_Subprogram_Body
7669 or else No
(Declarations
(S_Par
))
7679 -- Retrieve the declaration node of N (if any). Note that N
7680 -- may be a part of a complex initialization expression.
7684 while Present
(P
) loop
7686 -- If we have a short circuit form, and we are within the right
7687 -- hand expression, we return false, since the right hand side
7688 -- is not guaranteed to be elaborated.
7690 if Nkind
(P
) in N_Short_Circuit
7691 and then N
= Right_Opnd
(P
)
7696 -- Similarly, if we are in an if expression and not part of the
7697 -- condition, then we return False, since neither the THEN or
7698 -- ELSE dependent expressions will always be elaborated.
7700 if Nkind
(P
) = N_If_Expression
7701 and then N
/= First
(Expressions
(P
))
7706 -- If within a case expression, and not part of the expression,
7707 -- then return False, since a particular dependent expression
7708 -- may not always be elaborated
7710 if Nkind
(P
) = N_Case_Expression
7711 and then N
/= Expression
(P
)
7716 -- While traversing the parent chain, if node N belongs to a
7717 -- statement, then it may never appear in a declarative region.
7719 if Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
7720 or else Nkind
(P
) = N_Procedure_Call_Statement
7725 -- If we are at a declaration, record it and exit
7727 if Nkind
(P
) in N_Declaration
7728 and then Nkind
(P
) not in N_Subprogram_Specification
7741 return List_Containing
(N_Decl
) = Declarations
(S_Par
);
7743 end Safe_To_Capture_In_Parameter_Value
;
7749 procedure Mark_Non_Null
is
7751 -- Only case of interest is if node N is an entity name
7753 if Is_Entity_Name
(N
) then
7755 -- For sure, we want to clear an indication that this is known to
7756 -- be null, since if we get past this check, it definitely is not.
7758 Set_Is_Known_Null
(Entity
(N
), False);
7760 -- We can mark the entity as known to be non-null if either it is
7761 -- safe to capture the value, or in the case of an IN parameter,
7762 -- which is a constant, if the check we just installed is in the
7763 -- declarative region of the subprogram body. In this latter case,
7764 -- a check is decisive for the rest of the body if the expression
7765 -- is sure to be elaborated, since we know we have to elaborate
7766 -- all declarations before executing the body.
7768 -- Couldn't this always be part of Safe_To_Capture_Value ???
7770 if Safe_To_Capture_Value
(N
, Entity
(N
))
7771 or else Safe_To_Capture_In_Parameter_Value
7773 Set_Is_Known_Non_Null
(Entity
(N
));
7778 -- Start of processing for Install_Null_Excluding_Check
7781 -- No need to add null-excluding checks when the tree may not be fully
7784 if Serious_Errors_Detected
> 0 then
7788 pragma Assert
(Is_Access_Type
(Typ
));
7790 -- No check inside a generic, check will be emitted in instance
7792 if Inside_A_Generic
then
7796 -- No check needed if known to be non-null
7798 if Known_Non_Null
(N
) then
7802 -- If known to be null, here is where we generate a compile time check
7804 if Known_Null
(N
) then
7806 -- Avoid generating warning message inside init procs. In SPARK mode
7807 -- we can go ahead and call Apply_Compile_Time_Constraint_Error
7808 -- since it will be turned into an error in any case.
7810 if (not Inside_Init_Proc
or else SPARK_Mode
= On
)
7812 -- Do not emit the warning within a conditional expression,
7813 -- where the expression might not be evaluated, and the warning
7814 -- appear as extraneous noise.
7816 and then not Within_Case_Or_If_Expression
(N
)
7818 Apply_Compile_Time_Constraint_Error
7819 (N
, "null value not allowed here??", CE_Access_Check_Failed
);
7821 -- Remaining cases, where we silently insert the raise
7825 Make_Raise_Constraint_Error
(Loc
,
7826 Reason
=> CE_Access_Check_Failed
));
7833 -- If entity is never assigned, for sure a warning is appropriate
7835 if Is_Entity_Name
(N
) then
7836 Check_Unset_Reference
(N
);
7839 -- No check needed if checks are suppressed on the range. Note that we
7840 -- don't set Is_Known_Non_Null in this case (we could legitimately do
7841 -- so, since the program is erroneous, but we don't like to casually
7842 -- propagate such conclusions from erroneosity).
7844 if Access_Checks_Suppressed
(Typ
) then
7848 -- No check needed for access to concurrent record types generated by
7849 -- the expander. This is not just an optimization (though it does indeed
7850 -- remove junk checks). It also avoids generation of junk warnings.
7852 if Nkind
(N
) in N_Has_Chars
7853 and then Chars
(N
) = Name_uObject
7854 and then Is_Concurrent_Record_Type
7855 (Directly_Designated_Type
(Etype
(N
)))
7860 -- No check needed in interface thunks since the runtime check is
7861 -- already performed at the caller side.
7863 if Is_Thunk
(Current_Scope
) then
7867 -- No check needed for the Get_Current_Excep.all.all idiom generated by
7868 -- the expander within exception handlers, since we know that the value
7869 -- can never be null.
7871 -- Is this really the right way to do this? Normally we generate such
7872 -- code in the expander with checks off, and that's how we suppress this
7873 -- kind of junk check ???
7875 if Nkind
(N
) = N_Function_Call
7876 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
7877 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
7878 and then Is_RTE
(Entity
(Prefix
(Name
(N
))), RE_Get_Current_Excep
)
7883 -- Otherwise install access check
7886 Make_Raise_Constraint_Error
(Loc
,
7889 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
7890 Right_Opnd
=> Make_Null
(Loc
)),
7891 Reason
=> CE_Access_Check_Failed
));
7894 end Install_Null_Excluding_Check
;
7896 -----------------------------------------
7897 -- Install_Primitive_Elaboration_Check --
7898 -----------------------------------------
7900 procedure Install_Primitive_Elaboration_Check
(Subp_Body
: Node_Id
) is
7901 function Within_Compilation_Unit_Instance
7902 (Subp_Id
: Entity_Id
) return Boolean;
7903 -- Determine whether subprogram Subp_Id appears within an instance which
7904 -- acts as a compilation unit.
7906 --------------------------------------
7907 -- Within_Compilation_Unit_Instance --
7908 --------------------------------------
7910 function Within_Compilation_Unit_Instance
7911 (Subp_Id
: Entity_Id
) return Boolean
7916 -- Examine the scope chain looking for a compilation-unit-level
7919 Pack
:= Scope
(Subp_Id
);
7920 while Present
(Pack
) and then Pack
/= Standard_Standard
loop
7921 if Ekind
(Pack
) = E_Package
7922 and then Is_Generic_Instance
(Pack
)
7923 and then Nkind
(Parent
(Unit_Declaration_Node
(Pack
))) =
7929 Pack
:= Scope
(Pack
);
7933 end Within_Compilation_Unit_Instance
;
7935 -- Local declarations
7937 Context
: constant Node_Id
:= Parent
(Subp_Body
);
7938 Loc
: constant Source_Ptr
:= Sloc
(Subp_Body
);
7939 Subp_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Body
);
7940 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
7943 Flag_Id
: Entity_Id
;
7946 Tag_Typ
: Entity_Id
;
7948 -- Start of processing for Install_Primitive_Elaboration_Check
7951 -- Do not generate an elaboration check in compilation modes where
7952 -- expansion is not desirable.
7954 if ASIS_Mode
or GNATprove_Mode
then
7957 -- Do not generate an elaboration check if all checks have been
7960 elsif Suppress_Checks
then
7963 -- Do not generate an elaboration check if the related subprogram is
7964 -- not subjected to accessibility checks.
7966 elsif Elaboration_Checks_Suppressed
(Subp_Id
) then
7969 -- Do not generate an elaboration check if such code is not desirable
7971 elsif Restriction_Active
(No_Elaboration_Code
) then
7974 -- Do not generate an elaboration check if exceptions cannot be used,
7975 -- caught, or propagated.
7977 elsif not Exceptions_OK
then
7980 -- Do not consider subprograms which act as compilation units, because
7981 -- they cannot be the target of a dispatching call.
7983 elsif Nkind
(Context
) = N_Compilation_Unit
then
7986 -- Do not consider anything other than nonabstract library-level source
7990 (Comes_From_Source
(Subp_Id
)
7991 and then Is_Library_Level_Entity
(Subp_Id
)
7992 and then Is_Primitive
(Subp_Id
)
7993 and then not Is_Abstract_Subprogram
(Subp_Id
))
7997 -- Do not consider inlined primitives, because once the body is inlined
7998 -- the reference to the elaboration flag will be out of place and will
7999 -- result in an undefined symbol.
8001 elsif Is_Inlined
(Subp_Id
) or else Has_Pragma_Inline
(Subp_Id
) then
8004 -- Do not generate a duplicate elaboration check. This happens only in
8005 -- the case of primitives completed by an expression function, as the
8006 -- corresponding body is apparently analyzed and expanded twice.
8008 elsif Analyzed
(Subp_Body
) then
8011 -- Do not consider primitives which occur within an instance that acts
8012 -- as a compilation unit. Such an instance defines its spec and body out
8013 -- of order (body is first) within the tree, which causes the reference
8014 -- to the elaboration flag to appear as an undefined symbol.
8016 elsif Within_Compilation_Unit_Instance
(Subp_Id
) then
8020 Tag_Typ
:= Find_Dispatching_Type
(Subp_Id
);
8022 -- Only tagged primitives may be the target of a dispatching call
8024 if No
(Tag_Typ
) then
8027 -- Do not consider finalization-related primitives, because they may
8028 -- need to be called while elaboration is taking place.
8030 elsif Is_Controlled
(Tag_Typ
)
8031 and then Nam_In
(Chars
(Subp_Id
), Name_Adjust
,
8038 -- Create the declaration of the elaboration flag. The name carries a
8039 -- unique counter in case of name overloading.
8042 Make_Defining_Identifier
(Loc
,
8043 Chars
=> New_External_Name
(Chars
(Subp_Id
), 'E', -1));
8044 Set_Is_Frozen
(Flag_Id
);
8046 -- Insert the declaration of the elaboration flag in front of the
8047 -- primitive spec and analyze it in the proper context.
8049 Push_Scope
(Scope
(Subp_Id
));
8052 -- E : Boolean := False;
8054 Insert_Action
(Subp_Decl
,
8055 Make_Object_Declaration
(Loc
,
8056 Defining_Identifier
=> Flag_Id
,
8057 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8058 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
8061 -- Prevent the compiler from optimizing the elaboration check by killing
8062 -- the current value of the flag and the associated assignment.
8064 Set_Current_Value
(Flag_Id
, Empty
);
8065 Set_Last_Assignment
(Flag_Id
, Empty
);
8067 -- Add a check at the top of the body declarations to ensure that the
8068 -- elaboration flag has been set.
8070 Decls
:= Declarations
(Subp_Body
);
8074 Set_Declarations
(Subp_Body
, Decls
);
8079 -- raise Program_Error with "access before elaboration";
8083 Make_Raise_Program_Error
(Loc
,
8086 Right_Opnd
=> New_Occurrence_Of
(Flag_Id
, Loc
)),
8087 Reason
=> PE_Access_Before_Elaboration
));
8089 Analyze
(First
(Decls
));
8091 -- Set the elaboration flag once the body has been elaborated. Insert
8092 -- the statement after the subprogram stub when the primitive body is
8095 if Nkind
(Context
) = N_Subunit
then
8096 Set_Ins
:= Corresponding_Stub
(Context
);
8098 Set_Ins
:= Subp_Body
;
8105 Make_Assignment_Statement
(Loc
,
8106 Name
=> New_Occurrence_Of
(Flag_Id
, Loc
),
8107 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
));
8109 -- Mark the assignment statement as elaboration code. This allows the
8110 -- early call region mechanism (see Sem_Elab) to properly ignore such
8111 -- assignments even though they are non-preelaborable code.
8113 Set_Is_Elaboration_Code
(Set_Stmt
);
8115 Insert_After_And_Analyze
(Set_Ins
, Set_Stmt
);
8116 end Install_Primitive_Elaboration_Check
;
8118 --------------------------
8119 -- Install_Static_Check --
8120 --------------------------
8122 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
8123 Stat
: constant Boolean := Is_OK_Static_Expression
(R_Cno
);
8124 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
8128 Make_Raise_Constraint_Error
(Loc
,
8129 Reason
=> CE_Range_Check_Failed
));
8130 Set_Analyzed
(R_Cno
);
8131 Set_Etype
(R_Cno
, Typ
);
8132 Set_Raises_Constraint_Error
(R_Cno
);
8133 Set_Is_Static_Expression
(R_Cno
, Stat
);
8135 -- Now deal with possible local raise handling
8137 Possible_Local_Raise
(R_Cno
, Standard_Constraint_Error
);
8138 end Install_Static_Check
;
8140 -------------------------
8141 -- Is_Check_Suppressed --
8142 -------------------------
8144 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
8145 Ptr
: Suppress_Stack_Entry_Ptr
;
8148 -- First search the local entity suppress stack. We search this from the
8149 -- top of the stack down so that we get the innermost entry that applies
8150 -- to this case if there are nested entries.
8152 Ptr
:= Local_Suppress_Stack_Top
;
8153 while Ptr
/= null loop
8154 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
8155 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
8157 return Ptr
.Suppress
;
8163 -- Now search the global entity suppress table for a matching entry.
8164 -- We also search this from the top down so that if there are multiple
8165 -- pragmas for the same entity, the last one applies (not clear what
8166 -- or whether the RM specifies this handling, but it seems reasonable).
8168 Ptr
:= Global_Suppress_Stack_Top
;
8169 while Ptr
/= null loop
8170 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
8171 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
8173 return Ptr
.Suppress
;
8179 -- If we did not find a matching entry, then use the normal scope
8180 -- suppress value after all (actually this will be the global setting
8181 -- since it clearly was not overridden at any point). For a predefined
8182 -- check, we test the specific flag. For a user defined check, we check
8183 -- the All_Checks flag. The Overflow flag requires special handling to
8184 -- deal with the General vs Assertion case.
8186 if C
= Overflow_Check
then
8187 return Overflow_Checks_Suppressed
(Empty
);
8189 elsif C
in Predefined_Check_Id
then
8190 return Scope_Suppress
.Suppress
(C
);
8193 return Scope_Suppress
.Suppress
(All_Checks
);
8195 end Is_Check_Suppressed
;
8197 ---------------------
8198 -- Kill_All_Checks --
8199 ---------------------
8201 procedure Kill_All_Checks
is
8203 if Debug_Flag_CC
then
8204 w
("Kill_All_Checks");
8207 -- We reset the number of saved checks to zero, and also modify all
8208 -- stack entries for statement ranges to indicate that the number of
8209 -- checks at each level is now zero.
8211 Num_Saved_Checks
:= 0;
8213 -- Note: the Int'Min here avoids any possibility of J being out of
8214 -- range when called from e.g. Conditional_Statements_Begin.
8216 for J
in 1 .. Int
'Min (Saved_Checks_TOS
, Saved_Checks_Stack
'Last) loop
8217 Saved_Checks_Stack
(J
) := 0;
8219 end Kill_All_Checks
;
8225 procedure Kill_Checks
(V
: Entity_Id
) is
8227 if Debug_Flag_CC
then
8228 w
("Kill_Checks for entity", Int
(V
));
8231 for J
in 1 .. Num_Saved_Checks
loop
8232 if Saved_Checks
(J
).Entity
= V
then
8233 if Debug_Flag_CC
then
8234 w
(" Checks killed for saved check ", J
);
8237 Saved_Checks
(J
).Killed
:= True;
8242 ------------------------------
8243 -- Length_Checks_Suppressed --
8244 ------------------------------
8246 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
8248 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
8249 return Is_Check_Suppressed
(E
, Length_Check
);
8251 return Scope_Suppress
.Suppress
(Length_Check
);
8253 end Length_Checks_Suppressed
;
8255 -----------------------
8256 -- Make_Bignum_Block --
8257 -----------------------
8259 function Make_Bignum_Block
(Loc
: Source_Ptr
) return Node_Id
is
8260 M
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uM
);
8263 Make_Block_Statement
(Loc
,
8265 New_List
(Build_SS_Mark_Call
(Loc
, M
)),
8266 Handled_Statement_Sequence
=>
8267 Make_Handled_Sequence_Of_Statements
(Loc
,
8268 Statements
=> New_List
(Build_SS_Release_Call
(Loc
, M
))));
8269 end Make_Bignum_Block
;
8271 ----------------------------------
8272 -- Minimize_Eliminate_Overflows --
8273 ----------------------------------
8275 -- This is a recursive routine that is called at the top of an expression
8276 -- tree to properly process overflow checking for a whole subtree by making
8277 -- recursive calls to process operands. This processing may involve the use
8278 -- of bignum or long long integer arithmetic, which will change the types
8279 -- of operands and results. That's why we can't do this bottom up (since
8280 -- it would interfere with semantic analysis).
8282 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
8283 -- the operator expansion routines, as well as the expansion routines for
8284 -- if/case expression, do nothing (for the moment) except call the routine
8285 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
8286 -- routine does nothing for non top-level nodes, so at the point where the
8287 -- call is made for the top level node, the entire expression subtree has
8288 -- not been expanded, or processed for overflow. All that has to happen as
8289 -- a result of the top level call to this routine.
8291 -- As noted above, the overflow processing works by making recursive calls
8292 -- for the operands, and figuring out what to do, based on the processing
8293 -- of these operands (e.g. if a bignum operand appears, the parent op has
8294 -- to be done in bignum mode), and the determined ranges of the operands.
8296 -- After possible rewriting of a constituent subexpression node, a call is
8297 -- made to either reexpand the node (if nothing has changed) or reanalyze
8298 -- the node (if it has been modified by the overflow check processing). The
8299 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
8300 -- a recursive call into the whole overflow apparatus, an important rule
8301 -- for this call is that the overflow handling mode must be temporarily set
8304 procedure Minimize_Eliminate_Overflows
8308 Top_Level
: Boolean)
8310 Rtyp
: constant Entity_Id
:= Etype
(N
);
8311 pragma Assert
(Is_Signed_Integer_Type
(Rtyp
));
8312 -- Result type, must be a signed integer type
8314 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
8315 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
8317 Loc
: constant Source_Ptr
:= Sloc
(N
);
8320 -- Ranges of values for right operand (operator case)
8322 Llo
: Uint
:= No_Uint
; -- initialize to prevent warning
8323 Lhi
: Uint
:= No_Uint
; -- initialize to prevent warning
8324 -- Ranges of values for left operand (operator case)
8326 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
8327 -- Operands and results are of this type when we convert
8329 LLLo
: constant Uint
:= Intval
(Type_Low_Bound
(LLIB
));
8330 LLHi
: constant Uint
:= Intval
(Type_High_Bound
(LLIB
));
8331 -- Bounds of Long_Long_Integer
8333 Binary
: constant Boolean := Nkind
(N
) in N_Binary_Op
;
8334 -- Indicates binary operator case
8337 -- Used in call to Determine_Range
8339 Bignum_Operands
: Boolean;
8340 -- Set True if one or more operands is already of type Bignum, meaning
8341 -- that for sure (regardless of Top_Level setting) we are committed to
8342 -- doing the operation in Bignum mode (or in the case of a case or if
8343 -- expression, converting all the dependent expressions to Bignum).
8345 Long_Long_Integer_Operands
: Boolean;
8346 -- Set True if one or more operands is already of type Long_Long_Integer
8347 -- which means that if the result is known to be in the result type
8348 -- range, then we must convert such operands back to the result type.
8350 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False);
8351 -- This is called when we have modified the node and we therefore need
8352 -- to reanalyze it. It is important that we reset the mode to STRICT for
8353 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
8354 -- we would reenter this routine recursively which would not be good.
8355 -- The argument Suppress is set True if we also want to suppress
8356 -- overflow checking for the reexpansion (this is set when we know
8357 -- overflow is not possible). Typ is the type for the reanalysis.
8359 procedure Reexpand
(Suppress
: Boolean := False);
8360 -- This is like Reanalyze, but does not do the Analyze step, it only
8361 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
8362 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
8363 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
8364 -- Note that skipping reanalysis is not just an optimization, testing
8365 -- has showed up several complex cases in which reanalyzing an already
8366 -- analyzed node causes incorrect behavior.
8368 function In_Result_Range
return Boolean;
8369 -- Returns True iff Lo .. Hi are within range of the result type
8371 procedure Max
(A
: in out Uint
; B
: Uint
);
8372 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
8374 procedure Min
(A
: in out Uint
; B
: Uint
);
8375 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
8377 ---------------------
8378 -- In_Result_Range --
8379 ---------------------
8381 function In_Result_Range
return Boolean is
8383 if Lo
= No_Uint
or else Hi
= No_Uint
then
8386 elsif Is_OK_Static_Subtype
(Etype
(N
)) then
8387 return Lo
>= Expr_Value
(Type_Low_Bound
(Rtyp
))
8389 Hi
<= Expr_Value
(Type_High_Bound
(Rtyp
));
8392 return Lo
>= Expr_Value
(Type_Low_Bound
(Base_Type
(Rtyp
)))
8394 Hi
<= Expr_Value
(Type_High_Bound
(Base_Type
(Rtyp
)));
8396 end In_Result_Range
;
8402 procedure Max
(A
: in out Uint
; B
: Uint
) is
8404 if A
= No_Uint
or else B
> A
then
8413 procedure Min
(A
: in out Uint
; B
: Uint
) is
8415 if A
= No_Uint
or else B
< A
then
8424 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False) is
8425 Svg
: constant Overflow_Mode_Type
:=
8426 Scope_Suppress
.Overflow_Mode_General
;
8427 Sva
: constant Overflow_Mode_Type
:=
8428 Scope_Suppress
.Overflow_Mode_Assertions
;
8429 Svo
: constant Boolean :=
8430 Scope_Suppress
.Suppress
(Overflow_Check
);
8433 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
8434 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
8437 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
8440 Analyze_And_Resolve
(N
, Typ
);
8442 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
8443 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
8444 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
8451 procedure Reexpand
(Suppress
: Boolean := False) is
8452 Svg
: constant Overflow_Mode_Type
:=
8453 Scope_Suppress
.Overflow_Mode_General
;
8454 Sva
: constant Overflow_Mode_Type
:=
8455 Scope_Suppress
.Overflow_Mode_Assertions
;
8456 Svo
: constant Boolean :=
8457 Scope_Suppress
.Suppress
(Overflow_Check
);
8460 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
8461 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
8462 Set_Analyzed
(N
, False);
8465 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
8470 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
8471 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
8472 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
8475 -- Start of processing for Minimize_Eliminate_Overflows
8478 -- Default initialize Lo and Hi since these are not guaranteed to be
8484 -- Case where we do not have a signed integer arithmetic operation
8486 if not Is_Signed_Integer_Arithmetic_Op
(N
) then
8488 -- Use the normal Determine_Range routine to get the range. We
8489 -- don't require operands to be valid, invalid values may result in
8490 -- rubbish results where the result has not been properly checked for
8491 -- overflow, that's fine.
8493 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> False);
8495 -- If Determine_Range did not work (can this in fact happen? Not
8496 -- clear but might as well protect), use type bounds.
8499 Lo
:= Intval
(Type_Low_Bound
(Base_Type
(Etype
(N
))));
8500 Hi
:= Intval
(Type_High_Bound
(Base_Type
(Etype
(N
))));
8503 -- If we don't have a binary operator, all we have to do is to set
8504 -- the Hi/Lo range, so we are done.
8508 -- Processing for if expression
8510 elsif Nkind
(N
) = N_If_Expression
then
8512 Then_DE
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
8513 Else_DE
: constant Node_Id
:= Next
(Then_DE
);
8516 Bignum_Operands
:= False;
8518 Minimize_Eliminate_Overflows
8519 (Then_DE
, Lo
, Hi
, Top_Level
=> False);
8521 if Lo
= No_Uint
then
8522 Bignum_Operands
:= True;
8525 Minimize_Eliminate_Overflows
8526 (Else_DE
, Rlo
, Rhi
, Top_Level
=> False);
8528 if Rlo
= No_Uint
then
8529 Bignum_Operands
:= True;
8531 Long_Long_Integer_Operands
:=
8532 Etype
(Then_DE
) = LLIB
or else Etype
(Else_DE
) = LLIB
;
8538 -- If at least one of our operands is now Bignum, we must rebuild
8539 -- the if expression to use Bignum operands. We will analyze the
8540 -- rebuilt if expression with overflow checks off, since once we
8541 -- are in bignum mode, we are all done with overflow checks.
8543 if Bignum_Operands
then
8545 Make_If_Expression
(Loc
,
8546 Expressions
=> New_List
(
8547 Remove_Head
(Expressions
(N
)),
8548 Convert_To_Bignum
(Then_DE
),
8549 Convert_To_Bignum
(Else_DE
)),
8550 Is_Elsif
=> Is_Elsif
(N
)));
8552 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
8554 -- If we have no Long_Long_Integer operands, then we are in result
8555 -- range, since it means that none of our operands felt the need
8556 -- to worry about overflow (otherwise it would have already been
8557 -- converted to long long integer or bignum). We reexpand to
8558 -- complete the expansion of the if expression (but we do not
8559 -- need to reanalyze).
8561 elsif not Long_Long_Integer_Operands
then
8562 Set_Do_Overflow_Check
(N
, False);
8565 -- Otherwise convert us to long long integer mode. Note that we
8566 -- don't need any further overflow checking at this level.
8569 Convert_To_And_Rewrite
(LLIB
, Then_DE
);
8570 Convert_To_And_Rewrite
(LLIB
, Else_DE
);
8571 Set_Etype
(N
, LLIB
);
8573 -- Now reanalyze with overflow checks off
8575 Set_Do_Overflow_Check
(N
, False);
8576 Reanalyze
(LLIB
, Suppress
=> True);
8582 -- Here for case expression
8584 elsif Nkind
(N
) = N_Case_Expression
then
8585 Bignum_Operands
:= False;
8586 Long_Long_Integer_Operands
:= False;
8592 -- Loop through expressions applying recursive call
8594 Alt
:= First
(Alternatives
(N
));
8595 while Present
(Alt
) loop
8597 Aexp
: constant Node_Id
:= Expression
(Alt
);
8600 Minimize_Eliminate_Overflows
8601 (Aexp
, Lo
, Hi
, Top_Level
=> False);
8603 if Lo
= No_Uint
then
8604 Bignum_Operands
:= True;
8605 elsif Etype
(Aexp
) = LLIB
then
8606 Long_Long_Integer_Operands
:= True;
8613 -- If we have no bignum or long long integer operands, it means
8614 -- that none of our dependent expressions could raise overflow.
8615 -- In this case, we simply return with no changes except for
8616 -- resetting the overflow flag, since we are done with overflow
8617 -- checks for this node. We will reexpand to get the needed
8618 -- expansion for the case expression, but we do not need to
8619 -- reanalyze, since nothing has changed.
8621 if not (Bignum_Operands
or Long_Long_Integer_Operands
) then
8622 Set_Do_Overflow_Check
(N
, False);
8623 Reexpand
(Suppress
=> True);
8625 -- Otherwise we are going to rebuild the case expression using
8626 -- either bignum or long long integer operands throughout.
8631 pragma Warnings
(Off
, Rtype
);
8636 New_Alts
:= New_List
;
8637 Alt
:= First
(Alternatives
(N
));
8638 while Present
(Alt
) loop
8639 if Bignum_Operands
then
8640 New_Exp
:= Convert_To_Bignum
(Expression
(Alt
));
8641 Rtype
:= RTE
(RE_Bignum
);
8643 New_Exp
:= Convert_To
(LLIB
, Expression
(Alt
));
8647 Append_To
(New_Alts
,
8648 Make_Case_Expression_Alternative
(Sloc
(Alt
),
8650 Discrete_Choices
=> Discrete_Choices
(Alt
),
8651 Expression
=> New_Exp
));
8657 Make_Case_Expression
(Loc
,
8658 Expression
=> Expression
(N
),
8659 Alternatives
=> New_Alts
));
8661 Reanalyze
(Rtype
, Suppress
=> True);
8669 -- If we have an arithmetic operator we make recursive calls on the
8670 -- operands to get the ranges (and to properly process the subtree
8671 -- that lies below us).
8673 Minimize_Eliminate_Overflows
8674 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
8677 Minimize_Eliminate_Overflows
8678 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
8681 -- Record if we have Long_Long_Integer operands
8683 Long_Long_Integer_Operands
:=
8684 Etype
(Right_Opnd
(N
)) = LLIB
8685 or else (Binary
and then Etype
(Left_Opnd
(N
)) = LLIB
);
8687 -- If either operand is a bignum, then result will be a bignum and we
8688 -- don't need to do any range analysis. As previously discussed we could
8689 -- do range analysis in such cases, but it could mean working with giant
8690 -- numbers at compile time for very little gain (the number of cases
8691 -- in which we could slip back from bignum mode is small).
8693 if Rlo
= No_Uint
or else (Binary
and then Llo
= No_Uint
) then
8696 Bignum_Operands
:= True;
8698 -- Otherwise compute result range
8701 Bignum_Operands
:= False;
8709 Hi
:= UI_Max
(abs Rlo
, abs Rhi
);
8721 -- If the right operand can only be zero, set 0..0
8723 if Rlo
= 0 and then Rhi
= 0 then
8727 -- Possible bounds of division must come from dividing end
8728 -- values of the input ranges (four possibilities), provided
8729 -- zero is not included in the possible values of the right
8732 -- Otherwise, we just consider two intervals of values for
8733 -- the right operand: the interval of negative values (up to
8734 -- -1) and the interval of positive values (starting at 1).
8735 -- Since division by 1 is the identity, and division by -1
8736 -- is negation, we get all possible bounds of division in that
8737 -- case by considering:
8738 -- - all values from the division of end values of input
8740 -- - the end values of the left operand;
8741 -- - the negation of the end values of the left operand.
8745 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
8746 -- Mark so we can release the RR and Ev values
8754 -- Discard extreme values of zero for the divisor, since
8755 -- they will simply result in an exception in any case.
8763 -- Compute possible bounds coming from dividing end
8764 -- values of the input ranges.
8771 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
8772 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
8774 -- If the right operand can be both negative or positive,
8775 -- include the end values of the left operand in the
8776 -- extreme values, as well as their negation.
8778 if Rlo
< 0 and then Rhi
> 0 then
8785 UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
)));
8787 UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
)));
8790 -- Release the RR and Ev values
8792 Release_And_Save
(Mrk
, Lo
, Hi
);
8800 -- Discard negative values for the exponent, since they will
8801 -- simply result in an exception in any case.
8809 -- Estimate number of bits in result before we go computing
8810 -- giant useless bounds. Basically the number of bits in the
8811 -- result is the number of bits in the base multiplied by the
8812 -- value of the exponent. If this is big enough that the result
8813 -- definitely won't fit in Long_Long_Integer, switch to bignum
8814 -- mode immediately, and avoid computing giant bounds.
8816 -- The comparison here is approximate, but conservative, it
8817 -- only clicks on cases that are sure to exceed the bounds.
8819 if Num_Bits
(UI_Max
(abs Llo
, abs Lhi
)) * Rhi
+ 1 > 100 then
8823 -- If right operand is zero then result is 1
8830 -- High bound comes either from exponentiation of largest
8831 -- positive value to largest exponent value, or from
8832 -- the exponentiation of most negative value to an
8846 if Rhi
mod 2 = 0 then
8849 Hi2
:= Llo
** (Rhi
- 1);
8855 Hi
:= UI_Max
(Hi1
, Hi2
);
8858 -- Result can only be negative if base can be negative
8861 if Rhi
mod 2 = 0 then
8862 Lo
:= Llo
** (Rhi
- 1);
8867 -- Otherwise low bound is minimum ** minimum
8884 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
8885 -- This is the maximum absolute value of the result
8891 -- The result depends only on the sign and magnitude of
8892 -- the right operand, it does not depend on the sign or
8893 -- magnitude of the left operand.
8906 when N_Op_Multiply
=>
8908 -- Possible bounds of multiplication must come from multiplying
8909 -- end values of the input ranges (four possibilities).
8912 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
8913 -- Mark so we can release the Ev values
8915 Ev1
: constant Uint
:= Llo
* Rlo
;
8916 Ev2
: constant Uint
:= Llo
* Rhi
;
8917 Ev3
: constant Uint
:= Lhi
* Rlo
;
8918 Ev4
: constant Uint
:= Lhi
* Rhi
;
8921 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
8922 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
8924 -- Release the Ev values
8926 Release_And_Save
(Mrk
, Lo
, Hi
);
8929 -- Plus operator (affirmation)
8939 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
8940 -- This is the maximum absolute value of the result. Note
8941 -- that the result range does not depend on the sign of the
8948 -- Case of left operand negative, which results in a range
8949 -- of -Maxabs .. 0 for those negative values. If there are
8950 -- no negative values then Lo value of result is always 0.
8956 -- Case of left operand positive
8965 when N_Op_Subtract
=>
8969 -- Nothing else should be possible
8972 raise Program_Error
;
8976 -- Here for the case where we have not rewritten anything (no bignum
8977 -- operands or long long integer operands), and we know the result.
8978 -- If we know we are in the result range, and we do not have Bignum
8979 -- operands or Long_Long_Integer operands, we can just reexpand with
8980 -- overflow checks turned off (since we know we cannot have overflow).
8981 -- As always the reexpansion is required to complete expansion of the
8982 -- operator, but we do not need to reanalyze, and we prevent recursion
8983 -- by suppressing the check.
8985 if not (Bignum_Operands
or Long_Long_Integer_Operands
)
8986 and then In_Result_Range
8988 Set_Do_Overflow_Check
(N
, False);
8989 Reexpand
(Suppress
=> True);
8992 -- Here we know that we are not in the result range, and in the general
8993 -- case we will move into either the Bignum or Long_Long_Integer domain
8994 -- to compute the result. However, there is one exception. If we are
8995 -- at the top level, and we do not have Bignum or Long_Long_Integer
8996 -- operands, we will have to immediately convert the result back to
8997 -- the result type, so there is no point in Bignum/Long_Long_Integer
9001 and then not (Bignum_Operands
or Long_Long_Integer_Operands
)
9003 -- One further refinement. If we are at the top level, but our parent
9004 -- is a type conversion, then go into bignum or long long integer node
9005 -- since the result will be converted to that type directly without
9006 -- going through the result type, and we may avoid an overflow. This
9007 -- is the case for example of Long_Long_Integer (A ** 4), where A is
9008 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
9009 -- but does not fit in Integer.
9011 and then Nkind
(Parent
(N
)) /= N_Type_Conversion
9013 -- Here keep original types, but we need to complete analysis
9015 -- One subtlety. We can't just go ahead and do an analyze operation
9016 -- here because it will cause recursion into the whole MINIMIZED/
9017 -- ELIMINATED overflow processing which is not what we want. Here
9018 -- we are at the top level, and we need a check against the result
9019 -- mode (i.e. we want to use STRICT mode). So do exactly that.
9020 -- Also, we have not modified the node, so this is a case where
9021 -- we need to reexpand, but not reanalyze.
9026 -- Cases where we do the operation in Bignum mode. This happens either
9027 -- because one of our operands is in Bignum mode already, or because
9028 -- the computed bounds are outside the bounds of Long_Long_Integer,
9029 -- which in some cases can be indicated by Hi and Lo being No_Uint.
9031 -- Note: we could do better here and in some cases switch back from
9032 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
9033 -- 0 .. 1, but the cases are rare and it is not worth the effort.
9034 -- Failing to do this switching back is only an efficiency issue.
9036 elsif Lo
= No_Uint
or else Lo
< LLLo
or else Hi
> LLHi
then
9038 -- OK, we are definitely outside the range of Long_Long_Integer. The
9039 -- question is whether to move to Bignum mode, or stay in the domain
9040 -- of Long_Long_Integer, signalling that an overflow check is needed.
9042 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
9043 -- the Bignum business. In ELIMINATED mode, we will normally move
9044 -- into Bignum mode, but there is an exception if neither of our
9045 -- operands is Bignum now, and we are at the top level (Top_Level
9046 -- set True). In this case, there is no point in moving into Bignum
9047 -- mode to prevent overflow if the caller will immediately convert
9048 -- the Bignum value back to LLI with an overflow check. It's more
9049 -- efficient to stay in LLI mode with an overflow check (if needed)
9051 if Check_Mode
= Minimized
9052 or else (Top_Level
and not Bignum_Operands
)
9054 if Do_Overflow_Check
(N
) then
9055 Enable_Overflow_Check
(N
);
9058 -- The result now has to be in Long_Long_Integer mode, so adjust
9059 -- the possible range to reflect this. Note these calls also
9060 -- change No_Uint values from the top level case to LLI bounds.
9065 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
9068 pragma Assert
(Check_Mode
= Eliminated
);
9077 Fent
:= RTE
(RE_Big_Abs
);
9080 Fent
:= RTE
(RE_Big_Add
);
9083 Fent
:= RTE
(RE_Big_Div
);
9086 Fent
:= RTE
(RE_Big_Exp
);
9089 Fent
:= RTE
(RE_Big_Neg
);
9092 Fent
:= RTE
(RE_Big_Mod
);
9094 when N_Op_Multiply
=>
9095 Fent
:= RTE
(RE_Big_Mul
);
9098 Fent
:= RTE
(RE_Big_Rem
);
9100 when N_Op_Subtract
=>
9101 Fent
:= RTE
(RE_Big_Sub
);
9103 -- Anything else is an internal error, this includes the
9104 -- N_Op_Plus case, since how can plus cause the result
9105 -- to be out of range if the operand is in range?
9108 raise Program_Error
;
9111 -- Construct argument list for Bignum call, converting our
9112 -- operands to Bignum form if they are not already there.
9117 Append_To
(Args
, Convert_To_Bignum
(Left_Opnd
(N
)));
9120 Append_To
(Args
, Convert_To_Bignum
(Right_Opnd
(N
)));
9122 -- Now rewrite the arithmetic operator with a call to the
9123 -- corresponding bignum function.
9126 Make_Function_Call
(Loc
,
9127 Name
=> New_Occurrence_Of
(Fent
, Loc
),
9128 Parameter_Associations
=> Args
));
9129 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
9131 -- Indicate result is Bignum mode
9139 -- Otherwise we are in range of Long_Long_Integer, so no overflow
9140 -- check is required, at least not yet.
9143 Set_Do_Overflow_Check
(N
, False);
9146 -- Here we are not in Bignum territory, but we may have long long
9147 -- integer operands that need special handling. First a special check:
9148 -- If an exponentiation operator exponent is of type Long_Long_Integer,
9149 -- it means we converted it to prevent overflow, but exponentiation
9150 -- requires a Natural right operand, so convert it back to Natural.
9151 -- This conversion may raise an exception which is fine.
9153 if Nkind
(N
) = N_Op_Expon
and then Etype
(Right_Opnd
(N
)) = LLIB
then
9154 Convert_To_And_Rewrite
(Standard_Natural
, Right_Opnd
(N
));
9157 -- Here we will do the operation in Long_Long_Integer. We do this even
9158 -- if we know an overflow check is required, better to do this in long
9159 -- long integer mode, since we are less likely to overflow.
9161 -- Convert right or only operand to Long_Long_Integer, except that
9162 -- we do not touch the exponentiation right operand.
9164 if Nkind
(N
) /= N_Op_Expon
then
9165 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
9168 -- Convert left operand to Long_Long_Integer for binary case
9171 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
9174 -- Reset node to unanalyzed
9176 Set_Analyzed
(N
, False);
9177 Set_Etype
(N
, Empty
);
9178 Set_Entity
(N
, Empty
);
9180 -- Now analyze this new node. This reanalysis will complete processing
9181 -- for the node. In particular we will complete the expansion of an
9182 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
9183 -- we will complete any division checks (since we have not changed the
9184 -- setting of the Do_Division_Check flag).
9186 -- We do this reanalysis in STRICT mode to avoid recursion into the
9187 -- MINIMIZED/ELIMINATED handling, since we are now done with that.
9190 SG
: constant Overflow_Mode_Type
:=
9191 Scope_Suppress
.Overflow_Mode_General
;
9192 SA
: constant Overflow_Mode_Type
:=
9193 Scope_Suppress
.Overflow_Mode_Assertions
;
9196 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
9197 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
9199 if not Do_Overflow_Check
(N
) then
9200 Reanalyze
(LLIB
, Suppress
=> True);
9205 Scope_Suppress
.Overflow_Mode_General
:= SG
;
9206 Scope_Suppress
.Overflow_Mode_Assertions
:= SA
;
9208 end Minimize_Eliminate_Overflows
;
9210 -------------------------
9211 -- Overflow_Check_Mode --
9212 -------------------------
9214 function Overflow_Check_Mode
return Overflow_Mode_Type
is
9216 if In_Assertion_Expr
= 0 then
9217 return Scope_Suppress
.Overflow_Mode_General
;
9219 return Scope_Suppress
.Overflow_Mode_Assertions
;
9221 end Overflow_Check_Mode
;
9223 --------------------------------
9224 -- Overflow_Checks_Suppressed --
9225 --------------------------------
9227 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9229 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9230 return Is_Check_Suppressed
(E
, Overflow_Check
);
9232 return Scope_Suppress
.Suppress
(Overflow_Check
);
9234 end Overflow_Checks_Suppressed
;
9236 ---------------------------------
9237 -- Predicate_Checks_Suppressed --
9238 ---------------------------------
9240 function Predicate_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9242 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9243 return Is_Check_Suppressed
(E
, Predicate_Check
);
9245 return Scope_Suppress
.Suppress
(Predicate_Check
);
9247 end Predicate_Checks_Suppressed
;
9249 -----------------------------
9250 -- Range_Checks_Suppressed --
9251 -----------------------------
9253 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9256 if Kill_Range_Checks
(E
) then
9259 elsif Checks_May_Be_Suppressed
(E
) then
9260 return Is_Check_Suppressed
(E
, Range_Check
);
9264 return Scope_Suppress
.Suppress
(Range_Check
);
9265 end Range_Checks_Suppressed
;
9267 -----------------------------------------
9268 -- Range_Or_Validity_Checks_Suppressed --
9269 -----------------------------------------
9271 -- Note: the coding would be simpler here if we simply made appropriate
9272 -- calls to Range/Validity_Checks_Suppressed, but that would result in
9273 -- duplicated checks which we prefer to avoid.
9275 function Range_Or_Validity_Checks_Suppressed
9276 (Expr
: Node_Id
) return Boolean
9279 -- Immediate return if scope checks suppressed for either check
9281 if Scope_Suppress
.Suppress
(Range_Check
)
9283 Scope_Suppress
.Suppress
(Validity_Check
)
9288 -- If no expression, that's odd, decide that checks are suppressed,
9289 -- since we don't want anyone trying to do checks in this case, which
9290 -- is most likely the result of some other error.
9296 -- Expression is present, so perform suppress checks on type
9299 Typ
: constant Entity_Id
:= Etype
(Expr
);
9301 if Checks_May_Be_Suppressed
(Typ
)
9302 and then (Is_Check_Suppressed
(Typ
, Range_Check
)
9304 Is_Check_Suppressed
(Typ
, Validity_Check
))
9310 -- If expression is an entity name, perform checks on this entity
9312 if Is_Entity_Name
(Expr
) then
9314 Ent
: constant Entity_Id
:= Entity
(Expr
);
9316 if Checks_May_Be_Suppressed
(Ent
) then
9317 return Is_Check_Suppressed
(Ent
, Range_Check
)
9318 or else Is_Check_Suppressed
(Ent
, Validity_Check
);
9323 -- If we fall through, no checks suppressed
9326 end Range_Or_Validity_Checks_Suppressed
;
9332 procedure Remove_Checks
(Expr
: Node_Id
) is
9333 function Process
(N
: Node_Id
) return Traverse_Result
;
9334 -- Process a single node during the traversal
9336 procedure Traverse
is new Traverse_Proc
(Process
);
9337 -- The traversal procedure itself
9343 function Process
(N
: Node_Id
) return Traverse_Result
is
9345 if Nkind
(N
) not in N_Subexpr
then
9349 Set_Do_Range_Check
(N
, False);
9353 Traverse
(Left_Opnd
(N
));
9356 when N_Attribute_Reference
=>
9357 Set_Do_Overflow_Check
(N
, False);
9359 when N_Function_Call
=>
9360 Set_Do_Tag_Check
(N
, False);
9363 Set_Do_Overflow_Check
(N
, False);
9367 Set_Do_Division_Check
(N
, False);
9370 Set_Do_Length_Check
(N
, False);
9373 Set_Do_Division_Check
(N
, False);
9376 Set_Do_Length_Check
(N
, False);
9379 Set_Do_Division_Check
(N
, False);
9382 Set_Do_Length_Check
(N
, False);
9389 Traverse
(Left_Opnd
(N
));
9392 when N_Selected_Component
=>
9393 Set_Do_Discriminant_Check
(N
, False);
9395 when N_Type_Conversion
=>
9396 Set_Do_Length_Check
(N
, False);
9397 Set_Do_Tag_Check
(N
, False);
9398 Set_Do_Overflow_Check
(N
, False);
9407 -- Start of processing for Remove_Checks
9413 ----------------------------
9414 -- Selected_Length_Checks --
9415 ----------------------------
9417 function Selected_Length_Checks
9419 Target_Typ
: Entity_Id
;
9420 Source_Typ
: Entity_Id
;
9421 Warn_Node
: Node_Id
) return Check_Result
9423 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
9426 Expr_Actual
: Node_Id
;
9428 Cond
: Node_Id
:= Empty
;
9429 Do_Access
: Boolean := False;
9430 Wnode
: Node_Id
:= Warn_Node
;
9431 Ret_Result
: Check_Result
:= (Empty
, Empty
);
9432 Num_Checks
: Natural := 0;
9434 procedure Add_Check
(N
: Node_Id
);
9435 -- Adds the action given to Ret_Result if N is non-Empty
9437 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
9438 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
9439 -- Comments required ???
9441 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
9442 -- True for equal literals and for nodes that denote the same constant
9443 -- entity, even if its value is not a static constant. This includes the
9444 -- case of a discriminal reference within an init proc. Removes some
9445 -- obviously superfluous checks.
9447 function Length_E_Cond
9448 (Exptyp
: Entity_Id
;
9450 Indx
: Nat
) return Node_Id
;
9451 -- Returns expression to compute:
9452 -- Typ'Length /= Exptyp'Length
9454 function Length_N_Cond
9457 Indx
: Nat
) return Node_Id
;
9458 -- Returns expression to compute:
9459 -- Typ'Length /= Expr'Length
9465 procedure Add_Check
(N
: Node_Id
) is
9469 -- For now, ignore attempt to place more than two checks ???
9470 -- This is really worrisome, are we really discarding checks ???
9472 if Num_Checks
= 2 then
9476 pragma Assert
(Num_Checks
<= 1);
9477 Num_Checks
:= Num_Checks
+ 1;
9478 Ret_Result
(Num_Checks
) := N
;
9486 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
9487 SE
: constant Entity_Id
:= Scope
(E
);
9489 E1
: Entity_Id
:= E
;
9492 if Ekind
(Scope
(E
)) = E_Record_Type
9493 and then Has_Discriminants
(Scope
(E
))
9495 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
9498 Insert_Action
(Ck_Node
, N
);
9499 E1
:= Defining_Identifier
(N
);
9503 if Ekind
(E1
) = E_String_Literal_Subtype
then
9505 Make_Integer_Literal
(Loc
,
9506 Intval
=> String_Literal_Length
(E1
));
9508 elsif SE
/= Standard_Standard
9509 and then Ekind
(Scope
(SE
)) = E_Protected_Type
9510 and then Has_Discriminants
(Scope
(SE
))
9511 and then Has_Completion
(Scope
(SE
))
9512 and then not Inside_Init_Proc
9514 -- If the type whose length is needed is a private component
9515 -- constrained by a discriminant, we must expand the 'Length
9516 -- attribute into an explicit computation, using the discriminal
9517 -- of the current protected operation. This is because the actual
9518 -- type of the prival is constructed after the protected opera-
9519 -- tion has been fully expanded.
9522 Indx_Type
: Node_Id
;
9525 Do_Expand
: Boolean := False;
9528 Indx_Type
:= First_Index
(E
);
9530 for J
in 1 .. Indx
- 1 loop
9531 Next_Index
(Indx_Type
);
9534 Get_Index_Bounds
(Indx_Type
, Lo
, Hi
);
9536 if Nkind
(Lo
) = N_Identifier
9537 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
9539 Lo
:= Get_Discriminal
(E
, Lo
);
9543 if Nkind
(Hi
) = N_Identifier
9544 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
9546 Hi
:= Get_Discriminal
(E
, Hi
);
9551 if not Is_Entity_Name
(Lo
) then
9552 Lo
:= Duplicate_Subexpr_No_Checks
(Lo
);
9555 if not Is_Entity_Name
(Hi
) then
9556 Lo
:= Duplicate_Subexpr_No_Checks
(Hi
);
9562 Make_Op_Subtract
(Loc
,
9566 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
9571 Make_Attribute_Reference
(Loc
,
9572 Attribute_Name
=> Name_Length
,
9574 New_Occurrence_Of
(E1
, Loc
));
9577 Set_Expressions
(N
, New_List
(
9578 Make_Integer_Literal
(Loc
, Indx
)));
9587 Make_Attribute_Reference
(Loc
,
9588 Attribute_Name
=> Name_Length
,
9590 New_Occurrence_Of
(E1
, Loc
));
9593 Set_Expressions
(N
, New_List
(
9594 Make_Integer_Literal
(Loc
, Indx
)));
9605 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
9608 Make_Attribute_Reference
(Loc
,
9609 Attribute_Name
=> Name_Length
,
9611 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
9612 Expressions
=> New_List
(
9613 Make_Integer_Literal
(Loc
, Indx
)));
9620 function Length_E_Cond
9621 (Exptyp
: Entity_Id
;
9623 Indx
: Nat
) return Node_Id
9628 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
9629 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
9636 function Length_N_Cond
9639 Indx
: Nat
) return Node_Id
9644 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
9645 Right_Opnd
=> Get_N_Length
(Expr
, Indx
));
9652 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
9655 (Nkind
(L
) = N_Integer_Literal
9656 and then Nkind
(R
) = N_Integer_Literal
9657 and then Intval
(L
) = Intval
(R
))
9661 and then Ekind
(Entity
(L
)) = E_Constant
9662 and then ((Is_Entity_Name
(R
)
9663 and then Entity
(L
) = Entity
(R
))
9665 (Nkind
(R
) = N_Type_Conversion
9666 and then Is_Entity_Name
(Expression
(R
))
9667 and then Entity
(L
) = Entity
(Expression
(R
)))))
9671 and then Ekind
(Entity
(R
)) = E_Constant
9672 and then Nkind
(L
) = N_Type_Conversion
9673 and then Is_Entity_Name
(Expression
(L
))
9674 and then Entity
(R
) = Entity
(Expression
(L
)))
9678 and then Is_Entity_Name
(R
)
9679 and then Entity
(L
) = Entity
(R
)
9680 and then Ekind
(Entity
(L
)) = E_In_Parameter
9681 and then Inside_Init_Proc
);
9684 -- Start of processing for Selected_Length_Checks
9687 -- Checks will be applied only when generating code
9689 if not Expander_Active
then
9693 if Target_Typ
= Any_Type
9694 or else Target_Typ
= Any_Composite
9695 or else Raises_Constraint_Error
(Ck_Node
)
9704 T_Typ
:= Target_Typ
;
9706 if No
(Source_Typ
) then
9707 S_Typ
:= Etype
(Ck_Node
);
9709 S_Typ
:= Source_Typ
;
9712 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
9716 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
9717 S_Typ
:= Designated_Type
(S_Typ
);
9718 T_Typ
:= Designated_Type
(T_Typ
);
9721 -- A simple optimization for the null case
9723 if Known_Null
(Ck_Node
) then
9728 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
9729 if Is_Constrained
(T_Typ
) then
9731 -- The checking code to be generated will freeze the corresponding
9732 -- array type. However, we must freeze the type now, so that the
9733 -- freeze node does not appear within the generated if expression,
9736 Freeze_Before
(Ck_Node
, T_Typ
);
9738 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
9739 Exptyp
:= Get_Actual_Subtype
(Ck_Node
);
9741 if Is_Access_Type
(Exptyp
) then
9742 Exptyp
:= Designated_Type
(Exptyp
);
9745 -- String_Literal case. This needs to be handled specially be-
9746 -- cause no index types are available for string literals. The
9747 -- condition is simply:
9749 -- T_Typ'Length = string-literal-length
9751 if Nkind
(Expr_Actual
) = N_String_Literal
9752 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
9756 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
9758 Make_Integer_Literal
(Loc
,
9760 String_Literal_Length
(Etype
(Expr_Actual
))));
9762 -- General array case. Here we have a usable actual subtype for
9763 -- the expression, and the condition is built from the two types
9766 -- T_Typ'Length /= Exptyp'Length or else
9767 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
9768 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
9771 elsif Is_Constrained
(Exptyp
) then
9773 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9786 -- At the library level, we need to ensure that the type of
9787 -- the object is elaborated before the check itself is
9788 -- emitted. This is only done if the object is in the
9789 -- current compilation unit, otherwise the type is frozen
9790 -- and elaborated in its unit.
9792 if Is_Itype
(Exptyp
)
9794 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
9796 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
9797 and then In_Open_Scopes
(Scope
(Exptyp
))
9799 Ref_Node
:= Make_Itype_Reference
(Sloc
(Ck_Node
));
9800 Set_Itype
(Ref_Node
, Exptyp
);
9801 Insert_Action
(Ck_Node
, Ref_Node
);
9804 L_Index
:= First_Index
(T_Typ
);
9805 R_Index
:= First_Index
(Exptyp
);
9807 for Indx
in 1 .. Ndims
loop
9808 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
9810 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
9812 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
9813 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
9815 -- Deal with compile time length check. Note that we
9816 -- skip this in the access case, because the access
9817 -- value may be null, so we cannot know statically.
9820 and then Compile_Time_Known_Value
(L_Low
)
9821 and then Compile_Time_Known_Value
(L_High
)
9822 and then Compile_Time_Known_Value
(R_Low
)
9823 and then Compile_Time_Known_Value
(R_High
)
9825 if Expr_Value
(L_High
) >= Expr_Value
(L_Low
) then
9826 L_Length
:= Expr_Value
(L_High
) -
9827 Expr_Value
(L_Low
) + 1;
9829 L_Length
:= UI_From_Int
(0);
9832 if Expr_Value
(R_High
) >= Expr_Value
(R_Low
) then
9833 R_Length
:= Expr_Value
(R_High
) -
9834 Expr_Value
(R_Low
) + 1;
9836 R_Length
:= UI_From_Int
(0);
9839 if L_Length
> R_Length
then
9841 (Compile_Time_Constraint_Error
9842 (Wnode
, "too few elements for}??", T_Typ
));
9844 elsif L_Length
< R_Length
then
9846 (Compile_Time_Constraint_Error
9847 (Wnode
, "too many elements for}??", T_Typ
));
9850 -- The comparison for an individual index subtype
9851 -- is omitted if the corresponding index subtypes
9852 -- statically match, since the result is known to
9853 -- be true. Note that this test is worth while even
9854 -- though we do static evaluation, because non-static
9855 -- subtypes can statically match.
9858 Subtypes_Statically_Match
9859 (Etype
(L_Index
), Etype
(R_Index
))
9862 (Same_Bounds
(L_Low
, R_Low
)
9863 and then Same_Bounds
(L_High
, R_High
))
9866 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
9875 -- Handle cases where we do not get a usable actual subtype that
9876 -- is constrained. This happens for example in the function call
9877 -- and explicit dereference cases. In these cases, we have to get
9878 -- the length or range from the expression itself, making sure we
9879 -- do not evaluate it more than once.
9881 -- Here Ck_Node is the original expression, or more properly the
9882 -- result of applying Duplicate_Expr to the original tree, forcing
9883 -- the result to be a name.
9887 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9890 -- Build the condition for the explicit dereference case
9892 for Indx
in 1 .. Ndims
loop
9894 (Cond
, Length_N_Cond
(Ck_Node
, T_Typ
, Indx
));
9901 -- Construct the test and insert into the tree
9903 if Present
(Cond
) then
9905 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
9909 (Make_Raise_Constraint_Error
(Loc
,
9911 Reason
=> CE_Length_Check_Failed
));
9915 end Selected_Length_Checks
;
9917 ---------------------------
9918 -- Selected_Range_Checks --
9919 ---------------------------
9921 function Selected_Range_Checks
9923 Target_Typ
: Entity_Id
;
9924 Source_Typ
: Entity_Id
;
9925 Warn_Node
: Node_Id
) return Check_Result
9927 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
9930 Expr_Actual
: Node_Id
;
9932 Cond
: Node_Id
:= Empty
;
9933 Do_Access
: Boolean := False;
9934 Wnode
: Node_Id
:= Warn_Node
;
9935 Ret_Result
: Check_Result
:= (Empty
, Empty
);
9936 Num_Checks
: Natural := 0;
9938 procedure Add_Check
(N
: Node_Id
);
9939 -- Adds the action given to Ret_Result if N is non-Empty
9941 function Discrete_Range_Cond
9943 Typ
: Entity_Id
) return Node_Id
;
9944 -- Returns expression to compute:
9945 -- Low_Bound (Expr) < Typ'First
9947 -- High_Bound (Expr) > Typ'Last
9949 function Discrete_Expr_Cond
9951 Typ
: Entity_Id
) return Node_Id
;
9952 -- Returns expression to compute:
9957 function Get_E_First_Or_Last
9961 Nam
: Name_Id
) return Node_Id
;
9962 -- Returns an attribute reference
9963 -- E'First or E'Last
9964 -- with a source location of Loc.
9966 -- Nam is Name_First or Name_Last, according to which attribute is
9967 -- desired. If Indx is non-zero, it is passed as a literal in the
9968 -- Expressions of the attribute reference (identifying the desired
9969 -- array dimension).
9971 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
9972 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
9973 -- Returns expression to compute:
9974 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
9976 function Range_E_Cond
9977 (Exptyp
: Entity_Id
;
9981 -- Returns expression to compute:
9982 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
9984 function Range_Equal_E_Cond
9985 (Exptyp
: Entity_Id
;
9987 Indx
: Nat
) return Node_Id
;
9988 -- Returns expression to compute:
9989 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
9991 function Range_N_Cond
9994 Indx
: Nat
) return Node_Id
;
9995 -- Return expression to compute:
9996 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
10002 procedure Add_Check
(N
: Node_Id
) is
10004 if Present
(N
) then
10006 -- For now, ignore attempt to place more than 2 checks ???
10008 if Num_Checks
= 2 then
10012 pragma Assert
(Num_Checks
<= 1);
10013 Num_Checks
:= Num_Checks
+ 1;
10014 Ret_Result
(Num_Checks
) := N
;
10018 -------------------------
10019 -- Discrete_Expr_Cond --
10020 -------------------------
10022 function Discrete_Expr_Cond
10024 Typ
: Entity_Id
) return Node_Id
10032 Convert_To
(Base_Type
(Typ
),
10033 Duplicate_Subexpr_No_Checks
(Expr
)),
10035 Convert_To
(Base_Type
(Typ
),
10036 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
))),
10041 Convert_To
(Base_Type
(Typ
),
10042 Duplicate_Subexpr_No_Checks
(Expr
)),
10046 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
))));
10047 end Discrete_Expr_Cond
;
10049 -------------------------
10050 -- Discrete_Range_Cond --
10051 -------------------------
10053 function Discrete_Range_Cond
10055 Typ
: Entity_Id
) return Node_Id
10057 LB
: Node_Id
:= Low_Bound
(Expr
);
10058 HB
: Node_Id
:= High_Bound
(Expr
);
10060 Left_Opnd
: Node_Id
;
10061 Right_Opnd
: Node_Id
;
10064 if Nkind
(LB
) = N_Identifier
10065 and then Ekind
(Entity
(LB
)) = E_Discriminant
10067 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
10074 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
10079 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
)));
10081 if Nkind
(HB
) = N_Identifier
10082 and then Ekind
(Entity
(HB
)) = E_Discriminant
10084 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
10091 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
10096 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
)));
10098 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
10099 end Discrete_Range_Cond
;
10101 -------------------------
10102 -- Get_E_First_Or_Last --
10103 -------------------------
10105 function Get_E_First_Or_Last
10109 Nam
: Name_Id
) return Node_Id
10114 Exprs
:= New_List
(Make_Integer_Literal
(Loc
, UI_From_Int
(Indx
)));
10119 return Make_Attribute_Reference
(Loc
,
10120 Prefix
=> New_Occurrence_Of
(E
, Loc
),
10121 Attribute_Name
=> Nam
,
10122 Expressions
=> Exprs
);
10123 end Get_E_First_Or_Last
;
10129 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
10132 Make_Attribute_Reference
(Loc
,
10133 Attribute_Name
=> Name_First
,
10135 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
10136 Expressions
=> New_List
(
10137 Make_Integer_Literal
(Loc
, Indx
)));
10144 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
10147 Make_Attribute_Reference
(Loc
,
10148 Attribute_Name
=> Name_Last
,
10150 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
10151 Expressions
=> New_List
(
10152 Make_Integer_Literal
(Loc
, Indx
)));
10159 function Range_E_Cond
10160 (Exptyp
: Entity_Id
;
10162 Indx
: Nat
) return Node_Id
10170 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
10172 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
10177 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
10179 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
10182 ------------------------
10183 -- Range_Equal_E_Cond --
10184 ------------------------
10186 function Range_Equal_E_Cond
10187 (Exptyp
: Entity_Id
;
10189 Indx
: Nat
) return Node_Id
10197 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
10199 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
10204 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
10206 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
10207 end Range_Equal_E_Cond
;
10213 function Range_N_Cond
10216 Indx
: Nat
) return Node_Id
10224 Get_N_First
(Expr
, Indx
),
10226 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
10231 Get_N_Last
(Expr
, Indx
),
10233 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
10236 -- Start of processing for Selected_Range_Checks
10239 -- Checks will be applied only when generating code. In GNATprove mode,
10240 -- we do not apply the checks, but we still call Selected_Range_Checks
10241 -- to possibly issue errors on SPARK code when a run-time error can be
10242 -- detected at compile time.
10244 if not Expander_Active
and not GNATprove_Mode
then
10248 if Target_Typ
= Any_Type
10249 or else Target_Typ
= Any_Composite
10250 or else Raises_Constraint_Error
(Ck_Node
)
10259 T_Typ
:= Target_Typ
;
10261 if No
(Source_Typ
) then
10262 S_Typ
:= Etype
(Ck_Node
);
10264 S_Typ
:= Source_Typ
;
10267 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
10271 -- The order of evaluating T_Typ before S_Typ seems to be critical
10272 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
10273 -- in, and since Node can be an N_Range node, it might be invalid.
10274 -- Should there be an assert check somewhere for taking the Etype of
10275 -- an N_Range node ???
10277 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
10278 S_Typ
:= Designated_Type
(S_Typ
);
10279 T_Typ
:= Designated_Type
(T_Typ
);
10282 -- A simple optimization for the null case
10284 if Known_Null
(Ck_Node
) then
10289 -- For an N_Range Node, check for a null range and then if not
10290 -- null generate a range check action.
10292 if Nkind
(Ck_Node
) = N_Range
then
10294 -- There's no point in checking a range against itself
10296 if Ck_Node
= Scalar_Range
(T_Typ
) then
10301 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
10302 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
10303 Known_T_LB
: constant Boolean := Compile_Time_Known_Value
(T_LB
);
10304 Known_T_HB
: constant Boolean := Compile_Time_Known_Value
(T_HB
);
10306 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
10307 HB
: Node_Id
:= High_Bound
(Ck_Node
);
10308 Known_LB
: Boolean := False;
10309 Known_HB
: Boolean := False;
10311 Null_Range
: Boolean;
10312 Out_Of_Range_L
: Boolean;
10313 Out_Of_Range_H
: Boolean;
10316 -- Compute what is known at compile time
10318 if Known_T_LB
and Known_T_HB
then
10319 if Compile_Time_Known_Value
(LB
) then
10322 -- There's no point in checking that a bound is within its
10323 -- own range so pretend that it is known in this case. First
10324 -- deal with low bound.
10326 elsif Ekind
(Etype
(LB
)) = E_Signed_Integer_Subtype
10327 and then Scalar_Range
(Etype
(LB
)) = Scalar_Range
(T_Typ
)
10333 -- Likewise for the high bound
10335 if Compile_Time_Known_Value
(HB
) then
10338 elsif Ekind
(Etype
(HB
)) = E_Signed_Integer_Subtype
10339 and then Scalar_Range
(Etype
(HB
)) = Scalar_Range
(T_Typ
)
10346 -- Check for case where everything is static and we can do the
10347 -- check at compile time. This is skipped if we have an access
10348 -- type, since the access value may be null.
10350 -- ??? This code can be improved since you only need to know that
10351 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
10352 -- compile time to emit pertinent messages.
10354 if Known_T_LB
and Known_T_HB
and Known_LB
and Known_HB
10357 -- Floating-point case
10359 if Is_Floating_Point_Type
(S_Typ
) then
10360 Null_Range
:= Expr_Value_R
(HB
) < Expr_Value_R
(LB
);
10362 (Expr_Value_R
(LB
) < Expr_Value_R
(T_LB
))
10364 (Expr_Value_R
(LB
) > Expr_Value_R
(T_HB
));
10367 (Expr_Value_R
(HB
) > Expr_Value_R
(T_HB
))
10369 (Expr_Value_R
(HB
) < Expr_Value_R
(T_LB
));
10371 -- Fixed or discrete type case
10374 Null_Range
:= Expr_Value
(HB
) < Expr_Value
(LB
);
10376 (Expr_Value
(LB
) < Expr_Value
(T_LB
))
10378 (Expr_Value
(LB
) > Expr_Value
(T_HB
));
10381 (Expr_Value
(HB
) > Expr_Value
(T_HB
))
10383 (Expr_Value
(HB
) < Expr_Value
(T_LB
));
10386 if not Null_Range
then
10387 if Out_Of_Range_L
then
10388 if No
(Warn_Node
) then
10390 (Compile_Time_Constraint_Error
10391 (Low_Bound
(Ck_Node
),
10392 "static value out of range of}??", T_Typ
));
10396 (Compile_Time_Constraint_Error
10398 "static range out of bounds of}??", T_Typ
));
10402 if Out_Of_Range_H
then
10403 if No
(Warn_Node
) then
10405 (Compile_Time_Constraint_Error
10406 (High_Bound
(Ck_Node
),
10407 "static value out of range of}??", T_Typ
));
10411 (Compile_Time_Constraint_Error
10413 "static range out of bounds of}??", T_Typ
));
10420 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
10421 HB
: Node_Id
:= High_Bound
(Ck_Node
);
10424 -- If either bound is a discriminant and we are within the
10425 -- record declaration, it is a use of the discriminant in a
10426 -- constraint of a component, and nothing can be checked
10427 -- here. The check will be emitted within the init proc.
10428 -- Before then, the discriminal has no real meaning.
10429 -- Similarly, if the entity is a discriminal, there is no
10430 -- check to perform yet.
10432 -- The same holds within a discriminated synchronized type,
10433 -- where the discriminant may constrain a component or an
10436 if Nkind
(LB
) = N_Identifier
10437 and then Denotes_Discriminant
(LB
, True)
10439 if Current_Scope
= Scope
(Entity
(LB
))
10440 or else Is_Concurrent_Type
(Current_Scope
)
10441 or else Ekind
(Entity
(LB
)) /= E_Discriminant
10446 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
10450 if Nkind
(HB
) = N_Identifier
10451 and then Denotes_Discriminant
(HB
, True)
10453 if Current_Scope
= Scope
(Entity
(HB
))
10454 or else Is_Concurrent_Type
(Current_Scope
)
10455 or else Ekind
(Entity
(HB
)) /= E_Discriminant
10460 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
10464 Cond
:= Discrete_Range_Cond
(Ck_Node
, T_Typ
);
10465 Set_Paren_Count
(Cond
, 1);
10468 Make_And_Then
(Loc
,
10472 Convert_To
(Base_Type
(Etype
(HB
)),
10473 Duplicate_Subexpr_No_Checks
(HB
)),
10475 Convert_To
(Base_Type
(Etype
(LB
)),
10476 Duplicate_Subexpr_No_Checks
(LB
))),
10477 Right_Opnd
=> Cond
);
10482 elsif Is_Scalar_Type
(S_Typ
) then
10484 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
10485 -- except the above simply sets a flag in the node and lets
10486 -- gigi generate the check base on the Etype of the expression.
10487 -- Sometimes, however we want to do a dynamic check against an
10488 -- arbitrary target type, so we do that here.
10490 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
10491 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
10493 -- For literals, we can tell if the constraint error will be
10494 -- raised at compile time, so we never need a dynamic check, but
10495 -- if the exception will be raised, then post the usual warning,
10496 -- and replace the literal with a raise constraint error
10497 -- expression. As usual, skip this for access types
10499 elsif Compile_Time_Known_Value
(Ck_Node
) and then not Do_Access
then
10501 LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
10502 UB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
10504 Out_Of_Range
: Boolean;
10505 Static_Bounds
: constant Boolean :=
10506 Compile_Time_Known_Value
(LB
)
10507 and Compile_Time_Known_Value
(UB
);
10510 -- Following range tests should use Sem_Eval routine ???
10512 if Static_Bounds
then
10513 if Is_Floating_Point_Type
(S_Typ
) then
10515 (Expr_Value_R
(Ck_Node
) < Expr_Value_R
(LB
))
10517 (Expr_Value_R
(Ck_Node
) > Expr_Value_R
(UB
));
10519 -- Fixed or discrete type
10523 Expr_Value
(Ck_Node
) < Expr_Value
(LB
)
10525 Expr_Value
(Ck_Node
) > Expr_Value
(UB
);
10528 -- Bounds of the type are static and the literal is out of
10529 -- range so output a warning message.
10531 if Out_Of_Range
then
10532 if No
(Warn_Node
) then
10534 (Compile_Time_Constraint_Error
10536 "static value out of range of}??", T_Typ
));
10540 (Compile_Time_Constraint_Error
10542 "static value out of range of}??", T_Typ
));
10547 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
10551 -- Here for the case of a non-static expression, we need a runtime
10552 -- check unless the source type range is guaranteed to be in the
10553 -- range of the target type.
10556 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
10557 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
10562 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
10563 if Is_Constrained
(T_Typ
) then
10565 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
10566 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
10568 if Is_Access_Type
(Exptyp
) then
10569 Exptyp
:= Designated_Type
(Exptyp
);
10572 -- String_Literal case. This needs to be handled specially be-
10573 -- cause no index types are available for string literals. The
10574 -- condition is simply:
10576 -- T_Typ'Length = string-literal-length
10578 if Nkind
(Expr_Actual
) = N_String_Literal
then
10581 -- General array case. Here we have a usable actual subtype for
10582 -- the expression, and the condition is built from the two types
10584 -- T_Typ'First < Exptyp'First or else
10585 -- T_Typ'Last > Exptyp'Last or else
10586 -- T_Typ'First(1) < Exptyp'First(1) or else
10587 -- T_Typ'Last(1) > Exptyp'Last(1) or else
10590 elsif Is_Constrained
(Exptyp
) then
10592 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
10598 L_Index
:= First_Index
(T_Typ
);
10599 R_Index
:= First_Index
(Exptyp
);
10601 for Indx
in 1 .. Ndims
loop
10602 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
10604 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
10606 -- Deal with compile time length check. Note that we
10607 -- skip this in the access case, because the access
10608 -- value may be null, so we cannot know statically.
10611 Subtypes_Statically_Match
10612 (Etype
(L_Index
), Etype
(R_Index
))
10614 -- If the target type is constrained then we
10615 -- have to check for exact equality of bounds
10616 -- (required for qualified expressions).
10618 if Is_Constrained
(T_Typ
) then
10621 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
10624 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
10634 -- Handle cases where we do not get a usable actual subtype that
10635 -- is constrained. This happens for example in the function call
10636 -- and explicit dereference cases. In these cases, we have to get
10637 -- the length or range from the expression itself, making sure we
10638 -- do not evaluate it more than once.
10640 -- Here Ck_Node is the original expression, or more properly the
10641 -- result of applying Duplicate_Expr to the original tree,
10642 -- forcing the result to be a name.
10646 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
10649 -- Build the condition for the explicit dereference case
10651 for Indx
in 1 .. Ndims
loop
10653 (Cond
, Range_N_Cond
(Ck_Node
, T_Typ
, Indx
));
10659 -- For a conversion to an unconstrained array type, generate an
10660 -- Action to check that the bounds of the source value are within
10661 -- the constraints imposed by the target type (RM 4.6(38)). No
10662 -- check is needed for a conversion to an access to unconstrained
10663 -- array type, as 4.6(24.15/2) requires the designated subtypes
10664 -- of the two access types to statically match.
10666 if Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
10667 and then not Do_Access
10670 Opnd_Index
: Node_Id
;
10671 Targ_Index
: Node_Id
;
10672 Opnd_Range
: Node_Id
;
10675 Opnd_Index
:= First_Index
(Get_Actual_Subtype
(Ck_Node
));
10676 Targ_Index
:= First_Index
(T_Typ
);
10677 while Present
(Opnd_Index
) loop
10679 -- If the index is a range, use its bounds. If it is an
10680 -- entity (as will be the case if it is a named subtype
10681 -- or an itype created for a slice) retrieve its range.
10683 if Is_Entity_Name
(Opnd_Index
)
10684 and then Is_Type
(Entity
(Opnd_Index
))
10686 Opnd_Range
:= Scalar_Range
(Entity
(Opnd_Index
));
10688 Opnd_Range
:= Opnd_Index
;
10691 if Nkind
(Opnd_Range
) = N_Range
then
10693 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
10694 Assume_Valid
=> True)
10697 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
10698 Assume_Valid
=> True)
10702 -- If null range, no check needed
10705 Compile_Time_Known_Value
(High_Bound
(Opnd_Range
))
10707 Compile_Time_Known_Value
(Low_Bound
(Opnd_Range
))
10709 Expr_Value
(High_Bound
(Opnd_Range
)) <
10710 Expr_Value
(Low_Bound
(Opnd_Range
))
10714 elsif Is_Out_Of_Range
10715 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
10716 Assume_Valid
=> True)
10719 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
10720 Assume_Valid
=> True)
10723 (Compile_Time_Constraint_Error
10724 (Wnode
, "value out of range of}??", T_Typ
));
10729 Discrete_Range_Cond
10730 (Opnd_Range
, Etype
(Targ_Index
)));
10734 Next_Index
(Opnd_Index
);
10735 Next_Index
(Targ_Index
);
10742 -- Construct the test and insert into the tree
10744 if Present
(Cond
) then
10746 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
10750 (Make_Raise_Constraint_Error
(Loc
,
10752 Reason
=> CE_Range_Check_Failed
));
10756 end Selected_Range_Checks
;
10758 -------------------------------
10759 -- Storage_Checks_Suppressed --
10760 -------------------------------
10762 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
10764 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
10765 return Is_Check_Suppressed
(E
, Storage_Check
);
10767 return Scope_Suppress
.Suppress
(Storage_Check
);
10769 end Storage_Checks_Suppressed
;
10771 ---------------------------
10772 -- Tag_Checks_Suppressed --
10773 ---------------------------
10775 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
10778 and then Checks_May_Be_Suppressed
(E
)
10780 return Is_Check_Suppressed
(E
, Tag_Check
);
10782 return Scope_Suppress
.Suppress
(Tag_Check
);
10784 end Tag_Checks_Suppressed
;
10786 ---------------------------------------
10787 -- Validate_Alignment_Check_Warnings --
10788 ---------------------------------------
10790 procedure Validate_Alignment_Check_Warnings
is
10792 for J
in Alignment_Warnings
.First
.. Alignment_Warnings
.Last
loop
10794 AWR
: Alignment_Warnings_Record
10795 renames Alignment_Warnings
.Table
(J
);
10797 if Known_Alignment
(AWR
.E
)
10798 and then AWR
.A
mod Alignment
(AWR
.E
) = 0
10800 Delete_Warning_And_Continuations
(AWR
.W
);
10804 end Validate_Alignment_Check_Warnings
;
10806 --------------------------
10807 -- Validity_Check_Range --
10808 --------------------------
10810 procedure Validity_Check_Range
10812 Related_Id
: Entity_Id
:= Empty
)
10815 if Validity_Checks_On
and Validity_Check_Operands
then
10816 if Nkind
(N
) = N_Range
then
10818 (Expr
=> Low_Bound
(N
),
10819 Related_Id
=> Related_Id
,
10820 Is_Low_Bound
=> True);
10823 (Expr
=> High_Bound
(N
),
10824 Related_Id
=> Related_Id
,
10825 Is_High_Bound
=> True);
10828 end Validity_Check_Range
;
10830 --------------------------------
10831 -- Validity_Checks_Suppressed --
10832 --------------------------------
10834 function Validity_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
10836 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
10837 return Is_Check_Suppressed
(E
, Validity_Check
);
10839 return Scope_Suppress
.Suppress
(Validity_Check
);
10841 end Validity_Checks_Suppressed
;