1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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_Eval
; use Sem_Eval
;
52 with Sem_Res
; use Sem_Res
;
53 with Sem_Util
; use Sem_Util
;
54 with Sem_Warn
; use Sem_Warn
;
55 with Sinfo
; use Sinfo
;
56 with Sinput
; use Sinput
;
57 with Snames
; use Snames
;
58 with Sprint
; use Sprint
;
59 with Stand
; use Stand
;
60 with Stringt
; use Stringt
;
61 with Targparm
; use Targparm
;
62 with Tbuild
; use Tbuild
;
63 with Ttypes
; use Ttypes
;
64 with Validsw
; use Validsw
;
66 package body Checks
is
68 -- General note: many of these routines are concerned with generating
69 -- checking code to make sure that constraint error is raised at runtime.
70 -- Clearly this code is only needed if the expander is active, since
71 -- otherwise we will not be generating code or going into the runtime
74 -- We therefore disconnect most of these checks if the expander is
75 -- inactive. This has the additional benefit that we do not need to
76 -- worry about the tree being messed up by previous errors (since errors
77 -- turn off expansion anyway).
79 -- There are a few exceptions to the above rule. For instance routines
80 -- such as Apply_Scalar_Range_Check that do not insert any code can be
81 -- safely called even when the Expander is inactive (but Errors_Detected
82 -- is 0). The benefit of executing this code when expansion is off, is
83 -- the ability to emit constraint error warning for static expressions
84 -- even when we are not generating code.
86 -- The above is modified in gnatprove mode to ensure that proper check
87 -- flags are always placed, even if expansion is off.
89 -------------------------------------
90 -- Suppression of Redundant Checks --
91 -------------------------------------
93 -- This unit implements a limited circuit for removal of redundant
94 -- checks. The processing is based on a tracing of simple sequential
95 -- flow. For any sequence of statements, we save expressions that are
96 -- marked to be checked, and then if the same expression appears later
97 -- with the same check, then under certain circumstances, the second
98 -- check can be suppressed.
100 -- Basically, we can suppress the check if we know for certain that
101 -- the previous expression has been elaborated (together with its
102 -- check), and we know that the exception frame is the same, and that
103 -- nothing has happened to change the result of the exception.
105 -- Let us examine each of these three conditions in turn to describe
106 -- how we ensure that this condition is met.
108 -- First, we need to know for certain that the previous expression has
109 -- been executed. This is done principally by the mechanism of calling
110 -- Conditional_Statements_Begin at the start of any statement sequence
111 -- and Conditional_Statements_End at the end. The End call causes all
112 -- checks remembered since the Begin call to be discarded. This does
113 -- miss a few cases, notably the case of a nested BEGIN-END block with
114 -- no exception handlers. But the important thing is to be conservative.
115 -- The other protection is that all checks are discarded if a label
116 -- is encountered, since then the assumption of sequential execution
117 -- is violated, and we don't know enough about the flow.
119 -- Second, we need to know that the exception frame is the same. We
120 -- do this by killing all remembered checks when we enter a new frame.
121 -- Again, that's over-conservative, but generally the cases we can help
122 -- with are pretty local anyway (like the body of a loop for example).
124 -- Third, we must be sure to forget any checks which are no longer valid.
125 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
126 -- used to note any changes to local variables. We only attempt to deal
127 -- with checks involving local variables, so we do not need to worry
128 -- about global variables. Second, a call to any non-global procedure
129 -- causes us to abandon all stored checks, since such a all may affect
130 -- the values of any local variables.
132 -- The following define the data structures used to deal with remembering
133 -- checks so that redundant checks can be eliminated as described above.
135 -- Right now, the only expressions that we deal with are of the form of
136 -- simple local objects (either declared locally, or IN parameters) or
137 -- such objects plus/minus a compile time known constant. We can do
138 -- more later on if it seems worthwhile, but this catches many simple
139 -- cases in practice.
141 -- The following record type reflects a single saved check. An entry
142 -- is made in the stack of saved checks if and only if the expression
143 -- has been elaborated with the indicated checks.
145 type Saved_Check
is record
147 -- Set True if entry is killed by Kill_Checks
150 -- The entity involved in the expression that is checked
153 -- A compile time value indicating the result of adding or
154 -- subtracting a compile time value. This value is to be
155 -- added to the value of the Entity. A value of zero is
156 -- used for the case of a simple entity reference.
158 Check_Type
: Character;
159 -- This is set to 'R' for a range check (in which case Target_Type
160 -- is set to the target type for the range check) or to 'O' for an
161 -- overflow check (in which case Target_Type is set to Empty).
163 Target_Type
: Entity_Id
;
164 -- Used only if Do_Range_Check is set. Records the target type for
165 -- the check. We need this, because a check is a duplicate only if
166 -- it has the same target type (or more accurately one with a
167 -- range that is smaller or equal to the stored target type of a
171 -- The following table keeps track of saved checks. Rather than use an
172 -- extensible table, we just use a table of fixed size, and we discard
173 -- any saved checks that do not fit. That's very unlikely to happen and
174 -- this is only an optimization in any case.
176 Saved_Checks
: array (Int
range 1 .. 200) of Saved_Check
;
177 -- Array of saved checks
179 Num_Saved_Checks
: Nat
:= 0;
180 -- Number of saved checks
182 -- The following stack keeps track of statement ranges. It is treated
183 -- as a stack. When Conditional_Statements_Begin is called, an entry
184 -- is pushed onto this stack containing the value of Num_Saved_Checks
185 -- at the time of the call. Then when Conditional_Statements_End is
186 -- called, this value is popped off and used to reset Num_Saved_Checks.
188 -- Note: again, this is a fixed length stack with a size that should
189 -- always be fine. If the value of the stack pointer goes above the
190 -- limit, then we just forget all saved checks.
192 Saved_Checks_Stack
: array (Int
range 1 .. 100) of Nat
;
193 Saved_Checks_TOS
: Nat
:= 0;
195 -----------------------
196 -- Local Subprograms --
197 -----------------------
199 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
);
200 -- Used to apply arithmetic overflow checks for all cases except operators
201 -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we
202 -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a
203 -- signed integer arithmetic operator (but not an if or case expression).
204 -- It is also called for types other than signed integers.
206 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
);
207 -- Used to apply arithmetic overflow checks for the case where the overflow
208 -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer
209 -- arithmetic op (which includes the case of if and case expressions). Note
210 -- that Do_Overflow_Check may or may not be set for node Op. In these modes
211 -- we have work to do even if overflow checking is suppressed.
213 procedure Apply_Division_Check
218 -- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies
219 -- division checks as required if the Do_Division_Check flag is set.
220 -- Rlo and Rhi give the possible range of the right operand, these values
221 -- can be referenced and trusted only if ROK is set True.
223 procedure Apply_Float_Conversion_Check
225 Target_Typ
: Entity_Id
);
226 -- The checks on a conversion from a floating-point type to an integer
227 -- type are delicate. They have to be performed before conversion, they
228 -- have to raise an exception when the operand is a NaN, and rounding must
229 -- be taken into account to determine the safe bounds of the operand.
231 procedure Apply_Selected_Length_Checks
233 Target_Typ
: Entity_Id
;
234 Source_Typ
: Entity_Id
;
235 Do_Static
: Boolean);
236 -- This is the subprogram that does all the work for Apply_Length_Check
237 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
238 -- described for the above routines. The Do_Static flag indicates that
239 -- only a static check is to be done.
241 procedure Apply_Selected_Range_Checks
243 Target_Typ
: Entity_Id
;
244 Source_Typ
: Entity_Id
;
245 Do_Static
: Boolean);
246 -- This is the subprogram that does all the work for Apply_Range_Check.
247 -- Expr, Target_Typ and Source_Typ are as described for the above
248 -- routine. The Do_Static flag indicates that only a static check is
251 type Check_Type
is new Check_Id
range Access_Check
.. Division_Check
;
252 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean;
253 -- This function is used to see if an access or division by zero check is
254 -- needed. The check is to be applied to a single variable appearing in the
255 -- source, and N is the node for the reference. If N is not of this form,
256 -- True is returned with no further processing. If N is of the right form,
257 -- then further processing determines if the given Check is needed.
259 -- The particular circuit is to see if we have the case of a check that is
260 -- not needed because it appears in the right operand of a short circuited
261 -- conditional where the left operand guards the check. For example:
263 -- if Var = 0 or else Q / Var > 12 then
267 -- In this example, the division check is not required. At the same time
268 -- we can issue warnings for suspicious use of non-short-circuited forms,
271 -- if Var = 0 or Q / Var > 12 then
277 Check_Type
: Character;
278 Target_Type
: Entity_Id
;
279 Entry_OK
: out Boolean;
283 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
284 -- to see if a check is of the form for optimization, and if so, to see
285 -- if it has already been performed. Expr is the expression to check,
286 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
287 -- Target_Type is the target type for a range check, and Empty for an
288 -- overflow check. If the entry is not of the form for optimization,
289 -- then Entry_OK is set to False, and the remaining out parameters
290 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
291 -- entity and offset from the expression. Check_Num is the number of
292 -- a matching saved entry in Saved_Checks, or zero if no such entry
295 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
;
296 -- If a discriminal is used in constraining a prival, Return reference
297 -- to the discriminal of the protected body (which renames the parameter
298 -- of the enclosing protected operation). This clumsy transformation is
299 -- needed because privals are created too late and their actual subtypes
300 -- are not available when analysing the bodies of the protected operations.
301 -- This function is called whenever the bound is an entity and the scope
302 -- indicates a protected operation. If the bound is an in-parameter of
303 -- a protected operation that is not a prival, the function returns the
305 -- To be cleaned up???
307 function Guard_Access
310 Ck_Node
: Node_Id
) return Node_Id
;
311 -- In the access type case, guard the test with a test to ensure
312 -- that the access value is non-null, since the checks do not
313 -- not apply to null access values.
315 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
);
316 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
317 -- Constraint_Error node.
319 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean;
320 -- Returns True if node N is for an arithmetic operation with signed
321 -- integer operands. This includes unary and binary operators, and also
322 -- if and case expression nodes where the dependent expressions are of
323 -- a signed integer type. These are the kinds of nodes for which special
324 -- handling applies in MINIMIZED or ELIMINATED overflow checking mode.
326 function Range_Or_Validity_Checks_Suppressed
327 (Expr
: Node_Id
) return Boolean;
328 -- Returns True if either range or validity checks or both are suppressed
329 -- for the type of the given expression, or, if the expression is the name
330 -- of an entity, if these checks are suppressed for the entity.
332 function Selected_Length_Checks
334 Target_Typ
: Entity_Id
;
335 Source_Typ
: Entity_Id
;
336 Warn_Node
: Node_Id
) return Check_Result
;
337 -- Like Apply_Selected_Length_Checks, except it doesn't modify
338 -- anything, just returns a list of nodes as described in the spec of
339 -- this package for the Range_Check function.
341 function Selected_Range_Checks
343 Target_Typ
: Entity_Id
;
344 Source_Typ
: Entity_Id
;
345 Warn_Node
: Node_Id
) return Check_Result
;
346 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
347 -- just returns a list of nodes as described in the spec of this package
348 -- for the Range_Check function.
350 ------------------------------
351 -- Access_Checks_Suppressed --
352 ------------------------------
354 function Access_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
356 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
357 return Is_Check_Suppressed
(E
, Access_Check
);
359 return Scope_Suppress
.Suppress
(Access_Check
);
361 end Access_Checks_Suppressed
;
363 -------------------------------------
364 -- Accessibility_Checks_Suppressed --
365 -------------------------------------
367 function Accessibility_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
369 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
370 return Is_Check_Suppressed
(E
, Accessibility_Check
);
372 return Scope_Suppress
.Suppress
(Accessibility_Check
);
374 end Accessibility_Checks_Suppressed
;
376 -----------------------------
377 -- Activate_Division_Check --
378 -----------------------------
380 procedure Activate_Division_Check
(N
: Node_Id
) is
382 Set_Do_Division_Check
(N
, True);
383 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
384 end Activate_Division_Check
;
386 -----------------------------
387 -- Activate_Overflow_Check --
388 -----------------------------
390 procedure Activate_Overflow_Check
(N
: Node_Id
) is
391 Typ
: constant Entity_Id
:= Etype
(N
);
394 -- Floating-point case. If Etype is not set (this can happen when we
395 -- activate a check on a node that has not yet been analyzed), then
396 -- we assume we do not have a floating-point type (as per our spec).
398 if Present
(Typ
) and then Is_Floating_Point_Type
(Typ
) then
400 -- Ignore call if we have no automatic overflow checks on the target
401 -- and Check_Float_Overflow mode is not set. These are the cases in
402 -- which we expect to generate infinities and NaN's with no check.
404 if not (Machine_Overflows_On_Target
or Check_Float_Overflow
) then
407 -- Ignore for unary operations ("+", "-", abs) since these can never
408 -- result in overflow for floating-point cases.
410 elsif Nkind
(N
) in N_Unary_Op
then
413 -- Otherwise we will set the flag
422 -- Nothing to do for Rem/Mod/Plus (overflow not possible, the check
423 -- for zero-divide is a divide check, not an overflow check).
425 if Nkind_In
(N
, N_Op_Rem
, N_Op_Mod
, N_Op_Plus
) then
430 -- Fall through for cases where we do set the flag
432 Set_Do_Overflow_Check
(N
, True);
433 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
434 end Activate_Overflow_Check
;
436 --------------------------
437 -- Activate_Range_Check --
438 --------------------------
440 procedure Activate_Range_Check
(N
: Node_Id
) is
442 Set_Do_Range_Check
(N
, True);
443 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
444 end Activate_Range_Check
;
446 ---------------------------------
447 -- Alignment_Checks_Suppressed --
448 ---------------------------------
450 function Alignment_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
452 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
453 return Is_Check_Suppressed
(E
, Alignment_Check
);
455 return Scope_Suppress
.Suppress
(Alignment_Check
);
457 end Alignment_Checks_Suppressed
;
459 ----------------------------------
460 -- Allocation_Checks_Suppressed --
461 ----------------------------------
463 -- Note: at the current time there are no calls to this function, because
464 -- the relevant check is in the run-time, so it is not a check that the
465 -- compiler can suppress anyway, but we still have to recognize the check
466 -- name Allocation_Check since it is part of the standard.
468 function Allocation_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
470 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
471 return Is_Check_Suppressed
(E
, Allocation_Check
);
473 return Scope_Suppress
.Suppress
(Allocation_Check
);
475 end Allocation_Checks_Suppressed
;
477 -------------------------
478 -- Append_Range_Checks --
479 -------------------------
481 procedure Append_Range_Checks
482 (Checks
: Check_Result
;
484 Suppress_Typ
: Entity_Id
;
485 Static_Sloc
: Source_Ptr
;
488 Internal_Flag_Node
: constant Node_Id
:= Flag_Node
;
489 Internal_Static_Sloc
: constant Source_Ptr
:= Static_Sloc
;
491 Checks_On
: constant Boolean :=
492 (not Index_Checks_Suppressed
(Suppress_Typ
))
493 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
496 -- For now we just return if Checks_On is false, however this should
497 -- be enhanced to check for an always True value in the condition
498 -- and to generate a compilation warning???
500 if not Checks_On
then
505 exit when No
(Checks
(J
));
507 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
508 and then Present
(Condition
(Checks
(J
)))
510 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
511 Append_To
(Stmts
, Checks
(J
));
512 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
518 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
519 Reason
=> CE_Range_Check_Failed
));
522 end Append_Range_Checks
;
524 ------------------------
525 -- Apply_Access_Check --
526 ------------------------
528 procedure Apply_Access_Check
(N
: Node_Id
) is
529 P
: constant Node_Id
:= Prefix
(N
);
532 -- We do not need checks if we are not generating code (i.e. the
533 -- expander is not active). This is not just an optimization, there
534 -- are cases (e.g. with pragma Debug) where generating the checks
535 -- can cause real trouble).
537 if not Expander_Active
then
541 -- No check if short circuiting makes check unnecessary
543 if not Check_Needed
(P
, Access_Check
) then
547 -- No check if accessing the Offset_To_Top component of a dispatch
548 -- table. They are safe by construction.
550 if Tagged_Type_Expansion
551 and then Present
(Etype
(P
))
552 and then RTU_Loaded
(Ada_Tags
)
553 and then RTE_Available
(RE_Offset_To_Top_Ptr
)
554 and then Etype
(P
) = RTE
(RE_Offset_To_Top_Ptr
)
559 -- Otherwise go ahead and install the check
561 Install_Null_Excluding_Check
(P
);
562 end Apply_Access_Check
;
564 -------------------------------
565 -- Apply_Accessibility_Check --
566 -------------------------------
568 procedure Apply_Accessibility_Check
571 Insert_Node
: Node_Id
)
573 Loc
: constant Source_Ptr
:= Sloc
(N
);
574 Param_Ent
: Entity_Id
:= Param_Entity
(N
);
575 Param_Level
: Node_Id
;
576 Type_Level
: Node_Id
;
579 if Ada_Version
>= Ada_2012
580 and then not Present
(Param_Ent
)
581 and then Is_Entity_Name
(N
)
582 and then Ekind_In
(Entity
(N
), E_Constant
, E_Variable
)
583 and then Present
(Effective_Extra_Accessibility
(Entity
(N
)))
585 Param_Ent
:= Entity
(N
);
586 while Present
(Renamed_Object
(Param_Ent
)) loop
588 -- Renamed_Object must return an Entity_Name here
589 -- because of preceding "Present (E_E_A (...))" test.
591 Param_Ent
:= Entity
(Renamed_Object
(Param_Ent
));
595 if Inside_A_Generic
then
598 -- Only apply the run-time check if the access parameter has an
599 -- associated extra access level parameter and when the level of the
600 -- type is less deep than the level of the access parameter, and
601 -- accessibility checks are not suppressed.
603 elsif Present
(Param_Ent
)
604 and then Present
(Extra_Accessibility
(Param_Ent
))
605 and then UI_Gt
(Object_Access_Level
(N
),
606 Deepest_Type_Access_Level
(Typ
))
607 and then not Accessibility_Checks_Suppressed
(Param_Ent
)
608 and then not Accessibility_Checks_Suppressed
(Typ
)
611 New_Occurrence_Of
(Extra_Accessibility
(Param_Ent
), Loc
);
614 Make_Integer_Literal
(Loc
, Deepest_Type_Access_Level
(Typ
));
616 -- Raise Program_Error if the accessibility level of the access
617 -- parameter is deeper than the level of the target access type.
619 Insert_Action
(Insert_Node
,
620 Make_Raise_Program_Error
(Loc
,
623 Left_Opnd
=> Param_Level
,
624 Right_Opnd
=> Type_Level
),
625 Reason
=> PE_Accessibility_Check_Failed
));
627 Analyze_And_Resolve
(N
);
629 end Apply_Accessibility_Check
;
631 --------------------------------
632 -- Apply_Address_Clause_Check --
633 --------------------------------
635 procedure Apply_Address_Clause_Check
(E
: Entity_Id
; N
: Node_Id
) is
636 pragma Assert
(Nkind
(N
) = N_Freeze_Entity
);
638 AC
: constant Node_Id
:= Address_Clause
(E
);
639 Loc
: constant Source_Ptr
:= Sloc
(AC
);
640 Typ
: constant Entity_Id
:= Etype
(E
);
641 Aexp
: constant Node_Id
:= Expression
(AC
);
644 -- Address expression (not necessarily the same as Aexp, for example
645 -- when Aexp is a reference to a constant, in which case Expr gets
646 -- reset to reference the value expression of the constant).
648 procedure Compile_Time_Bad_Alignment
;
649 -- Post error warnings when alignment is known to be incompatible. Note
650 -- that we do not go as far as inserting a raise of Program_Error since
651 -- this is an erroneous case, and it may happen that we are lucky and an
652 -- underaligned address turns out to be OK after all.
654 --------------------------------
655 -- Compile_Time_Bad_Alignment --
656 --------------------------------
658 procedure Compile_Time_Bad_Alignment
is
660 if Address_Clause_Overlay_Warnings
then
662 ("?o?specified address for& may be inconsistent with alignment",
665 ("\?o?program execution may be erroneous (RM 13.3(27))",
667 Set_Address_Warning_Posted
(AC
);
669 end Compile_Time_Bad_Alignment
;
671 -- Start of processing for Apply_Address_Clause_Check
674 -- See if alignment check needed. Note that we never need a check if the
675 -- maximum alignment is one, since the check will always succeed.
677 -- Note: we do not check for checks suppressed here, since that check
678 -- was done in Sem_Ch13 when the address clause was processed. We are
679 -- only called if checks were not suppressed. The reason for this is
680 -- that we have to delay the call to Apply_Alignment_Check till freeze
681 -- time (so that all types etc are elaborated), but we have to check
682 -- the status of check suppressing at the point of the address clause.
685 or else not Check_Address_Alignment
(AC
)
686 or else Maximum_Alignment
= 1
691 -- Obtain expression from address clause
693 Expr
:= Expression
(AC
);
695 -- The following loop digs for the real expression to use in the check
698 -- For constant, get constant expression
700 if Is_Entity_Name
(Expr
)
701 and then Ekind
(Entity
(Expr
)) = E_Constant
703 Expr
:= Constant_Value
(Entity
(Expr
));
705 -- For unchecked conversion, get result to convert
707 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
708 Expr
:= Expression
(Expr
);
710 -- For (common case) of To_Address call, get argument
712 elsif Nkind
(Expr
) = N_Function_Call
713 and then Is_Entity_Name
(Name
(Expr
))
714 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
716 Expr
:= First
(Parameter_Associations
(Expr
));
718 if Nkind
(Expr
) = N_Parameter_Association
then
719 Expr
:= Explicit_Actual_Parameter
(Expr
);
722 -- We finally have the real expression
729 -- See if we know that Expr has a bad alignment at compile time
731 if Compile_Time_Known_Value
(Expr
)
732 and then (Known_Alignment
(E
) or else Known_Alignment
(Typ
))
735 AL
: Uint
:= Alignment
(Typ
);
738 -- The object alignment might be more restrictive than the
741 if Known_Alignment
(E
) then
745 if Expr_Value
(Expr
) mod AL
/= 0 then
746 Compile_Time_Bad_Alignment
;
752 -- If the expression has the form X'Address, then we can find out if the
753 -- object X has an alignment that is compatible with the object E. If it
754 -- hasn't or we don't know, we defer issuing the warning until the end
755 -- of the compilation to take into account back end annotations.
757 elsif Nkind
(Expr
) = N_Attribute_Reference
758 and then Attribute_Name
(Expr
) = Name_Address
760 Has_Compatible_Alignment
(E
, Prefix
(Expr
), False) = Known_Compatible
765 -- Here we do not know if the value is acceptable. Strictly we don't
766 -- have to do anything, since if the alignment is bad, we have an
767 -- erroneous program. However we are allowed to check for erroneous
768 -- conditions and we decide to do this by default if the check is not
771 -- However, don't do the check if elaboration code is unwanted
773 if Restriction_Active
(No_Elaboration_Code
) then
776 -- Generate a check to raise PE if alignment may be inappropriate
779 -- If the original expression is a non-static constant, use the
780 -- name of the constant itself rather than duplicating its
781 -- defining expression, which was extracted above.
783 -- Note: Expr is empty if the address-clause is applied to in-mode
784 -- actuals (allowed by 13.1(22)).
786 if not Present
(Expr
)
788 (Is_Entity_Name
(Expression
(AC
))
789 and then Ekind
(Entity
(Expression
(AC
))) = E_Constant
790 and then Nkind
(Parent
(Entity
(Expression
(AC
))))
791 = N_Object_Declaration
)
793 Expr
:= New_Copy_Tree
(Expression
(AC
));
795 Remove_Side_Effects
(Expr
);
798 if No
(Actions
(N
)) then
799 Set_Actions
(N
, New_List
);
802 Prepend_To
(Actions
(N
),
803 Make_Raise_Program_Error
(Loc
,
810 (RTE
(RE_Integer_Address
), Expr
),
812 Make_Attribute_Reference
(Loc
,
813 Prefix
=> New_Occurrence_Of
(E
, Loc
),
814 Attribute_Name
=> Name_Alignment
)),
815 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
816 Reason
=> PE_Misaligned_Address_Value
));
818 Warning_Msg
:= No_Error_Msg
;
819 Analyze
(First
(Actions
(N
)), Suppress
=> All_Checks
);
821 -- If the address clause generated a warning message (for example,
822 -- from Warn_On_Non_Local_Exception mode with the active restriction
823 -- No_Exception_Propagation).
825 if Warning_Msg
/= No_Error_Msg
then
827 -- If the expression has a known at compile time value, then
828 -- once we know the alignment of the type, we can check if the
829 -- exception will be raised or not, and if not, we don't need
830 -- the warning so we will kill the warning later on.
832 if Compile_Time_Known_Value
(Expr
) then
833 Alignment_Warnings
.Append
834 ((E
=> E
, A
=> Expr_Value
(Expr
), W
=> Warning_Msg
));
837 -- Add explanation of the warning that is generated by the check
840 ("\address value may be incompatible with alignment "
841 & "of object?X?", AC
);
848 -- If we have some missing run time component in configurable run time
849 -- mode then just skip the check (it is not required in any case).
851 when RE_Not_Available
=>
853 end Apply_Address_Clause_Check
;
855 -------------------------------------
856 -- Apply_Arithmetic_Overflow_Check --
857 -------------------------------------
859 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
861 -- Use old routine in almost all cases (the only case we are treating
862 -- specially is the case of a signed integer arithmetic op with the
863 -- overflow checking mode set to MINIMIZED or ELIMINATED).
865 if Overflow_Check_Mode
= Strict
866 or else not Is_Signed_Integer_Arithmetic_Op
(N
)
868 Apply_Arithmetic_Overflow_Strict
(N
);
870 -- Otherwise use the new routine for the case of a signed integer
871 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
872 -- mode is MINIMIZED or ELIMINATED.
875 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
877 end Apply_Arithmetic_Overflow_Check
;
879 --------------------------------------
880 -- Apply_Arithmetic_Overflow_Strict --
881 --------------------------------------
883 -- This routine is called only if the type is an integer type, and a
884 -- software arithmetic overflow check may be needed for op (add, subtract,
885 -- or multiply). This check is performed only if Software_Overflow_Checking
886 -- is enabled and Do_Overflow_Check is set. In this case we expand the
887 -- operation into a more complex sequence of tests that ensures that
888 -- overflow is properly caught.
890 -- This is used in CHECKED modes. It is identical to the code for this
891 -- cases before the big overflow earthquake, thus ensuring that in this
892 -- modes we have compatible behavior (and reliability) to what was there
893 -- before. It is also called for types other than signed integers, and if
894 -- the Do_Overflow_Check flag is off.
896 -- Note: we also call this routine if we decide in the MINIMIZED case
897 -- to give up and just generate an overflow check without any fuss.
899 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
) is
900 Loc
: constant Source_Ptr
:= Sloc
(N
);
901 Typ
: constant Entity_Id
:= Etype
(N
);
902 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
905 -- Nothing to do if Do_Overflow_Check not set or overflow checks
908 if not Do_Overflow_Check
(N
) then
912 -- An interesting special case. If the arithmetic operation appears as
913 -- the operand of a type conversion:
917 -- and all the following conditions apply:
919 -- arithmetic operation is for a signed integer type
920 -- target type type1 is a static integer subtype
921 -- range of x and y are both included in the range of type1
922 -- range of x op y is included in the range of type1
923 -- size of type1 is at least twice the result size of op
925 -- then we don't do an overflow check in any case. Instead, we transform
926 -- the operation so that we end up with:
928 -- type1 (type1 (x) op type1 (y))
930 -- This avoids intermediate overflow before the conversion. It is
931 -- explicitly permitted by RM 3.5.4(24):
933 -- For the execution of a predefined operation of a signed integer
934 -- type, the implementation need not raise Constraint_Error if the
935 -- result is outside the base range of the type, so long as the
936 -- correct result is produced.
938 -- It's hard to imagine that any programmer counts on the exception
939 -- being raised in this case, and in any case it's wrong coding to
940 -- have this expectation, given the RM permission. Furthermore, other
941 -- Ada compilers do allow such out of range results.
943 -- Note that we do this transformation even if overflow checking is
944 -- off, since this is precisely about giving the "right" result and
945 -- avoiding the need for an overflow check.
947 -- Note: this circuit is partially redundant with respect to the similar
948 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
949 -- with cases that do not come through here. We still need the following
950 -- processing even with the Exp_Ch4 code in place, since we want to be
951 -- sure not to generate the arithmetic overflow check in these cases
952 -- (Exp_Ch4 would have a hard time removing them once generated).
954 if Is_Signed_Integer_Type
(Typ
)
955 and then Nkind
(Parent
(N
)) = N_Type_Conversion
957 Conversion_Optimization
: declare
958 Target_Type
: constant Entity_Id
:=
959 Base_Type
(Entity
(Subtype_Mark
(Parent
(N
))));
973 if Is_Integer_Type
(Target_Type
)
974 and then RM_Size
(Root_Type
(Target_Type
)) >= 2 * RM_Size
(Rtyp
)
976 Tlo
:= Expr_Value
(Type_Low_Bound
(Target_Type
));
977 Thi
:= Expr_Value
(Type_High_Bound
(Target_Type
));
980 (Left_Opnd
(N
), LOK
, Llo
, Lhi
, Assume_Valid
=> True);
982 (Right_Opnd
(N
), ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
985 and then Tlo
<= Llo
and then Lhi
<= Thi
986 and then Tlo
<= Rlo
and then Rhi
<= Thi
988 Determine_Range
(N
, VOK
, Vlo
, Vhi
, Assume_Valid
=> True);
990 if VOK
and then Tlo
<= Vlo
and then Vhi
<= Thi
then
991 Rewrite
(Left_Opnd
(N
),
992 Make_Type_Conversion
(Loc
,
993 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
994 Expression
=> Relocate_Node
(Left_Opnd
(N
))));
996 Rewrite
(Right_Opnd
(N
),
997 Make_Type_Conversion
(Loc
,
998 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
999 Expression
=> Relocate_Node
(Right_Opnd
(N
))));
1001 -- Rewrite the conversion operand so that the original
1002 -- node is retained, in order to avoid the warning for
1003 -- redundant conversions in Resolve_Type_Conversion.
1005 Rewrite
(N
, Relocate_Node
(N
));
1007 Set_Etype
(N
, Target_Type
);
1009 Analyze_And_Resolve
(Left_Opnd
(N
), Target_Type
);
1010 Analyze_And_Resolve
(Right_Opnd
(N
), Target_Type
);
1012 -- Given that the target type is twice the size of the
1013 -- source type, overflow is now impossible, so we can
1014 -- safely kill the overflow check and return.
1016 Set_Do_Overflow_Check
(N
, False);
1021 end Conversion_Optimization
;
1024 -- Now see if an overflow check is required
1027 Siz
: constant Int
:= UI_To_Int
(Esize
(Rtyp
));
1028 Dsiz
: constant Int
:= Siz
* 2;
1035 -- Skip check if back end does overflow checks, or the overflow flag
1036 -- is not set anyway, or we are not doing code expansion, or the
1037 -- parent node is a type conversion whose operand is an arithmetic
1038 -- operation on signed integers on which the expander can promote
1039 -- later the operands to type Integer (see Expand_N_Type_Conversion).
1041 if Backend_Overflow_Checks_On_Target
1042 or else not Do_Overflow_Check
(N
)
1043 or else not Expander_Active
1044 or else (Present
(Parent
(N
))
1045 and then Nkind
(Parent
(N
)) = N_Type_Conversion
1046 and then Integer_Promotion_Possible
(Parent
(N
)))
1051 -- Otherwise, generate the full general code for front end overflow
1052 -- detection, which works by doing arithmetic in a larger type:
1058 -- Typ (Checktyp (x) op Checktyp (y));
1060 -- where Typ is the type of the original expression, and Checktyp is
1061 -- an integer type of sufficient length to hold the largest possible
1064 -- If the size of check type exceeds the size of Long_Long_Integer,
1065 -- we use a different approach, expanding to:
1067 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
1069 -- where xxx is Add, Multiply or Subtract as appropriate
1071 -- Find check type if one exists
1073 if Dsiz
<= Standard_Integer_Size
then
1074 Ctyp
:= Standard_Integer
;
1076 elsif Dsiz
<= Standard_Long_Long_Integer_Size
then
1077 Ctyp
:= Standard_Long_Long_Integer
;
1079 -- No check type exists, use runtime call
1082 if Nkind
(N
) = N_Op_Add
then
1083 Cent
:= RE_Add_With_Ovflo_Check
;
1085 elsif Nkind
(N
) = N_Op_Multiply
then
1086 Cent
:= RE_Multiply_With_Ovflo_Check
;
1089 pragma Assert
(Nkind
(N
) = N_Op_Subtract
);
1090 Cent
:= RE_Subtract_With_Ovflo_Check
;
1095 Make_Function_Call
(Loc
,
1096 Name
=> New_Occurrence_Of
(RTE
(Cent
), Loc
),
1097 Parameter_Associations
=> New_List
(
1098 OK_Convert_To
(RTE
(RE_Integer_64
), Left_Opnd
(N
)),
1099 OK_Convert_To
(RTE
(RE_Integer_64
), Right_Opnd
(N
))))));
1101 Analyze_And_Resolve
(N
, Typ
);
1105 -- If we fall through, we have the case where we do the arithmetic
1106 -- in the next higher type and get the check by conversion. In these
1107 -- cases Ctyp is set to the type to be used as the check type.
1109 Opnod
:= Relocate_Node
(N
);
1111 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
1114 Set_Etype
(Opnd
, Ctyp
);
1115 Set_Analyzed
(Opnd
, True);
1116 Set_Left_Opnd
(Opnod
, Opnd
);
1118 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
1121 Set_Etype
(Opnd
, Ctyp
);
1122 Set_Analyzed
(Opnd
, True);
1123 Set_Right_Opnd
(Opnod
, Opnd
);
1125 -- The type of the operation changes to the base type of the check
1126 -- type, and we reset the overflow check indication, since clearly no
1127 -- overflow is possible now that we are using a double length type.
1128 -- We also set the Analyzed flag to avoid a recursive attempt to
1131 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
1132 Set_Do_Overflow_Check
(Opnod
, False);
1133 Set_Analyzed
(Opnod
, True);
1135 -- Now build the outer conversion
1137 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
1139 Set_Etype
(Opnd
, Typ
);
1141 -- In the discrete type case, we directly generate the range check
1142 -- for the outer operand. This range check will implement the
1143 -- required overflow check.
1145 if Is_Discrete_Type
(Typ
) then
1147 Generate_Range_Check
1148 (Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
1150 -- For other types, we enable overflow checking on the conversion,
1151 -- after setting the node as analyzed to prevent recursive attempts
1152 -- to expand the conversion node.
1155 Set_Analyzed
(Opnd
, True);
1156 Enable_Overflow_Check
(Opnd
);
1161 when RE_Not_Available
=>
1164 end Apply_Arithmetic_Overflow_Strict
;
1166 ----------------------------------------------------
1167 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1168 ----------------------------------------------------
1170 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
) is
1171 pragma Assert
(Is_Signed_Integer_Arithmetic_Op
(Op
));
1173 Loc
: constant Source_Ptr
:= Sloc
(Op
);
1174 P
: constant Node_Id
:= Parent
(Op
);
1176 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
1177 -- Operands and results are of this type when we convert
1179 Result_Type
: constant Entity_Id
:= Etype
(Op
);
1180 -- Original result type
1182 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1183 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
1186 -- Ranges of values for result
1189 -- Nothing to do if our parent is one of the following:
1191 -- Another signed integer arithmetic op
1192 -- A membership operation
1193 -- A comparison operation
1195 -- In all these cases, we will process at the higher level (and then
1196 -- this node will be processed during the downwards recursion that
1197 -- is part of the processing in Minimize_Eliminate_Overflows).
1199 if Is_Signed_Integer_Arithmetic_Op
(P
)
1200 or else Nkind
(P
) in N_Membership_Test
1201 or else Nkind
(P
) in N_Op_Compare
1203 -- This is also true for an alternative in a case expression
1205 or else Nkind
(P
) = N_Case_Expression_Alternative
1207 -- This is also true for a range operand in a membership test
1209 or else (Nkind
(P
) = N_Range
1210 and then Nkind
(Parent
(P
)) in N_Membership_Test
)
1212 -- If_Expressions and Case_Expressions are treated as arithmetic
1213 -- ops, but if they appear in an assignment or similar contexts
1214 -- there is no overflow check that starts from that parent node,
1215 -- so apply check now.
1217 if Nkind_In
(P
, N_If_Expression
, N_Case_Expression
)
1218 and then not Is_Signed_Integer_Arithmetic_Op
(Parent
(P
))
1226 -- Otherwise, we have a top level arithmetic operation node, and this
1227 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1228 -- modes. This is the case where we tell the machinery not to move into
1229 -- Bignum mode at this top level (of course the top level operation
1230 -- will still be in Bignum mode if either of its operands are of type
1233 Minimize_Eliminate_Overflows
(Op
, Lo
, Hi
, Top_Level
=> True);
1235 -- That call may but does not necessarily change the result type of Op.
1236 -- It is the job of this routine to undo such changes, so that at the
1237 -- top level, we have the proper type. This "undoing" is a point at
1238 -- which a final overflow check may be applied.
1240 -- If the result type was not fiddled we are all set. We go to base
1241 -- types here because things may have been rewritten to generate the
1242 -- base type of the operand types.
1244 if Base_Type
(Etype
(Op
)) = Base_Type
(Result_Type
) then
1249 elsif Is_RTE
(Etype
(Op
), RE_Bignum
) then
1251 -- We need a sequence that looks like:
1253 -- Rnn : Result_Type;
1256 -- M : Mark_Id := SS_Mark;
1258 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1262 -- This block is inserted (using Insert_Actions), and then the node
1263 -- is replaced with a reference to Rnn.
1265 -- If our parent is a conversion node then there is no point in
1266 -- generating a conversion to Result_Type. Instead, we let the parent
1267 -- handle this. Note that this special case is not just about
1268 -- optimization. Consider
1272 -- X := Long_Long_Integer'Base (A * (B ** C));
1274 -- Now the product may fit in Long_Long_Integer but not in Integer.
1275 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1276 -- overflow exception for this intermediate value.
1279 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
1280 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R', Op
);
1286 RHS
:= Convert_From_Bignum
(Op
);
1288 if Nkind
(P
) /= N_Type_Conversion
then
1289 Convert_To_And_Rewrite
(Result_Type
, RHS
);
1290 Rtype
:= Result_Type
;
1292 -- Interesting question, do we need a check on that conversion
1293 -- operation. Answer, not if we know the result is in range.
1294 -- At the moment we are not taking advantage of this. To be
1295 -- looked at later ???
1302 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
1303 Make_Assignment_Statement
(Loc
,
1304 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
1305 Expression
=> RHS
));
1307 Insert_Actions
(Op
, New_List
(
1308 Make_Object_Declaration
(Loc
,
1309 Defining_Identifier
=> Rnn
,
1310 Object_Definition
=> New_Occurrence_Of
(Rtype
, Loc
)),
1313 Rewrite
(Op
, New_Occurrence_Of
(Rnn
, Loc
));
1314 Analyze_And_Resolve
(Op
);
1317 -- Here we know the result is Long_Long_Integer'Base, or that it has
1318 -- been rewritten because the parent operation is a conversion. See
1319 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1323 (Etype
(Op
) = LLIB
or else Nkind
(Parent
(Op
)) = N_Type_Conversion
);
1325 -- All we need to do here is to convert the result to the proper
1326 -- result type. As explained above for the Bignum case, we can
1327 -- omit this if our parent is a type conversion.
1329 if Nkind
(P
) /= N_Type_Conversion
then
1330 Convert_To_And_Rewrite
(Result_Type
, Op
);
1333 Analyze_And_Resolve
(Op
);
1335 end Apply_Arithmetic_Overflow_Minimized_Eliminated
;
1337 ----------------------------
1338 -- Apply_Constraint_Check --
1339 ----------------------------
1341 procedure Apply_Constraint_Check
1344 No_Sliding
: Boolean := False)
1346 Desig_Typ
: Entity_Id
;
1349 -- No checks inside a generic (check the instantiations)
1351 if Inside_A_Generic
then
1355 -- Apply required constraint checks
1357 if Is_Scalar_Type
(Typ
) then
1358 Apply_Scalar_Range_Check
(N
, Typ
);
1360 elsif Is_Array_Type
(Typ
) then
1362 -- A useful optimization: an aggregate with only an others clause
1363 -- always has the right bounds.
1365 if Nkind
(N
) = N_Aggregate
1366 and then No
(Expressions
(N
))
1368 (First
(Choices
(First
(Component_Associations
(N
)))))
1374 if Is_Constrained
(Typ
) then
1375 Apply_Length_Check
(N
, Typ
);
1378 Apply_Range_Check
(N
, Typ
);
1381 Apply_Range_Check
(N
, Typ
);
1384 elsif (Is_Record_Type
(Typ
) or else Is_Private_Type
(Typ
))
1385 and then Has_Discriminants
(Base_Type
(Typ
))
1386 and then Is_Constrained
(Typ
)
1388 Apply_Discriminant_Check
(N
, Typ
);
1390 elsif Is_Access_Type
(Typ
) then
1392 Desig_Typ
:= Designated_Type
(Typ
);
1394 -- No checks necessary if expression statically null
1396 if Known_Null
(N
) then
1397 if Can_Never_Be_Null
(Typ
) then
1398 Install_Null_Excluding_Check
(N
);
1401 -- No sliding possible on access to arrays
1403 elsif Is_Array_Type
(Desig_Typ
) then
1404 if Is_Constrained
(Desig_Typ
) then
1405 Apply_Length_Check
(N
, Typ
);
1408 Apply_Range_Check
(N
, Typ
);
1410 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
1411 and then Is_Constrained
(Desig_Typ
)
1413 Apply_Discriminant_Check
(N
, Typ
);
1416 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1417 -- this check if the constraint node is illegal, as shown by having
1418 -- an error posted. This additional guard prevents cascaded errors
1419 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1421 if Can_Never_Be_Null
(Typ
)
1422 and then not Can_Never_Be_Null
(Etype
(N
))
1423 and then not Error_Posted
(N
)
1425 Install_Null_Excluding_Check
(N
);
1428 end Apply_Constraint_Check
;
1430 ------------------------------
1431 -- Apply_Discriminant_Check --
1432 ------------------------------
1434 procedure Apply_Discriminant_Check
1437 Lhs
: Node_Id
:= Empty
)
1439 Loc
: constant Source_Ptr
:= Sloc
(N
);
1440 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1441 S_Typ
: Entity_Id
:= Etype
(N
);
1445 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean;
1446 -- A heap object with an indefinite subtype is constrained by its
1447 -- initial value, and assigning to it requires a constraint_check.
1448 -- The target may be an explicit dereference, or a renaming of one.
1450 function Is_Aliased_Unconstrained_Component
return Boolean;
1451 -- It is possible for an aliased component to have a nominal
1452 -- unconstrained subtype (through instantiation). If this is a
1453 -- discriminated component assigned in the expansion of an aggregate
1454 -- in an initialization, the check must be suppressed. This unusual
1455 -- situation requires a predicate of its own.
1457 ----------------------------------
1458 -- Denotes_Explicit_Dereference --
1459 ----------------------------------
1461 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean is
1464 Nkind
(Obj
) = N_Explicit_Dereference
1466 (Is_Entity_Name
(Obj
)
1467 and then Present
(Renamed_Object
(Entity
(Obj
)))
1468 and then Nkind
(Renamed_Object
(Entity
(Obj
))) =
1469 N_Explicit_Dereference
);
1470 end Denotes_Explicit_Dereference
;
1472 ----------------------------------------
1473 -- Is_Aliased_Unconstrained_Component --
1474 ----------------------------------------
1476 function Is_Aliased_Unconstrained_Component
return Boolean is
1481 if Nkind
(Lhs
) /= N_Selected_Component
then
1484 Comp
:= Entity
(Selector_Name
(Lhs
));
1485 Pref
:= Prefix
(Lhs
);
1488 if Ekind
(Comp
) /= E_Component
1489 or else not Is_Aliased
(Comp
)
1494 return not Comes_From_Source
(Pref
)
1495 and then In_Instance
1496 and then not Is_Constrained
(Etype
(Comp
));
1497 end Is_Aliased_Unconstrained_Component
;
1499 -- Start of processing for Apply_Discriminant_Check
1503 T_Typ
:= Designated_Type
(Typ
);
1508 -- Nothing to do if discriminant checks are suppressed or else no code
1509 -- is to be generated
1511 if not Expander_Active
1512 or else Discriminant_Checks_Suppressed
(T_Typ
)
1517 -- No discriminant checks necessary for an access when expression is
1518 -- statically Null. This is not only an optimization, it is fundamental
1519 -- because otherwise discriminant checks may be generated in init procs
1520 -- for types containing an access to a not-yet-frozen record, causing a
1521 -- deadly forward reference.
1523 -- Also, if the expression is of an access type whose designated type is
1524 -- incomplete, then the access value must be null and we suppress the
1527 if Known_Null
(N
) then
1530 elsif Is_Access_Type
(S_Typ
) then
1531 S_Typ
:= Designated_Type
(S_Typ
);
1533 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1538 -- If an assignment target is present, then we need to generate the
1539 -- actual subtype if the target is a parameter or aliased object with
1540 -- an unconstrained nominal subtype.
1542 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1543 -- subtype to the parameter and dereference cases, since other aliased
1544 -- objects are unconstrained (unless the nominal subtype is explicitly
1548 and then (Present
(Param_Entity
(Lhs
))
1549 or else (Ada_Version
< Ada_2005
1550 and then not Is_Constrained
(T_Typ
)
1551 and then Is_Aliased_View
(Lhs
)
1552 and then not Is_Aliased_Unconstrained_Component
)
1553 or else (Ada_Version
>= Ada_2005
1554 and then not Is_Constrained
(T_Typ
)
1555 and then Denotes_Explicit_Dereference
(Lhs
)
1556 and then Nkind
(Original_Node
(Lhs
)) /=
1559 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1562 -- Nothing to do if the type is unconstrained (this is the case where
1563 -- the actual subtype in the RM sense of N is unconstrained and no check
1566 if not Is_Constrained
(T_Typ
) then
1569 -- Ada 2005: nothing to do if the type is one for which there is a
1570 -- partial view that is constrained.
1572 elsif Ada_Version
>= Ada_2005
1573 and then Object_Type_Has_Constrained_Partial_View
1574 (Typ
=> Base_Type
(T_Typ
),
1575 Scop
=> Current_Scope
)
1580 -- Nothing to do if the type is an Unchecked_Union
1582 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
1586 -- Suppress checks if the subtypes are the same. The check must be
1587 -- preserved in an assignment to a formal, because the constraint is
1588 -- given by the actual.
1590 if Nkind
(Original_Node
(N
)) /= N_Allocator
1592 or else not Is_Entity_Name
(Lhs
)
1593 or else No
(Param_Entity
(Lhs
)))
1596 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1597 and then not Is_Aliased_View
(Lhs
)
1602 -- We can also eliminate checks on allocators with a subtype mark that
1603 -- coincides with the context type. The context type may be a subtype
1604 -- without a constraint (common case, a generic actual).
1606 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1607 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1610 Alloc_Typ
: constant Entity_Id
:=
1611 Entity
(Expression
(Original_Node
(N
)));
1614 if Alloc_Typ
= T_Typ
1615 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1616 and then Is_Entity_Name
(
1617 Subtype_Indication
(Parent
(T_Typ
)))
1618 and then Alloc_Typ
= Base_Type
(T_Typ
))
1626 -- See if we have a case where the types are both constrained, and all
1627 -- the constraints are constants. In this case, we can do the check
1628 -- successfully at compile time.
1630 -- We skip this check for the case where the node is rewritten as
1631 -- an allocator, because it already carries the context subtype,
1632 -- and extracting the discriminants from the aggregate is messy.
1634 if Is_Constrained
(S_Typ
)
1635 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1645 -- S_Typ may not have discriminants in the case where it is a
1646 -- private type completed by a default discriminated type. In that
1647 -- case, we need to get the constraints from the underlying type.
1648 -- If the underlying type is unconstrained (i.e. has no default
1649 -- discriminants) no check is needed.
1651 if Has_Discriminants
(S_Typ
) then
1652 Discr
:= First_Discriminant
(S_Typ
);
1653 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1656 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1659 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1665 -- A further optimization: if T_Typ is derived from S_Typ
1666 -- without imposing a constraint, no check is needed.
1668 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1669 N_Full_Type_Declaration
1672 Type_Def
: constant Node_Id
:=
1673 Type_Definition
(Original_Node
(Parent
(T_Typ
)));
1675 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1676 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1677 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1685 -- Constraint may appear in full view of type
1687 if Ekind
(T_Typ
) = E_Private_Subtype
1688 and then Present
(Full_View
(T_Typ
))
1691 First_Elmt
(Discriminant_Constraint
(Full_View
(T_Typ
)));
1694 First_Elmt
(Discriminant_Constraint
(T_Typ
));
1697 while Present
(Discr
) loop
1698 ItemS
:= Node
(DconS
);
1699 ItemT
:= Node
(DconT
);
1701 -- For a discriminated component type constrained by the
1702 -- current instance of an enclosing type, there is no
1703 -- applicable discriminant check.
1705 if Nkind
(ItemT
) = N_Attribute_Reference
1706 and then Is_Access_Type
(Etype
(ItemT
))
1707 and then Is_Entity_Name
(Prefix
(ItemT
))
1708 and then Is_Type
(Entity
(Prefix
(ItemT
)))
1713 -- If the expressions for the discriminants are identical
1714 -- and it is side-effect free (for now just an entity),
1715 -- this may be a shared constraint, e.g. from a subtype
1716 -- without a constraint introduced as a generic actual.
1717 -- Examine other discriminants if any.
1720 and then Is_Entity_Name
(ItemS
)
1724 elsif not Is_OK_Static_Expression
(ItemS
)
1725 or else not Is_OK_Static_Expression
(ItemT
)
1729 elsif Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1730 if Do_Access
then -- needs run-time check.
1733 Apply_Compile_Time_Constraint_Error
1734 (N
, "incorrect value for discriminant&??",
1735 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1742 Next_Discriminant
(Discr
);
1751 -- Here we need a discriminant check. First build the expression
1752 -- for the comparisons of the discriminants:
1754 -- (n.disc1 /= typ.disc1) or else
1755 -- (n.disc2 /= typ.disc2) or else
1757 -- (n.discn /= typ.discn)
1759 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1761 -- If Lhs is set and is a parameter, then the condition is guarded by:
1762 -- lhs'constrained and then (condition built above)
1764 if Present
(Param_Entity
(Lhs
)) then
1768 Make_Attribute_Reference
(Loc
,
1769 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1770 Attribute_Name
=> Name_Constrained
),
1771 Right_Opnd
=> Cond
);
1775 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1779 Make_Raise_Constraint_Error
(Loc
,
1781 Reason
=> CE_Discriminant_Check_Failed
));
1782 end Apply_Discriminant_Check
;
1784 -------------------------
1785 -- Apply_Divide_Checks --
1786 -------------------------
1788 procedure Apply_Divide_Checks
(N
: Node_Id
) is
1789 Loc
: constant Source_Ptr
:= Sloc
(N
);
1790 Typ
: constant Entity_Id
:= Etype
(N
);
1791 Left
: constant Node_Id
:= Left_Opnd
(N
);
1792 Right
: constant Node_Id
:= Right_Opnd
(N
);
1794 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1795 -- Current overflow checking mode
1805 pragma Warnings
(Off
, Lhi
);
1806 -- Don't actually use this value
1809 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1810 -- operating on signed integer types, then the only thing this routine
1811 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1812 -- procedure will (possibly later on during recursive downward calls),
1813 -- ensure that any needed overflow/division checks are properly applied.
1815 if Mode
in Minimized_Or_Eliminated
1816 and then Is_Signed_Integer_Type
(Typ
)
1818 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
1822 -- Proceed here in SUPPRESSED or CHECKED modes
1825 and then not Backend_Divide_Checks_On_Target
1826 and then Check_Needed
(Right
, Division_Check
)
1828 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
1830 -- Deal with division check
1832 if Do_Division_Check
(N
)
1833 and then not Division_Checks_Suppressed
(Typ
)
1835 Apply_Division_Check
(N
, Rlo
, Rhi
, ROK
);
1838 -- Deal with overflow check
1840 if Do_Overflow_Check
(N
)
1841 and then not Overflow_Checks_Suppressed
(Etype
(N
))
1843 Set_Do_Overflow_Check
(N
, False);
1845 -- Test for extremely annoying case of xxx'First divided by -1
1846 -- for division of signed integer types (only overflow case).
1848 if Nkind
(N
) = N_Op_Divide
1849 and then Is_Signed_Integer_Type
(Typ
)
1851 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
1852 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1854 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1856 ((not LOK
) or else (Llo
= LLB
))
1859 Make_Raise_Constraint_Error
(Loc
,
1865 Duplicate_Subexpr_Move_Checks
(Left
),
1866 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1870 Left_Opnd
=> Duplicate_Subexpr
(Right
),
1871 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1))),
1873 Reason
=> CE_Overflow_Check_Failed
));
1878 end Apply_Divide_Checks
;
1880 --------------------------
1881 -- Apply_Division_Check --
1882 --------------------------
1884 procedure Apply_Division_Check
1890 pragma Assert
(Do_Division_Check
(N
));
1892 Loc
: constant Source_Ptr
:= Sloc
(N
);
1893 Right
: constant Node_Id
:= Right_Opnd
(N
);
1897 and then not Backend_Divide_Checks_On_Target
1898 and then Check_Needed
(Right
, Division_Check
)
1900 -- See if division by zero possible, and if so generate test. This
1901 -- part of the test is not controlled by the -gnato switch, since
1902 -- it is a Division_Check and not an Overflow_Check.
1904 if Do_Division_Check
(N
) then
1905 Set_Do_Division_Check
(N
, False);
1907 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1909 Make_Raise_Constraint_Error
(Loc
,
1912 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1913 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1914 Reason
=> CE_Divide_By_Zero
));
1918 end Apply_Division_Check
;
1920 ----------------------------------
1921 -- Apply_Float_Conversion_Check --
1922 ----------------------------------
1924 -- Let F and I be the source and target types of the conversion. The RM
1925 -- specifies that a floating-point value X is rounded to the nearest
1926 -- integer, with halfway cases being rounded away from zero. The rounded
1927 -- value of X is checked against I'Range.
1929 -- The catch in the above paragraph is that there is no good way to know
1930 -- whether the round-to-integer operation resulted in overflow. A remedy is
1931 -- to perform a range check in the floating-point domain instead, however:
1933 -- (1) The bounds may not be known at compile time
1934 -- (2) The check must take into account rounding or truncation.
1935 -- (3) The range of type I may not be exactly representable in F.
1936 -- (4) For the rounding case, The end-points I'First - 0.5 and
1937 -- I'Last + 0.5 may or may not be in range, depending on the
1938 -- sign of I'First and I'Last.
1939 -- (5) X may be a NaN, which will fail any comparison
1941 -- The following steps correctly convert X with rounding:
1943 -- (1) If either I'First or I'Last is not known at compile time, use
1944 -- I'Base instead of I in the next three steps and perform a
1945 -- regular range check against I'Range after conversion.
1946 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1947 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1948 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1949 -- In other words, take one of the closest floating-point numbers
1950 -- (which is an integer value) to I'First, and see if it is in
1952 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1953 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1954 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1955 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1956 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1958 -- For the truncating case, replace steps (2) and (3) as follows:
1959 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1960 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1962 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1963 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1966 procedure Apply_Float_Conversion_Check
1968 Target_Typ
: Entity_Id
)
1970 LB
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1971 HB
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1972 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1973 Expr_Type
: constant Entity_Id
:= Base_Type
(Etype
(Ck_Node
));
1974 Target_Base
: constant Entity_Id
:=
1975 Implementation_Base_Type
(Target_Typ
);
1977 Par
: constant Node_Id
:= Parent
(Ck_Node
);
1978 pragma Assert
(Nkind
(Par
) = N_Type_Conversion
);
1979 -- Parent of check node, must be a type conversion
1981 Truncate
: constant Boolean := Float_Truncate
(Par
);
1982 Max_Bound
: constant Uint
:=
1984 (Machine_Radix_Value
(Expr_Type
),
1985 Machine_Mantissa_Value
(Expr_Type
) - 1) - 1;
1987 -- Largest bound, so bound plus or minus half is a machine number of F
1989 Ifirst
, Ilast
: Uint
;
1990 -- Bounds of integer type
1993 -- Bounds to check in floating-point domain
1995 Lo_OK
, Hi_OK
: Boolean;
1996 -- True iff Lo resp. Hi belongs to I'Range
1998 Lo_Chk
, Hi_Chk
: Node_Id
;
1999 -- Expressions that are False iff check fails
2001 Reason
: RT_Exception_Code
;
2004 -- We do not need checks if we are not generating code (i.e. the full
2005 -- expander is not active). In SPARK mode, we specifically don't want
2006 -- the frontend to expand these checks, which are dealt with directly
2007 -- in the formal verification backend.
2009 if not Expander_Active
then
2013 if not Compile_Time_Known_Value
(LB
)
2014 or not Compile_Time_Known_Value
(HB
)
2017 -- First check that the value falls in the range of the base type,
2018 -- to prevent overflow during conversion and then perform a
2019 -- regular range check against the (dynamic) bounds.
2021 pragma Assert
(Target_Base
/= Target_Typ
);
2023 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Par
);
2026 Apply_Float_Conversion_Check
(Ck_Node
, Target_Base
);
2027 Set_Etype
(Temp
, Target_Base
);
2029 Insert_Action
(Parent
(Par
),
2030 Make_Object_Declaration
(Loc
,
2031 Defining_Identifier
=> Temp
,
2032 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
),
2033 Expression
=> New_Copy_Tree
(Par
)),
2034 Suppress
=> All_Checks
);
2037 Make_Raise_Constraint_Error
(Loc
,
2040 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
2041 Right_Opnd
=> New_Occurrence_Of
(Target_Typ
, Loc
)),
2042 Reason
=> CE_Range_Check_Failed
));
2043 Rewrite
(Par
, New_Occurrence_Of
(Temp
, Loc
));
2049 -- Get the (static) bounds of the target type
2051 Ifirst
:= Expr_Value
(LB
);
2052 Ilast
:= Expr_Value
(HB
);
2054 -- A simple optimization: if the expression is a universal literal,
2055 -- we can do the comparison with the bounds and the conversion to
2056 -- an integer type statically. The range checks are unchanged.
2058 if Nkind
(Ck_Node
) = N_Real_Literal
2059 and then Etype
(Ck_Node
) = Universal_Real
2060 and then Is_Integer_Type
(Target_Typ
)
2061 and then Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
2064 Int_Val
: constant Uint
:= UR_To_Uint
(Realval
(Ck_Node
));
2067 if Int_Val
<= Ilast
and then Int_Val
>= Ifirst
then
2069 -- Conversion is safe
2071 Rewrite
(Parent
(Ck_Node
),
2072 Make_Integer_Literal
(Loc
, UI_To_Int
(Int_Val
)));
2073 Analyze_And_Resolve
(Parent
(Ck_Node
), Target_Typ
);
2079 -- Check against lower bound
2081 if Truncate
and then Ifirst
> 0 then
2082 Lo
:= Pred
(Expr_Type
, UR_From_Uint
(Ifirst
));
2086 Lo
:= Succ
(Expr_Type
, UR_From_Uint
(Ifirst
- 1));
2089 elsif abs (Ifirst
) < Max_Bound
then
2090 Lo
:= UR_From_Uint
(Ifirst
) - Ureal_Half
;
2091 Lo_OK
:= (Ifirst
> 0);
2094 Lo
:= Machine
(Expr_Type
, UR_From_Uint
(Ifirst
), Round_Even
, Ck_Node
);
2095 Lo_OK
:= (Lo
>= UR_From_Uint
(Ifirst
));
2100 -- Lo_Chk := (X >= Lo)
2102 Lo_Chk
:= Make_Op_Ge
(Loc
,
2103 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2104 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2107 -- Lo_Chk := (X > Lo)
2109 Lo_Chk
:= Make_Op_Gt
(Loc
,
2110 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2111 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2114 -- Check against higher bound
2116 if Truncate
and then Ilast
< 0 then
2117 Hi
:= Succ
(Expr_Type
, UR_From_Uint
(Ilast
));
2121 Hi
:= Pred
(Expr_Type
, UR_From_Uint
(Ilast
+ 1));
2124 elsif abs (Ilast
) < Max_Bound
then
2125 Hi
:= UR_From_Uint
(Ilast
) + Ureal_Half
;
2126 Hi_OK
:= (Ilast
< 0);
2128 Hi
:= Machine
(Expr_Type
, UR_From_Uint
(Ilast
), Round_Even
, Ck_Node
);
2129 Hi_OK
:= (Hi
<= UR_From_Uint
(Ilast
));
2134 -- Hi_Chk := (X <= Hi)
2136 Hi_Chk
:= Make_Op_Le
(Loc
,
2137 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2138 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2141 -- Hi_Chk := (X < Hi)
2143 Hi_Chk
:= Make_Op_Lt
(Loc
,
2144 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2145 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2148 -- If the bounds of the target type are the same as those of the base
2149 -- type, the check is an overflow check as a range check is not
2150 -- performed in these cases.
2152 if Expr_Value
(Type_Low_Bound
(Target_Base
)) = Ifirst
2153 and then Expr_Value
(Type_High_Bound
(Target_Base
)) = Ilast
2155 Reason
:= CE_Overflow_Check_Failed
;
2157 Reason
:= CE_Range_Check_Failed
;
2160 -- Raise CE if either conditions does not hold
2162 Insert_Action
(Ck_Node
,
2163 Make_Raise_Constraint_Error
(Loc
,
2164 Condition
=> Make_Op_Not
(Loc
, Make_And_Then
(Loc
, Lo_Chk
, Hi_Chk
)),
2166 end Apply_Float_Conversion_Check
;
2168 ------------------------
2169 -- Apply_Length_Check --
2170 ------------------------
2172 procedure Apply_Length_Check
2174 Target_Typ
: Entity_Id
;
2175 Source_Typ
: Entity_Id
:= Empty
)
2178 Apply_Selected_Length_Checks
2179 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2180 end Apply_Length_Check
;
2182 -------------------------------------
2183 -- Apply_Parameter_Aliasing_Checks --
2184 -------------------------------------
2186 procedure Apply_Parameter_Aliasing_Checks
2190 Loc
: constant Source_Ptr
:= Sloc
(Call
);
2192 function May_Cause_Aliasing
2193 (Formal_1
: Entity_Id
;
2194 Formal_2
: Entity_Id
) return Boolean;
2195 -- Determine whether two formal parameters can alias each other
2196 -- depending on their modes.
2198 function Original_Actual
(N
: Node_Id
) return Node_Id
;
2199 -- The expander may replace an actual with a temporary for the sake of
2200 -- side effect removal. The temporary may hide a potential aliasing as
2201 -- it does not share the address of the actual. This routine attempts
2202 -- to retrieve the original actual.
2204 procedure Overlap_Check
2205 (Actual_1
: Node_Id
;
2207 Formal_1
: Entity_Id
;
2208 Formal_2
: Entity_Id
;
2209 Check
: in out Node_Id
);
2210 -- Create a check to determine whether Actual_1 overlaps with Actual_2.
2211 -- If detailed exception messages are enabled, the check is augmented to
2212 -- provide information about the names of the corresponding formals. See
2213 -- the body for details. Actual_1 and Actual_2 denote the two actuals to
2214 -- be tested. Formal_1 and Formal_2 denote the corresponding formals.
2215 -- Check contains all and-ed simple tests generated so far or remains
2216 -- unchanged in the case of detailed exception messaged.
2218 ------------------------
2219 -- May_Cause_Aliasing --
2220 ------------------------
2222 function May_Cause_Aliasing
2223 (Formal_1
: Entity_Id
;
2224 Formal_2
: Entity_Id
) return Boolean
2227 -- The following combination cannot lead to aliasing
2229 -- Formal 1 Formal 2
2232 if Ekind
(Formal_1
) = E_In_Parameter
2234 Ekind
(Formal_2
) = E_In_Parameter
2238 -- The following combinations may lead to aliasing
2240 -- Formal 1 Formal 2
2250 end May_Cause_Aliasing
;
2252 ---------------------
2253 -- Original_Actual --
2254 ---------------------
2256 function Original_Actual
(N
: Node_Id
) return Node_Id
is
2258 if Nkind
(N
) = N_Type_Conversion
then
2259 return Expression
(N
);
2261 -- The expander created a temporary to capture the result of a type
2262 -- conversion where the expression is the real actual.
2264 elsif Nkind
(N
) = N_Identifier
2265 and then Present
(Original_Node
(N
))
2266 and then Nkind
(Original_Node
(N
)) = N_Type_Conversion
2268 return Expression
(Original_Node
(N
));
2272 end Original_Actual
;
2278 procedure Overlap_Check
2279 (Actual_1
: Node_Id
;
2281 Formal_1
: Entity_Id
;
2282 Formal_2
: Entity_Id
;
2283 Check
: in out Node_Id
)
2286 ID_Casing
: constant Casing_Type
:=
2287 Identifier_Casing
(Source_Index
(Current_Sem_Unit
));
2291 -- Actual_1'Overlaps_Storage (Actual_2)
2294 Make_Attribute_Reference
(Loc
,
2295 Prefix
=> New_Copy_Tree
(Original_Actual
(Actual_1
)),
2296 Attribute_Name
=> Name_Overlaps_Storage
,
2298 New_List
(New_Copy_Tree
(Original_Actual
(Actual_2
))));
2300 -- Generate the following check when detailed exception messages are
2303 -- if Actual_1'Overlaps_Storage (Actual_2) then
2304 -- raise Program_Error with <detailed message>;
2307 if Exception_Extra_Info
then
2310 -- Do not generate location information for internal calls
2312 if Comes_From_Source
(Call
) then
2313 Store_String_Chars
(Build_Location_String
(Loc
));
2314 Store_String_Char
(' ');
2317 Store_String_Chars
("aliased parameters, actuals for """);
2319 Get_Name_String
(Chars
(Formal_1
));
2320 Set_Casing
(ID_Casing
);
2321 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2323 Store_String_Chars
(""" and """);
2325 Get_Name_String
(Chars
(Formal_2
));
2326 Set_Casing
(ID_Casing
);
2327 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2329 Store_String_Chars
(""" overlap");
2331 Insert_Action
(Call
,
2332 Make_If_Statement
(Loc
,
2334 Then_Statements
=> New_List
(
2335 Make_Raise_Statement
(Loc
,
2337 New_Occurrence_Of
(Standard_Program_Error
, Loc
),
2338 Expression
=> Make_String_Literal
(Loc
, End_String
)))));
2340 -- Create a sequence of overlapping checks by and-ing them all
2350 Right_Opnd
=> Cond
);
2360 Formal_1
: Entity_Id
;
2361 Formal_2
: Entity_Id
;
2362 Orig_Act_1
: Node_Id
;
2363 Orig_Act_2
: Node_Id
;
2365 -- Start of processing for Apply_Parameter_Aliasing_Checks
2370 Actual_1
:= First_Actual
(Call
);
2371 Formal_1
:= First_Formal
(Subp
);
2372 while Present
(Actual_1
) and then Present
(Formal_1
) loop
2373 Orig_Act_1
:= Original_Actual
(Actual_1
);
2375 -- Ensure that the actual is an object that is not passed by value.
2376 -- Elementary types are always passed by value, therefore actuals of
2377 -- such types cannot lead to aliasing. An aggregate is an object in
2378 -- Ada 2012, but an actual that is an aggregate cannot overlap with
2379 -- another actual. A type that is By_Reference (such as an array of
2380 -- controlled types) is not subject to the check because any update
2381 -- will be done in place and a subsequent read will always see the
2382 -- correct value, see RM 6.2 (12/3).
2384 if Nkind
(Orig_Act_1
) = N_Aggregate
2385 or else (Nkind
(Orig_Act_1
) = N_Qualified_Expression
2386 and then Nkind
(Expression
(Orig_Act_1
)) = N_Aggregate
)
2390 elsif Is_Object_Reference
(Orig_Act_1
)
2391 and then not Is_Elementary_Type
(Etype
(Orig_Act_1
))
2392 and then not Is_By_Reference_Type
(Etype
(Orig_Act_1
))
2394 Actual_2
:= Next_Actual
(Actual_1
);
2395 Formal_2
:= Next_Formal
(Formal_1
);
2396 while Present
(Actual_2
) and then Present
(Formal_2
) loop
2397 Orig_Act_2
:= Original_Actual
(Actual_2
);
2399 -- The other actual we are testing against must also denote
2400 -- a non pass-by-value object. Generate the check only when
2401 -- the mode of the two formals may lead to aliasing.
2403 if Is_Object_Reference
(Orig_Act_2
)
2404 and then not Is_Elementary_Type
(Etype
(Orig_Act_2
))
2405 and then May_Cause_Aliasing
(Formal_1
, Formal_2
)
2408 (Actual_1
=> Actual_1
,
2409 Actual_2
=> Actual_2
,
2410 Formal_1
=> Formal_1
,
2411 Formal_2
=> Formal_2
,
2415 Next_Actual
(Actual_2
);
2416 Next_Formal
(Formal_2
);
2420 Next_Actual
(Actual_1
);
2421 Next_Formal
(Formal_1
);
2424 -- Place a simple check right before the call
2426 if Present
(Check
) and then not Exception_Extra_Info
then
2427 Insert_Action
(Call
,
2428 Make_Raise_Program_Error
(Loc
,
2430 Reason
=> PE_Aliased_Parameters
));
2432 end Apply_Parameter_Aliasing_Checks
;
2434 -------------------------------------
2435 -- Apply_Parameter_Validity_Checks --
2436 -------------------------------------
2438 procedure Apply_Parameter_Validity_Checks
(Subp
: Entity_Id
) is
2439 Subp_Decl
: Node_Id
;
2441 procedure Add_Validity_Check
2442 (Formal
: Entity_Id
;
2444 For_Result
: Boolean := False);
2445 -- Add a single 'Valid[_Scalar] check which verifies the initialization
2446 -- of Formal. Prag_Nam denotes the pre or post condition pragma name.
2447 -- Set flag For_Result when to verify the result of a function.
2449 ------------------------
2450 -- Add_Validity_Check --
2451 ------------------------
2453 procedure Add_Validity_Check
2454 (Formal
: Entity_Id
;
2456 For_Result
: Boolean := False)
2458 procedure Build_Pre_Post_Condition
(Expr
: Node_Id
);
2459 -- Create a pre/postcondition pragma that tests expression Expr
2461 ------------------------------
2462 -- Build_Pre_Post_Condition --
2463 ------------------------------
2465 procedure Build_Pre_Post_Condition
(Expr
: Node_Id
) is
2466 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2473 Pragma_Identifier
=>
2474 Make_Identifier
(Loc
, Prag_Nam
),
2475 Pragma_Argument_Associations
=> New_List
(
2476 Make_Pragma_Argument_Association
(Loc
,
2477 Chars
=> Name_Check
,
2478 Expression
=> Expr
)));
2480 -- Add a message unless exception messages are suppressed
2482 if not Exception_Locations_Suppressed
then
2483 Append_To
(Pragma_Argument_Associations
(Prag
),
2484 Make_Pragma_Argument_Association
(Loc
,
2485 Chars
=> Name_Message
,
2487 Make_String_Literal
(Loc
,
2489 & Get_Name_String
(Prag_Nam
)
2491 & Build_Location_String
(Loc
))));
2494 -- Insert the pragma in the tree
2496 if Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
then
2497 Add_Global_Declaration
(Prag
);
2500 -- PPC pragmas associated with subprogram bodies must be inserted
2501 -- in the declarative part of the body.
2503 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
then
2504 Decls
:= Declarations
(Subp_Decl
);
2508 Set_Declarations
(Subp_Decl
, Decls
);
2511 Prepend_To
(Decls
, Prag
);
2514 -- For subprogram declarations insert the PPC pragma right after
2515 -- the declarative node.
2518 Insert_After_And_Analyze
(Subp_Decl
, Prag
);
2520 end Build_Pre_Post_Condition
;
2524 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2525 Typ
: constant Entity_Id
:= Etype
(Formal
);
2529 -- Start of processing for Add_Validity_Check
2532 -- For scalars, generate 'Valid test
2534 if Is_Scalar_Type
(Typ
) then
2537 -- For any non-scalar with scalar parts, generate 'Valid_Scalars test
2539 elsif Scalar_Part_Present
(Typ
) then
2540 Nam
:= Name_Valid_Scalars
;
2542 -- No test needed for other cases (no scalars to test)
2548 -- Step 1: Create the expression to verify the validity of the
2551 Check
:= New_Occurrence_Of
(Formal
, Loc
);
2553 -- When processing a function result, use 'Result. Generate
2558 Make_Attribute_Reference
(Loc
,
2560 Attribute_Name
=> Name_Result
);
2564 -- Context['Result]'Valid[_Scalars]
2567 Make_Attribute_Reference
(Loc
,
2569 Attribute_Name
=> Nam
);
2571 -- Step 2: Create a pre or post condition pragma
2573 Build_Pre_Post_Condition
(Check
);
2574 end Add_Validity_Check
;
2579 Subp_Spec
: Node_Id
;
2581 -- Start of processing for Apply_Parameter_Validity_Checks
2584 -- Extract the subprogram specification and declaration nodes
2586 Subp_Spec
:= Parent
(Subp
);
2588 if Nkind
(Subp_Spec
) = N_Defining_Program_Unit_Name
then
2589 Subp_Spec
:= Parent
(Subp_Spec
);
2592 Subp_Decl
:= Parent
(Subp_Spec
);
2594 if not Comes_From_Source
(Subp
)
2596 -- Do not process formal subprograms because the corresponding actual
2597 -- will receive the proper checks when the instance is analyzed.
2599 or else Is_Formal_Subprogram
(Subp
)
2601 -- Do not process imported subprograms since pre and postconditions
2602 -- are never verified on routines coming from a different language.
2604 or else Is_Imported
(Subp
)
2605 or else Is_Intrinsic_Subprogram
(Subp
)
2607 -- The PPC pragmas generated by this routine do not correspond to
2608 -- source aspects, therefore they cannot be applied to abstract
2611 or else Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
2613 -- Do not consider subprogram renaminds because the renamed entity
2614 -- already has the proper PPC pragmas.
2616 or else Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
2618 -- Do not process null procedures because there is no benefit of
2619 -- adding the checks to a no action routine.
2621 or else (Nkind
(Subp_Spec
) = N_Procedure_Specification
2622 and then Null_Present
(Subp_Spec
))
2627 -- Inspect all the formals applying aliasing and scalar initialization
2628 -- checks where applicable.
2630 Formal
:= First_Formal
(Subp
);
2631 while Present
(Formal
) loop
2633 -- Generate the following scalar initialization checks for each
2634 -- formal parameter:
2636 -- mode IN - Pre => Formal'Valid[_Scalars]
2637 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2638 -- mode OUT - Post => Formal'Valid[_Scalars]
2640 if Check_Validity_Of_Parameters
then
2641 if Ekind_In
(Formal
, E_In_Parameter
, E_In_Out_Parameter
) then
2642 Add_Validity_Check
(Formal
, Name_Precondition
, False);
2645 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
2646 Add_Validity_Check
(Formal
, Name_Postcondition
, False);
2650 Next_Formal
(Formal
);
2653 -- Generate following scalar initialization check for function result:
2655 -- Post => Subp'Result'Valid[_Scalars]
2657 if Check_Validity_Of_Parameters
and then Ekind
(Subp
) = E_Function
then
2658 Add_Validity_Check
(Subp
, Name_Postcondition
, True);
2660 end Apply_Parameter_Validity_Checks
;
2662 ---------------------------
2663 -- Apply_Predicate_Check --
2664 ---------------------------
2666 procedure Apply_Predicate_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
2670 if Predicate_Checks_Suppressed
(Empty
) then
2673 elsif Present
(Predicate_Function
(Typ
)) then
2675 while Present
(S
) and then not Is_Subprogram
(S
) loop
2679 -- A predicate check does not apply within internally generated
2680 -- subprograms, such as TSS functions.
2682 if Within_Internal_Subprogram
then
2685 -- If the check appears within the predicate function itself, it
2686 -- means that the user specified a check whose formal is the
2687 -- predicated subtype itself, rather than some covering type. This
2688 -- is likely to be a common error, and thus deserves a warning.
2690 elsif Present
(S
) and then S
= Predicate_Function
(Typ
) then
2692 ("predicate check includes a function call that "
2693 & "requires a predicate check??", Parent
(N
));
2695 ("\this will result in infinite recursion??", Parent
(N
));
2697 Make_Raise_Storage_Error
(Sloc
(N
),
2698 Reason
=> SE_Infinite_Recursion
));
2700 -- Here for normal case of predicate active
2703 -- If the type has a static predicate and the expression is known
2704 -- at compile time, see if the expression satisfies the predicate.
2706 Check_Expression_Against_Static_Predicate
(N
, Typ
);
2708 if Is_Entity_Name
(N
) then
2710 Make_Predicate_Check
2711 (Typ
, New_Occurrence_Of
(Entity
(N
), Sloc
(N
))));
2713 -- If the expression is not an entity it may have side-effects,
2714 -- and the following call will create an object declaration for
2715 -- it. We disable checks during its analysis, to prevent an
2716 -- infinite recursion.
2720 Make_Predicate_Check
2721 (Typ
, Duplicate_Subexpr
(N
)), Suppress
=> All_Checks
);
2725 end Apply_Predicate_Check
;
2727 -----------------------
2728 -- Apply_Range_Check --
2729 -----------------------
2731 procedure Apply_Range_Check
2733 Target_Typ
: Entity_Id
;
2734 Source_Typ
: Entity_Id
:= Empty
)
2737 Apply_Selected_Range_Checks
2738 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2739 end Apply_Range_Check
;
2741 ------------------------------
2742 -- Apply_Scalar_Range_Check --
2743 ------------------------------
2745 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
2746 -- off if it is already set on.
2748 procedure Apply_Scalar_Range_Check
2750 Target_Typ
: Entity_Id
;
2751 Source_Typ
: Entity_Id
:= Empty
;
2752 Fixed_Int
: Boolean := False)
2754 Parnt
: constant Node_Id
:= Parent
(Expr
);
2756 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
2757 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
2760 Is_Subscr_Ref
: Boolean;
2761 -- Set true if Expr is a subscript
2763 Is_Unconstrained_Subscr_Ref
: Boolean;
2764 -- Set true if Expr is a subscript of an unconstrained array. In this
2765 -- case we do not attempt to do an analysis of the value against the
2766 -- range of the subscript, since we don't know the actual subtype.
2769 -- Set to True if Expr should be regarded as a real value even though
2770 -- the type of Expr might be discrete.
2772 procedure Bad_Value
(Warn
: Boolean := False);
2773 -- Procedure called if value is determined to be out of range. Warn is
2774 -- True to force a warning instead of an error, even when SPARK_Mode is
2781 procedure Bad_Value
(Warn
: Boolean := False) is
2783 Apply_Compile_Time_Constraint_Error
2784 (Expr
, "value not in range of}??", CE_Range_Check_Failed
,
2790 -- Start of processing for Apply_Scalar_Range_Check
2793 -- Return if check obviously not needed
2796 -- Not needed inside generic
2800 -- Not needed if previous error
2802 or else Target_Typ
= Any_Type
2803 or else Nkind
(Expr
) = N_Error
2805 -- Not needed for non-scalar type
2807 or else not Is_Scalar_Type
(Target_Typ
)
2809 -- Not needed if we know node raises CE already
2811 or else Raises_Constraint_Error
(Expr
)
2816 -- Now, see if checks are suppressed
2819 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
2821 if Is_Subscr_Ref
then
2822 Arr
:= Prefix
(Parnt
);
2823 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
2825 if Is_Access_Type
(Arr_Typ
) then
2826 Arr_Typ
:= Designated_Type
(Arr_Typ
);
2830 if not Do_Range_Check
(Expr
) then
2832 -- Subscript reference. Check for Index_Checks suppressed
2834 if Is_Subscr_Ref
then
2836 -- Check array type and its base type
2838 if Index_Checks_Suppressed
(Arr_Typ
)
2839 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
2843 -- Check array itself if it is an entity name
2845 elsif Is_Entity_Name
(Arr
)
2846 and then Index_Checks_Suppressed
(Entity
(Arr
))
2850 -- Check expression itself if it is an entity name
2852 elsif Is_Entity_Name
(Expr
)
2853 and then Index_Checks_Suppressed
(Entity
(Expr
))
2858 -- All other cases, check for Range_Checks suppressed
2861 -- Check target type and its base type
2863 if Range_Checks_Suppressed
(Target_Typ
)
2864 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
2868 -- Check expression itself if it is an entity name
2870 elsif Is_Entity_Name
(Expr
)
2871 and then Range_Checks_Suppressed
(Entity
(Expr
))
2875 -- If Expr is part of an assignment statement, then check left
2876 -- side of assignment if it is an entity name.
2878 elsif Nkind
(Parnt
) = N_Assignment_Statement
2879 and then Is_Entity_Name
(Name
(Parnt
))
2880 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
2887 -- Do not set range checks if they are killed
2889 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
2890 and then Kill_Range_Check
(Expr
)
2895 -- Do not set range checks for any values from System.Scalar_Values
2896 -- since the whole idea of such values is to avoid checking them.
2898 if Is_Entity_Name
(Expr
)
2899 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
2904 -- Now see if we need a check
2906 if No
(Source_Typ
) then
2907 S_Typ
:= Etype
(Expr
);
2909 S_Typ
:= Source_Typ
;
2912 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
2916 Is_Unconstrained_Subscr_Ref
:=
2917 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
2919 -- Special checks for floating-point type
2921 if Is_Floating_Point_Type
(S_Typ
) then
2923 -- Always do a range check if the source type includes infinities and
2924 -- the target type does not include infinities. We do not do this if
2925 -- range checks are killed.
2926 -- If the expression is a literal and the bounds of the type are
2927 -- static constants it may be possible to optimize the check.
2929 if Has_Infinities
(S_Typ
)
2930 and then not Has_Infinities
(Target_Typ
)
2932 -- If the expression is a literal and the bounds of the type are
2933 -- static constants it may be possible to optimize the check.
2935 if Nkind
(Expr
) = N_Real_Literal
then
2937 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
2938 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
2941 if Compile_Time_Known_Value
(Tlo
)
2942 and then Compile_Time_Known_Value
(Thi
)
2943 and then Expr_Value_R
(Expr
) >= Expr_Value_R
(Tlo
)
2944 and then Expr_Value_R
(Expr
) <= Expr_Value_R
(Thi
)
2948 Enable_Range_Check
(Expr
);
2953 Enable_Range_Check
(Expr
);
2958 -- Return if we know expression is definitely in the range of the target
2959 -- type as determined by Determine_Range. Right now we only do this for
2960 -- discrete types, and not fixed-point or floating-point types.
2962 -- The additional less-precise tests below catch these cases
2964 -- Note: skip this if we are given a source_typ, since the point of
2965 -- supplying a Source_Typ is to stop us looking at the expression.
2966 -- We could sharpen this test to be out parameters only ???
2968 if Is_Discrete_Type
(Target_Typ
)
2969 and then Is_Discrete_Type
(Etype
(Expr
))
2970 and then not Is_Unconstrained_Subscr_Ref
2971 and then No
(Source_Typ
)
2974 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
2975 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
2980 if Compile_Time_Known_Value
(Tlo
)
2981 and then Compile_Time_Known_Value
(Thi
)
2984 Lov
: constant Uint
:= Expr_Value
(Tlo
);
2985 Hiv
: constant Uint
:= Expr_Value
(Thi
);
2988 -- If range is null, we for sure have a constraint error
2989 -- (we don't even need to look at the value involved,
2990 -- since all possible values will raise CE).
2994 -- When SPARK_Mode is On, force a warning instead of
2995 -- an error in that case, as this likely corresponds
2996 -- to deactivated code.
2998 Bad_Value
(Warn
=> SPARK_Mode
= On
);
3000 -- In GNATprove mode, we enable the range check so that
3001 -- GNATprove will issue a message if it cannot be proved.
3003 if GNATprove_Mode
then
3004 Enable_Range_Check
(Expr
);
3010 -- Otherwise determine range of value
3012 Determine_Range
(Expr
, OK
, Lo
, Hi
, Assume_Valid
=> True);
3016 -- If definitely in range, all OK
3018 if Lo
>= Lov
and then Hi
<= Hiv
then
3021 -- If definitely not in range, warn
3023 elsif Lov
> Hi
or else Hiv
< Lo
then
3027 -- Otherwise we don't know
3039 Is_Floating_Point_Type
(S_Typ
)
3040 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
3042 -- Check if we can determine at compile time whether Expr is in the
3043 -- range of the target type. Note that if S_Typ is within the bounds
3044 -- of Target_Typ then this must be the case. This check is meaningful
3045 -- only if this is not a conversion between integer and real types.
3047 if not Is_Unconstrained_Subscr_Ref
3048 and then Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
3050 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
3052 -- Also check if the expression itself is in the range of the
3053 -- target type if it is a known at compile time value. We skip
3054 -- this test if S_Typ is set since for OUT and IN OUT parameters
3055 -- the Expr itself is not relevant to the checking.
3059 and then Is_In_Range
(Expr
, Target_Typ
,
3060 Assume_Valid
=> True,
3061 Fixed_Int
=> Fixed_Int
,
3062 Int_Real
=> Int_Real
)))
3066 elsif Is_Out_Of_Range
(Expr
, Target_Typ
,
3067 Assume_Valid
=> True,
3068 Fixed_Int
=> Fixed_Int
,
3069 Int_Real
=> Int_Real
)
3074 -- Floating-point case
3075 -- In the floating-point case, we only do range checks if the type is
3076 -- constrained. We definitely do NOT want range checks for unconstrained
3077 -- types, since we want to have infinities
3079 elsif Is_Floating_Point_Type
(S_Typ
) then
3081 -- Normally, we only do range checks if the type is constrained. We do
3082 -- NOT want range checks for unconstrained types, since we want to have
3085 if Is_Constrained
(S_Typ
) then
3086 Enable_Range_Check
(Expr
);
3089 -- For all other cases we enable a range check unconditionally
3092 Enable_Range_Check
(Expr
);
3095 end Apply_Scalar_Range_Check
;
3097 ----------------------------------
3098 -- Apply_Selected_Length_Checks --
3099 ----------------------------------
3101 procedure Apply_Selected_Length_Checks
3103 Target_Typ
: Entity_Id
;
3104 Source_Typ
: Entity_Id
;
3105 Do_Static
: Boolean)
3108 R_Result
: Check_Result
;
3111 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
3112 Checks_On
: constant Boolean :=
3113 (not Index_Checks_Suppressed
(Target_Typ
))
3114 or else (not Length_Checks_Suppressed
(Target_Typ
));
3117 -- Note: this means that we lose some useful warnings if the expander
3118 -- is not active, and we also lose these warnings in SPARK mode ???
3120 if not Expander_Active
then
3125 Selected_Length_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
3127 for J
in 1 .. 2 loop
3128 R_Cno
:= R_Result
(J
);
3129 exit when No
(R_Cno
);
3131 -- A length check may mention an Itype which is attached to a
3132 -- subsequent node. At the top level in a package this can cause
3133 -- an order-of-elaboration problem, so we make sure that the itype
3134 -- is referenced now.
3136 if Ekind
(Current_Scope
) = E_Package
3137 and then Is_Compilation_Unit
(Current_Scope
)
3139 Ensure_Defined
(Target_Typ
, Ck_Node
);
3141 if Present
(Source_Typ
) then
3142 Ensure_Defined
(Source_Typ
, Ck_Node
);
3144 elsif Is_Itype
(Etype
(Ck_Node
)) then
3145 Ensure_Defined
(Etype
(Ck_Node
), Ck_Node
);
3149 -- If the item is a conditional raise of constraint error, then have
3150 -- a look at what check is being performed and ???
3152 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
3153 and then Present
(Condition
(R_Cno
))
3155 Cond
:= Condition
(R_Cno
);
3157 -- Case where node does not now have a dynamic check
3159 if not Has_Dynamic_Length_Check
(Ck_Node
) then
3161 -- If checks are on, just insert the check
3164 Insert_Action
(Ck_Node
, R_Cno
);
3166 if not Do_Static
then
3167 Set_Has_Dynamic_Length_Check
(Ck_Node
);
3170 -- If checks are off, then analyze the length check after
3171 -- temporarily attaching it to the tree in case the relevant
3172 -- condition can be evaluated at compile time. We still want a
3173 -- compile time warning in this case.
3176 Set_Parent
(R_Cno
, Ck_Node
);
3181 -- Output a warning if the condition is known to be True
3183 if Is_Entity_Name
(Cond
)
3184 and then Entity
(Cond
) = Standard_True
3186 Apply_Compile_Time_Constraint_Error
3187 (Ck_Node
, "wrong length for array of}??",
3188 CE_Length_Check_Failed
,
3192 -- If we were only doing a static check, or if checks are not
3193 -- on, then we want to delete the check, since it is not needed.
3194 -- We do this by replacing the if statement by a null statement
3196 elsif Do_Static
or else not Checks_On
then
3197 Remove_Warning_Messages
(R_Cno
);
3198 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3202 Install_Static_Check
(R_Cno
, Loc
);
3205 end Apply_Selected_Length_Checks
;
3207 ---------------------------------
3208 -- Apply_Selected_Range_Checks --
3209 ---------------------------------
3211 procedure Apply_Selected_Range_Checks
3213 Target_Typ
: Entity_Id
;
3214 Source_Typ
: Entity_Id
;
3215 Do_Static
: Boolean)
3217 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
3218 Checks_On
: constant Boolean :=
3219 not Index_Checks_Suppressed
(Target_Typ
)
3221 not Range_Checks_Suppressed
(Target_Typ
);
3225 R_Result
: Check_Result
;
3228 if not Expander_Active
or not Checks_On
then
3233 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
3235 for J
in 1 .. 2 loop
3236 R_Cno
:= R_Result
(J
);
3237 exit when No
(R_Cno
);
3239 -- The range check requires runtime evaluation. Depending on what its
3240 -- triggering condition is, the check may be converted into a compile
3241 -- time constraint check.
3243 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
3244 and then Present
(Condition
(R_Cno
))
3246 Cond
:= Condition
(R_Cno
);
3248 -- Insert the range check before the related context. Note that
3249 -- this action analyses the triggering condition.
3251 Insert_Action
(Ck_Node
, R_Cno
);
3253 -- This old code doesn't make sense, why is the context flagged as
3254 -- requiring dynamic range checks now in the middle of generating
3257 if not Do_Static
then
3258 Set_Has_Dynamic_Range_Check
(Ck_Node
);
3261 -- The triggering condition evaluates to True, the range check
3262 -- can be converted into a compile time constraint check.
3264 if Is_Entity_Name
(Cond
)
3265 and then Entity
(Cond
) = Standard_True
3267 -- Since an N_Range is technically not an expression, we have
3268 -- to set one of the bounds to C_E and then just flag the
3269 -- N_Range. The warning message will point to the lower bound
3270 -- and complain about a range, which seems OK.
3272 if Nkind
(Ck_Node
) = N_Range
then
3273 Apply_Compile_Time_Constraint_Error
3274 (Low_Bound
(Ck_Node
),
3275 "static range out of bounds of}??",
3276 CE_Range_Check_Failed
,
3280 Set_Raises_Constraint_Error
(Ck_Node
);
3283 Apply_Compile_Time_Constraint_Error
3285 "static value out of range of}??",
3286 CE_Range_Check_Failed
,
3291 -- If we were only doing a static check, or if checks are not
3292 -- on, then we want to delete the check, since it is not needed.
3293 -- We do this by replacing the if statement by a null statement
3295 -- Why are we even generating checks if checks are turned off ???
3297 elsif Do_Static
or else not Checks_On
then
3298 Remove_Warning_Messages
(R_Cno
);
3299 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3302 -- The range check raises Constraint_Error explicitly
3305 Install_Static_Check
(R_Cno
, Loc
);
3308 end Apply_Selected_Range_Checks
;
3310 -------------------------------
3311 -- Apply_Static_Length_Check --
3312 -------------------------------
3314 procedure Apply_Static_Length_Check
3316 Target_Typ
: Entity_Id
;
3317 Source_Typ
: Entity_Id
:= Empty
)
3320 Apply_Selected_Length_Checks
3321 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
3322 end Apply_Static_Length_Check
;
3324 -------------------------------------
3325 -- Apply_Subscript_Validity_Checks --
3326 -------------------------------------
3328 procedure Apply_Subscript_Validity_Checks
(Expr
: Node_Id
) is
3332 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
3334 -- Loop through subscripts
3336 Sub
:= First
(Expressions
(Expr
));
3337 while Present
(Sub
) loop
3339 -- Check one subscript. Note that we do not worry about enumeration
3340 -- type with holes, since we will convert the value to a Pos value
3341 -- for the subscript, and that convert will do the necessary validity
3344 Ensure_Valid
(Sub
, Holes_OK
=> True);
3346 -- Move to next subscript
3350 end Apply_Subscript_Validity_Checks
;
3352 ----------------------------------
3353 -- Apply_Type_Conversion_Checks --
3354 ----------------------------------
3356 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
3357 Target_Type
: constant Entity_Id
:= Etype
(N
);
3358 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
3359 Expr
: constant Node_Id
:= Expression
(N
);
3361 Expr_Type
: constant Entity_Id
:= Underlying_Type
(Etype
(Expr
));
3362 -- Note: if Etype (Expr) is a private type without discriminants, its
3363 -- full view might have discriminants with defaults, so we need the
3364 -- full view here to retrieve the constraints.
3367 if Inside_A_Generic
then
3370 -- Skip these checks if serious errors detected, there are some nasty
3371 -- situations of incomplete trees that blow things up.
3373 elsif Serious_Errors_Detected
> 0 then
3376 -- Never generate discriminant checks for Unchecked_Union types
3378 elsif Present
(Expr_Type
)
3379 and then Is_Unchecked_Union
(Expr_Type
)
3383 -- Scalar type conversions of the form Target_Type (Expr) require a
3384 -- range check if we cannot be sure that Expr is in the base type of
3385 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3386 -- are not quite the same condition from an implementation point of
3387 -- view, but clearly the second includes the first.
3389 elsif Is_Scalar_Type
(Target_Type
) then
3391 Conv_OK
: constant Boolean := Conversion_OK
(N
);
3392 -- If the Conversion_OK flag on the type conversion is set and no
3393 -- floating-point type is involved in the type conversion then
3394 -- fixed-point values must be read as integral values.
3396 Float_To_Int
: constant Boolean :=
3397 Is_Floating_Point_Type
(Expr_Type
)
3398 and then Is_Integer_Type
(Target_Type
);
3401 if not Overflow_Checks_Suppressed
(Target_Base
)
3402 and then not Overflow_Checks_Suppressed
(Target_Type
)
3404 In_Subrange_Of
(Expr_Type
, Target_Base
, Fixed_Int
=> Conv_OK
)
3405 and then not Float_To_Int
3407 Activate_Overflow_Check
(N
);
3410 if not Range_Checks_Suppressed
(Target_Type
)
3411 and then not Range_Checks_Suppressed
(Expr_Type
)
3413 if Float_To_Int
then
3414 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
3416 Apply_Scalar_Range_Check
3417 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
3419 -- If the target type has predicates, we need to indicate
3420 -- the need for a check, even if Determine_Range finds that
3421 -- the value is within bounds. This may be the case e.g for
3422 -- a division with a constant denominator.
3424 if Has_Predicates
(Target_Type
) then
3425 Enable_Range_Check
(Expr
);
3431 elsif Comes_From_Source
(N
)
3432 and then not Discriminant_Checks_Suppressed
(Target_Type
)
3433 and then Is_Record_Type
(Target_Type
)
3434 and then Is_Derived_Type
(Target_Type
)
3435 and then not Is_Tagged_Type
(Target_Type
)
3436 and then not Is_Constrained
(Target_Type
)
3437 and then Present
(Stored_Constraint
(Target_Type
))
3439 -- An unconstrained derived type may have inherited discriminant.
3440 -- Build an actual discriminant constraint list using the stored
3441 -- constraint, to verify that the expression of the parent type
3442 -- satisfies the constraints imposed by the (unconstrained) derived
3443 -- type. This applies to value conversions, not to view conversions
3447 Loc
: constant Source_Ptr
:= Sloc
(N
);
3449 Constraint
: Elmt_Id
;
3450 Discr_Value
: Node_Id
;
3453 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
3454 Old_Constraints
: constant Elist_Id
:=
3455 Discriminant_Constraint
(Expr_Type
);
3458 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
3459 while Present
(Constraint
) loop
3460 Discr_Value
:= Node
(Constraint
);
3462 if Is_Entity_Name
(Discr_Value
)
3463 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
3465 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
3468 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
3470 -- Parent is constrained by new discriminant. Obtain
3471 -- Value of original discriminant in expression. If the
3472 -- new discriminant has been used to constrain more than
3473 -- one of the stored discriminants, this will provide the
3474 -- required consistency check.
3477 (Make_Selected_Component
(Loc
,
3479 Duplicate_Subexpr_No_Checks
3480 (Expr
, Name_Req
=> True),
3482 Make_Identifier
(Loc
, Chars
(Discr
))),
3486 -- Discriminant of more remote ancestor ???
3491 -- Derived type definition has an explicit value for this
3492 -- stored discriminant.
3496 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
3500 Next_Elmt
(Constraint
);
3503 -- Use the unconstrained expression type to retrieve the
3504 -- discriminants of the parent, and apply momentarily the
3505 -- discriminant constraint synthesized above.
3507 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
3508 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
3509 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
3512 Make_Raise_Constraint_Error
(Loc
,
3514 Reason
=> CE_Discriminant_Check_Failed
));
3517 -- For arrays, checks are set now, but conversions are applied during
3518 -- expansion, to take into accounts changes of representation. The
3519 -- checks become range checks on the base type or length checks on the
3520 -- subtype, depending on whether the target type is unconstrained or
3521 -- constrained. Note that the range check is put on the expression of a
3522 -- type conversion, while the length check is put on the type conversion
3525 elsif Is_Array_Type
(Target_Type
) then
3526 if Is_Constrained
(Target_Type
) then
3527 Set_Do_Length_Check
(N
);
3529 Set_Do_Range_Check
(Expr
);
3532 end Apply_Type_Conversion_Checks
;
3534 ----------------------------------------------
3535 -- Apply_Universal_Integer_Attribute_Checks --
3536 ----------------------------------------------
3538 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
3539 Loc
: constant Source_Ptr
:= Sloc
(N
);
3540 Typ
: constant Entity_Id
:= Etype
(N
);
3543 if Inside_A_Generic
then
3546 -- Nothing to do if checks are suppressed
3548 elsif Range_Checks_Suppressed
(Typ
)
3549 and then Overflow_Checks_Suppressed
(Typ
)
3553 -- Nothing to do if the attribute does not come from source. The
3554 -- internal attributes we generate of this type do not need checks,
3555 -- and furthermore the attempt to check them causes some circular
3556 -- elaboration orders when dealing with packed types.
3558 elsif not Comes_From_Source
(N
) then
3561 -- If the prefix is a selected component that depends on a discriminant
3562 -- the check may improperly expose a discriminant instead of using
3563 -- the bounds of the object itself. Set the type of the attribute to
3564 -- the base type of the context, so that a check will be imposed when
3565 -- needed (e.g. if the node appears as an index).
3567 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
3568 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
3569 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
3571 Set_Etype
(N
, Base_Type
(Typ
));
3573 -- Otherwise, replace the attribute node with a type conversion node
3574 -- whose expression is the attribute, retyped to universal integer, and
3575 -- whose subtype mark is the target type. The call to analyze this
3576 -- conversion will set range and overflow checks as required for proper
3577 -- detection of an out of range value.
3580 Set_Etype
(N
, Universal_Integer
);
3581 Set_Analyzed
(N
, True);
3584 Make_Type_Conversion
(Loc
,
3585 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
3586 Expression
=> Relocate_Node
(N
)));
3588 Analyze_And_Resolve
(N
, Typ
);
3591 end Apply_Universal_Integer_Attribute_Checks
;
3593 -------------------------------------
3594 -- Atomic_Synchronization_Disabled --
3595 -------------------------------------
3597 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3598 -- using a bogus check called Atomic_Synchronization. This is to make it
3599 -- more convenient to get exactly the same semantics as [Un]Suppress.
3601 function Atomic_Synchronization_Disabled
(E
: Entity_Id
) return Boolean is
3603 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3604 -- looks enabled, since it is never disabled.
3606 if Debug_Flag_Dot_E
then
3609 -- If debug flag d.d is set then always return True, i.e. all atomic
3610 -- sync looks disabled, since it always tests True.
3612 elsif Debug_Flag_Dot_D
then
3615 -- If entity present, then check result for that entity
3617 elsif Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3618 return Is_Check_Suppressed
(E
, Atomic_Synchronization
);
3620 -- Otherwise result depends on current scope setting
3623 return Scope_Suppress
.Suppress
(Atomic_Synchronization
);
3625 end Atomic_Synchronization_Disabled
;
3627 -------------------------------
3628 -- Build_Discriminant_Checks --
3629 -------------------------------
3631 function Build_Discriminant_Checks
3633 T_Typ
: Entity_Id
) return Node_Id
3635 Loc
: constant Source_Ptr
:= Sloc
(N
);
3638 Disc_Ent
: Entity_Id
;
3642 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
;
3644 ----------------------------------
3645 -- Aggregate_Discriminant_Value --
3646 ----------------------------------
3648 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
is
3652 -- The aggregate has been normalized with named associations. We use
3653 -- the Chars field to locate the discriminant to take into account
3654 -- discriminants in derived types, which carry the same name as those
3657 Assoc
:= First
(Component_Associations
(N
));
3658 while Present
(Assoc
) loop
3659 if Chars
(First
(Choices
(Assoc
))) = Chars
(Disc
) then
3660 return Expression
(Assoc
);
3666 -- Discriminant must have been found in the loop above
3668 raise Program_Error
;
3669 end Aggregate_Discriminant_Val
;
3671 -- Start of processing for Build_Discriminant_Checks
3674 -- Loop through discriminants evolving the condition
3677 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
3679 -- For a fully private type, use the discriminants of the parent type
3681 if Is_Private_Type
(T_Typ
)
3682 and then No
(Full_View
(T_Typ
))
3684 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
3686 Disc_Ent
:= First_Discriminant
(T_Typ
);
3689 while Present
(Disc
) loop
3690 Dval
:= Node
(Disc
);
3692 if Nkind
(Dval
) = N_Identifier
3693 and then Ekind
(Entity
(Dval
)) = E_Discriminant
3695 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
3697 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
3700 -- If we have an Unchecked_Union node, we can infer the discriminants
3703 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
3705 Get_Discriminant_Value
(
3706 First_Discriminant
(T_Typ
),
3708 Stored_Constraint
(T_Typ
)));
3710 elsif Nkind
(N
) = N_Aggregate
then
3712 Duplicate_Subexpr_No_Checks
3713 (Aggregate_Discriminant_Val
(Disc_Ent
));
3717 Make_Selected_Component
(Loc
,
3719 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
3720 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
3722 Set_Is_In_Discriminant_Check
(Dref
);
3725 Evolve_Or_Else
(Cond
,
3728 Right_Opnd
=> Dval
));
3731 Next_Discriminant
(Disc_Ent
);
3735 end Build_Discriminant_Checks
;
3741 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
3748 function Left_Expression
(Op
: Node_Id
) return Node_Id
;
3749 -- Return the relevant expression from the left operand of the given
3750 -- short circuit form: this is LO itself, except if LO is a qualified
3751 -- expression, a type conversion, or an expression with actions, in
3752 -- which case this is Left_Expression (Expression (LO)).
3754 ---------------------
3755 -- Left_Expression --
3756 ---------------------
3758 function Left_Expression
(Op
: Node_Id
) return Node_Id
is
3759 LE
: Node_Id
:= Left_Opnd
(Op
);
3761 while Nkind_In
(LE
, N_Qualified_Expression
,
3763 N_Expression_With_Actions
)
3765 LE
:= Expression
(LE
);
3769 end Left_Expression
;
3771 -- Start of processing for Check_Needed
3774 -- Always check if not simple entity
3776 if Nkind
(Nod
) not in N_Has_Entity
3777 or else not Comes_From_Source
(Nod
)
3782 -- Look up tree for short circuit
3789 -- Done if out of subexpression (note that we allow generated stuff
3790 -- such as itype declarations in this context, to keep the loop going
3791 -- since we may well have generated such stuff in complex situations.
3792 -- Also done if no parent (probably an error condition, but no point
3793 -- in behaving nasty if we find it).
3796 or else (K
not in N_Subexpr
and then Comes_From_Source
(P
))
3800 -- Or/Or Else case, where test is part of the right operand, or is
3801 -- part of one of the actions associated with the right operand, and
3802 -- the left operand is an equality test.
3804 elsif K
= N_Op_Or
then
3805 exit when N
= Right_Opnd
(P
)
3806 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
3808 elsif K
= N_Or_Else
then
3809 exit when (N
= Right_Opnd
(P
)
3812 and then List_Containing
(N
) = Actions
(P
)))
3813 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
3815 -- Similar test for the And/And then case, where the left operand
3816 -- is an inequality test.
3818 elsif K
= N_Op_And
then
3819 exit when N
= Right_Opnd
(P
)
3820 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
3822 elsif K
= N_And_Then
then
3823 exit when (N
= Right_Opnd
(P
)
3826 and then List_Containing
(N
) = Actions
(P
)))
3827 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
3833 -- If we fall through the loop, then we have a conditional with an
3834 -- appropriate test as its left operand, so look further.
3836 L
:= Left_Expression
(P
);
3838 -- L is an "=" or "/=" operator: extract its operands
3840 R
:= Right_Opnd
(L
);
3843 -- Left operand of test must match original variable
3845 if Nkind
(L
) not in N_Has_Entity
or else Entity
(L
) /= Entity
(Nod
) then
3849 -- Right operand of test must be key value (zero or null)
3852 when Access_Check
=>
3853 if not Known_Null
(R
) then
3857 when Division_Check
=>
3858 if not Compile_Time_Known_Value
(R
)
3859 or else Expr_Value
(R
) /= Uint_0
3865 raise Program_Error
;
3868 -- Here we have the optimizable case, warn if not short-circuited
3870 if K
= N_Op_And
or else K
= N_Op_Or
then
3871 Error_Msg_Warn
:= SPARK_Mode
/= On
;
3874 when Access_Check
=>
3875 if GNATprove_Mode
then
3877 ("Constraint_Error might have been raised (access check)",
3881 ("Constraint_Error may be raised (access check)??",
3885 when Division_Check
=>
3886 if GNATprove_Mode
then
3888 ("Constraint_Error might have been raised (zero divide)",
3892 ("Constraint_Error may be raised (zero divide)??",
3897 raise Program_Error
;
3900 if K
= N_Op_And
then
3901 Error_Msg_N
-- CODEFIX
3902 ("use `AND THEN` instead of AND??", P
);
3904 Error_Msg_N
-- CODEFIX
3905 ("use `OR ELSE` instead of OR??", P
);
3908 -- If not short-circuited, we need the check
3912 -- If short-circuited, we can omit the check
3919 -----------------------------------
3920 -- Check_Valid_Lvalue_Subscripts --
3921 -----------------------------------
3923 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
3925 -- Skip this if range checks are suppressed
3927 if Range_Checks_Suppressed
(Etype
(Expr
)) then
3930 -- Only do this check for expressions that come from source. We assume
3931 -- that expander generated assignments explicitly include any necessary
3932 -- checks. Note that this is not just an optimization, it avoids
3933 -- infinite recursions.
3935 elsif not Comes_From_Source
(Expr
) then
3938 -- For a selected component, check the prefix
3940 elsif Nkind
(Expr
) = N_Selected_Component
then
3941 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3944 -- Case of indexed component
3946 elsif Nkind
(Expr
) = N_Indexed_Component
then
3947 Apply_Subscript_Validity_Checks
(Expr
);
3949 -- Prefix may itself be or contain an indexed component, and these
3950 -- subscripts need checking as well.
3952 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3954 end Check_Valid_Lvalue_Subscripts
;
3956 ----------------------------------
3957 -- Null_Exclusion_Static_Checks --
3958 ----------------------------------
3960 procedure Null_Exclusion_Static_Checks
(N
: Node_Id
) is
3961 Error_Node
: Node_Id
;
3963 Has_Null
: constant Boolean := Has_Null_Exclusion
(N
);
3964 K
: constant Node_Kind
:= Nkind
(N
);
3969 (Nkind_In
(K
, N_Component_Declaration
,
3970 N_Discriminant_Specification
,
3971 N_Function_Specification
,
3972 N_Object_Declaration
,
3973 N_Parameter_Specification
));
3975 if K
= N_Function_Specification
then
3976 Typ
:= Etype
(Defining_Entity
(N
));
3978 Typ
:= Etype
(Defining_Identifier
(N
));
3982 when N_Component_Declaration
=>
3983 if Present
(Access_Definition
(Component_Definition
(N
))) then
3984 Error_Node
:= Component_Definition
(N
);
3986 Error_Node
:= Subtype_Indication
(Component_Definition
(N
));
3989 when N_Discriminant_Specification
=>
3990 Error_Node
:= Discriminant_Type
(N
);
3992 when N_Function_Specification
=>
3993 Error_Node
:= Result_Definition
(N
);
3995 when N_Object_Declaration
=>
3996 Error_Node
:= Object_Definition
(N
);
3998 when N_Parameter_Specification
=>
3999 Error_Node
:= Parameter_Type
(N
);
4002 raise Program_Error
;
4007 -- Enforce legality rule 3.10 (13): A null exclusion can only be
4008 -- applied to an access [sub]type.
4010 if not Is_Access_Type
(Typ
) then
4012 ("`NOT NULL` allowed only for an access type", Error_Node
);
4014 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
4015 -- be applied to a [sub]type that does not exclude null already.
4017 elsif Can_Never_Be_Null
(Typ
)
4018 and then Comes_From_Source
(Typ
)
4021 ("`NOT NULL` not allowed (& already excludes null)",
4026 -- Check that null-excluding objects are always initialized, except for
4027 -- deferred constants, for which the expression will appear in the full
4030 if K
= N_Object_Declaration
4031 and then No
(Expression
(N
))
4032 and then not Constant_Present
(N
)
4033 and then not No_Initialization
(N
)
4035 -- Add an expression that assigns null. This node is needed by
4036 -- Apply_Compile_Time_Constraint_Error, which will replace this with
4037 -- a Constraint_Error node.
4039 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
4040 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
4042 Apply_Compile_Time_Constraint_Error
4043 (N
=> Expression
(N
),
4045 "(Ada 2005) null-excluding objects must be initialized??",
4046 Reason
=> CE_Null_Not_Allowed
);
4049 -- Check that a null-excluding component, formal or object is not being
4050 -- assigned a null value. Otherwise generate a warning message and
4051 -- replace Expression (N) by an N_Constraint_Error node.
4053 if K
/= N_Function_Specification
then
4054 Expr
:= Expression
(N
);
4056 if Present
(Expr
) and then Known_Null
(Expr
) then
4058 when N_Component_Declaration |
4059 N_Discriminant_Specification
=>
4060 Apply_Compile_Time_Constraint_Error
4062 Msg
=> "(Ada 2005) null not allowed "
4063 & "in null-excluding components??",
4064 Reason
=> CE_Null_Not_Allowed
);
4066 when N_Object_Declaration
=>
4067 Apply_Compile_Time_Constraint_Error
4069 Msg
=> "(Ada 2005) null not allowed "
4070 & "in null-excluding objects??",
4071 Reason
=> CE_Null_Not_Allowed
);
4073 when N_Parameter_Specification
=>
4074 Apply_Compile_Time_Constraint_Error
4076 Msg
=> "(Ada 2005) null not allowed "
4077 & "in null-excluding formals??",
4078 Reason
=> CE_Null_Not_Allowed
);
4085 end Null_Exclusion_Static_Checks
;
4087 ----------------------------------
4088 -- Conditional_Statements_Begin --
4089 ----------------------------------
4091 procedure Conditional_Statements_Begin
is
4093 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
4095 -- If stack overflows, kill all checks, that way we know to simply reset
4096 -- the number of saved checks to zero on return. This should never occur
4099 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
4102 -- In the normal case, we just make a new stack entry saving the current
4103 -- number of saved checks for a later restore.
4106 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
4108 if Debug_Flag_CC
then
4109 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
4113 end Conditional_Statements_Begin
;
4115 --------------------------------
4116 -- Conditional_Statements_End --
4117 --------------------------------
4119 procedure Conditional_Statements_End
is
4121 pragma Assert
(Saved_Checks_TOS
> 0);
4123 -- If the saved checks stack overflowed, then we killed all checks, so
4124 -- setting the number of saved checks back to zero is correct. This
4125 -- should never occur in practice.
4127 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
4128 Num_Saved_Checks
:= 0;
4130 -- In the normal case, restore the number of saved checks from the top
4134 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
4136 if Debug_Flag_CC
then
4137 w
("Conditional_Statements_End: Num_Saved_Checks = ",
4142 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
4143 end Conditional_Statements_End
;
4145 -------------------------
4146 -- Convert_From_Bignum --
4147 -------------------------
4149 function Convert_From_Bignum
(N
: Node_Id
) return Node_Id
is
4150 Loc
: constant Source_Ptr
:= Sloc
(N
);
4153 pragma Assert
(Is_RTE
(Etype
(N
), RE_Bignum
));
4155 -- Construct call From Bignum
4158 Make_Function_Call
(Loc
,
4160 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
4161 Parameter_Associations
=> New_List
(Relocate_Node
(N
)));
4162 end Convert_From_Bignum
;
4164 -----------------------
4165 -- Convert_To_Bignum --
4166 -----------------------
4168 function Convert_To_Bignum
(N
: Node_Id
) return Node_Id
is
4169 Loc
: constant Source_Ptr
:= Sloc
(N
);
4172 -- Nothing to do if Bignum already except call Relocate_Node
4174 if Is_RTE
(Etype
(N
), RE_Bignum
) then
4175 return Relocate_Node
(N
);
4177 -- Otherwise construct call to To_Bignum, converting the operand to the
4178 -- required Long_Long_Integer form.
4181 pragma Assert
(Is_Signed_Integer_Type
(Etype
(N
)));
4183 Make_Function_Call
(Loc
,
4185 New_Occurrence_Of
(RTE
(RE_To_Bignum
), Loc
),
4186 Parameter_Associations
=> New_List
(
4187 Convert_To
(Standard_Long_Long_Integer
, Relocate_Node
(N
))));
4189 end Convert_To_Bignum
;
4191 ---------------------
4192 -- Determine_Range --
4193 ---------------------
4195 Cache_Size
: constant := 2 ** 10;
4196 type Cache_Index
is range 0 .. Cache_Size
- 1;
4197 -- Determine size of below cache (power of 2 is more efficient)
4199 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
4200 Determine_Range_Cache_V
: array (Cache_Index
) of Boolean;
4201 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
4202 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
4203 Determine_Range_Cache_Lo_R
: array (Cache_Index
) of Ureal
;
4204 Determine_Range_Cache_Hi_R
: array (Cache_Index
) of Ureal
;
4205 -- The above arrays are used to implement a small direct cache for
4206 -- Determine_Range and Determine_Range_R calls. Because of the way these
4207 -- subprograms recursively traces subexpressions, and because overflow
4208 -- checking calls the routine on the way up the tree, a quadratic behavior
4209 -- can otherwise be encountered in large expressions. The cache entry for
4210 -- node N is stored in the (N mod Cache_Size) entry, and can be validated
4211 -- by checking the actual node value stored there. The Range_Cache_V array
4212 -- records the setting of Assume_Valid for the cache entry.
4214 procedure Determine_Range
4219 Assume_Valid
: Boolean := False)
4221 Typ
: Entity_Id
:= Etype
(N
);
4222 -- Type to use, may get reset to base type for possibly invalid entity
4226 -- Lo and Hi bounds of left operand
4230 -- Lo and Hi bounds of right (or only) operand
4233 -- Temp variable used to hold a bound node
4236 -- High bound of base type of expression
4240 -- Refined values for low and high bounds, after tightening
4243 -- Used in lower level calls to indicate if call succeeded
4245 Cindex
: Cache_Index
;
4246 -- Used to search cache
4251 function OK_Operands
return Boolean;
4252 -- Used for binary operators. Determines the ranges of the left and
4253 -- right operands, and if they are both OK, returns True, and puts
4254 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4260 function OK_Operands
return Boolean is
4263 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
4270 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4274 -- Start of processing for Determine_Range
4277 -- Prevent junk warnings by initializing range variables
4284 -- For temporary constants internally generated to remove side effects
4285 -- we must use the corresponding expression to determine the range of
4286 -- the expression. But note that the expander can also generate
4287 -- constants in other cases, including deferred constants.
4289 if Is_Entity_Name
(N
)
4290 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
4291 and then Ekind
(Entity
(N
)) = E_Constant
4292 and then Is_Internal_Name
(Chars
(Entity
(N
)))
4294 if Present
(Expression
(Parent
(Entity
(N
)))) then
4296 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
4298 elsif Present
(Full_View
(Entity
(N
))) then
4300 (Expression
(Parent
(Full_View
(Entity
(N
)))),
4301 OK
, Lo
, Hi
, Assume_Valid
);
4309 -- If type is not defined, we can't determine its range
4313 -- We don't deal with anything except discrete types
4315 or else not Is_Discrete_Type
(Typ
)
4317 -- Ignore type for which an error has been posted, since range in
4318 -- this case may well be a bogosity deriving from the error. Also
4319 -- ignore if error posted on the reference node.
4321 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
4327 -- For all other cases, we can determine the range
4331 -- If value is compile time known, then the possible range is the one
4332 -- value that we know this expression definitely has.
4334 if Compile_Time_Known_Value
(N
) then
4335 Lo
:= Expr_Value
(N
);
4340 -- Return if already in the cache
4342 Cindex
:= Cache_Index
(N
mod Cache_Size
);
4344 if Determine_Range_Cache_N
(Cindex
) = N
4346 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
4348 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
4349 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
4353 -- Otherwise, start by finding the bounds of the type of the expression,
4354 -- the value cannot be outside this range (if it is, then we have an
4355 -- overflow situation, which is a separate check, we are talking here
4356 -- only about the expression value).
4358 -- First a check, never try to find the bounds of a generic type, since
4359 -- these bounds are always junk values, and it is only valid to look at
4360 -- the bounds in an instance.
4362 if Is_Generic_Type
(Typ
) then
4367 -- First step, change to use base type unless we know the value is valid
4369 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
4370 or else Assume_No_Invalid_Values
4371 or else Assume_Valid
4375 Typ
:= Underlying_Type
(Base_Type
(Typ
));
4378 -- Retrieve the base type. Handle the case where the base type is a
4379 -- private enumeration type.
4381 Btyp
:= Base_Type
(Typ
);
4383 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
4384 Btyp
:= Full_View
(Btyp
);
4387 -- We use the actual bound unless it is dynamic, in which case use the
4388 -- corresponding base type bound if possible. If we can't get a bound
4389 -- then we figure we can't determine the range (a peculiar case, that
4390 -- perhaps cannot happen, but there is no point in bombing in this
4391 -- optimization circuit.
4393 -- First the low bound
4395 Bound
:= Type_Low_Bound
(Typ
);
4397 if Compile_Time_Known_Value
(Bound
) then
4398 Lo
:= Expr_Value
(Bound
);
4400 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
4401 Lo
:= Expr_Value
(Type_Low_Bound
(Btyp
));
4408 -- Now the high bound
4410 Bound
:= Type_High_Bound
(Typ
);
4412 -- We need the high bound of the base type later on, and this should
4413 -- always be compile time known. Again, it is not clear that this
4414 -- can ever be false, but no point in bombing.
4416 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
4417 Hbound
:= Expr_Value
(Type_High_Bound
(Btyp
));
4425 -- If we have a static subtype, then that may have a tighter bound so
4426 -- use the upper bound of the subtype instead in this case.
4428 if Compile_Time_Known_Value
(Bound
) then
4429 Hi
:= Expr_Value
(Bound
);
4432 -- We may be able to refine this value in certain situations. If any
4433 -- refinement is possible, then Lor and Hir are set to possibly tighter
4434 -- bounds, and OK1 is set to True.
4438 -- For unary plus, result is limited by range of operand
4442 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4444 -- For unary minus, determine range of operand, and negate it
4448 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4455 -- For binary addition, get range of each operand and do the
4456 -- addition to get the result range.
4460 Lor
:= Lo_Left
+ Lo_Right
;
4461 Hir
:= Hi_Left
+ Hi_Right
;
4464 -- Division is tricky. The only case we consider is where the right
4465 -- operand is a positive constant, and in this case we simply divide
4466 -- the bounds of the left operand
4470 if Lo_Right
= Hi_Right
4471 and then Lo_Right
> 0
4473 Lor
:= Lo_Left
/ Lo_Right
;
4474 Hir
:= Hi_Left
/ Lo_Right
;
4480 -- For binary subtraction, get range of each operand and do the worst
4481 -- case subtraction to get the result range.
4483 when N_Op_Subtract
=>
4485 Lor
:= Lo_Left
- Hi_Right
;
4486 Hir
:= Hi_Left
- Lo_Right
;
4489 -- For MOD, if right operand is a positive constant, then result must
4490 -- be in the allowable range of mod results.
4494 if Lo_Right
= Hi_Right
4495 and then Lo_Right
/= 0
4497 if Lo_Right
> 0 then
4499 Hir
:= Lo_Right
- 1;
4501 else -- Lo_Right < 0
4502 Lor
:= Lo_Right
+ 1;
4511 -- For REM, if right operand is a positive constant, then result must
4512 -- be in the allowable range of mod results.
4516 if Lo_Right
= Hi_Right
4517 and then Lo_Right
/= 0
4520 Dval
: constant Uint
:= (abs Lo_Right
) - 1;
4523 -- The sign of the result depends on the sign of the
4524 -- dividend (but not on the sign of the divisor, hence
4525 -- the abs operation above).
4545 -- Attribute reference cases
4547 when N_Attribute_Reference
=>
4548 case Attribute_Name
(N
) is
4550 -- For Pos/Val attributes, we can refine the range using the
4551 -- possible range of values of the attribute expression.
4553 when Name_Pos | Name_Val
=>
4555 (First
(Expressions
(N
)), OK1
, Lor
, Hir
, Assume_Valid
);
4557 -- For Length attribute, use the bounds of the corresponding
4558 -- index type to refine the range.
4562 Atyp
: Entity_Id
:= Etype
(Prefix
(N
));
4570 if Is_Access_Type
(Atyp
) then
4571 Atyp
:= Designated_Type
(Atyp
);
4574 -- For string literal, we know exact value
4576 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
4578 Lo
:= String_Literal_Length
(Atyp
);
4579 Hi
:= String_Literal_Length
(Atyp
);
4583 -- Otherwise check for expression given
4585 if No
(Expressions
(N
)) then
4589 UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
4592 Indx
:= First_Index
(Atyp
);
4593 for J
in 2 .. Inum
loop
4594 Indx
:= Next_Index
(Indx
);
4597 -- If the index type is a formal type or derived from
4598 -- one, the bounds are not static.
4600 if Is_Generic_Type
(Root_Type
(Etype
(Indx
))) then
4606 (Type_Low_Bound
(Etype
(Indx
)), OK1
, LL
, LU
,
4611 (Type_High_Bound
(Etype
(Indx
)), OK1
, UL
, UU
,
4616 -- The maximum value for Length is the biggest
4617 -- possible gap between the values of the bounds.
4618 -- But of course, this value cannot be negative.
4620 Hir
:= UI_Max
(Uint_0
, UU
- LL
+ 1);
4622 -- For constrained arrays, the minimum value for
4623 -- Length is taken from the actual value of the
4624 -- bounds, since the index will be exactly of this
4627 if Is_Constrained
(Atyp
) then
4628 Lor
:= UI_Max
(Uint_0
, UL
- LU
+ 1);
4630 -- For an unconstrained array, the minimum value
4631 -- for length is always zero.
4640 -- No special handling for other attributes
4641 -- Probably more opportunities exist here???
4648 -- For type conversion from one discrete type to another, we can
4649 -- refine the range using the converted value.
4651 when N_Type_Conversion
=>
4652 Determine_Range
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4654 -- Nothing special to do for all other expression kinds
4662 -- At this stage, if OK1 is true, then we know that the actual result of
4663 -- the computed expression is in the range Lor .. Hir. We can use this
4664 -- to restrict the possible range of results.
4668 -- If the refined value of the low bound is greater than the type
4669 -- low bound, then reset it to the more restrictive value. However,
4670 -- we do NOT do this for the case of a modular type where the
4671 -- possible upper bound on the value is above the base type high
4672 -- bound, because that means the result could wrap.
4675 and then not (Is_Modular_Integer_Type
(Typ
) and then Hir
> Hbound
)
4680 -- Similarly, if the refined value of the high bound is less than the
4681 -- value so far, then reset it to the more restrictive value. Again,
4682 -- we do not do this if the refined low bound is negative for a
4683 -- modular type, since this would wrap.
4686 and then not (Is_Modular_Integer_Type
(Typ
) and then Lor
< Uint_0
)
4692 -- Set cache entry for future call and we are all done
4694 Determine_Range_Cache_N
(Cindex
) := N
;
4695 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
4696 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
4697 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
4700 -- If any exception occurs, it means that we have some bug in the compiler,
4701 -- possibly triggered by a previous error, or by some unforeseen peculiar
4702 -- occurrence. However, this is only an optimization attempt, so there is
4703 -- really no point in crashing the compiler. Instead we just decide, too
4704 -- bad, we can't figure out a range in this case after all.
4709 -- Debug flag K disables this behavior (useful for debugging)
4711 if Debug_Flag_K
then
4719 end Determine_Range
;
4721 -----------------------
4722 -- Determine_Range_R --
4723 -----------------------
4725 procedure Determine_Range_R
4730 Assume_Valid
: Boolean := False)
4732 Typ
: Entity_Id
:= Etype
(N
);
4733 -- Type to use, may get reset to base type for possibly invalid entity
4737 -- Lo and Hi bounds of left operand
4741 -- Lo and Hi bounds of right (or only) operand
4744 -- Temp variable used to hold a bound node
4747 -- High bound of base type of expression
4751 -- Refined values for low and high bounds, after tightening
4754 -- Used in lower level calls to indicate if call succeeded
4756 Cindex
: Cache_Index
;
4757 -- Used to search cache
4762 function OK_Operands
return Boolean;
4763 -- Used for binary operators. Determines the ranges of the left and
4764 -- right operands, and if they are both OK, returns True, and puts
4765 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4767 function Round_Machine
(B
: Ureal
) return Ureal
;
4768 -- B is a real bound. Round it using mode Round_Even.
4774 function OK_Operands
return Boolean is
4777 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
4784 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4792 function Round_Machine
(B
: Ureal
) return Ureal
is
4794 return Machine
(Typ
, B
, Round_Even
, N
);
4797 -- Start of processing for Determine_Range_R
4800 -- Prevent junk warnings by initializing range variables
4807 -- For temporary constants internally generated to remove side effects
4808 -- we must use the corresponding expression to determine the range of
4809 -- the expression. But note that the expander can also generate
4810 -- constants in other cases, including deferred constants.
4812 if Is_Entity_Name
(N
)
4813 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
4814 and then Ekind
(Entity
(N
)) = E_Constant
4815 and then Is_Internal_Name
(Chars
(Entity
(N
)))
4817 if Present
(Expression
(Parent
(Entity
(N
)))) then
4819 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
4821 elsif Present
(Full_View
(Entity
(N
))) then
4823 (Expression
(Parent
(Full_View
(Entity
(N
)))),
4824 OK
, Lo
, Hi
, Assume_Valid
);
4833 -- If type is not defined, we can't determine its range
4837 -- We don't deal with anything except IEEE floating-point types
4839 or else not Is_Floating_Point_Type
(Typ
)
4840 or else Float_Rep
(Typ
) /= IEEE_Binary
4842 -- Ignore type for which an error has been posted, since range in
4843 -- this case may well be a bogosity deriving from the error. Also
4844 -- ignore if error posted on the reference node.
4846 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
4852 -- For all other cases, we can determine the range
4856 -- If value is compile time known, then the possible range is the one
4857 -- value that we know this expression definitely has.
4859 if Compile_Time_Known_Value
(N
) then
4860 Lo
:= Expr_Value_R
(N
);
4865 -- Return if already in the cache
4867 Cindex
:= Cache_Index
(N
mod Cache_Size
);
4869 if Determine_Range_Cache_N
(Cindex
) = N
4871 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
4873 Lo
:= Determine_Range_Cache_Lo_R
(Cindex
);
4874 Hi
:= Determine_Range_Cache_Hi_R
(Cindex
);
4878 -- Otherwise, start by finding the bounds of the type of the expression,
4879 -- the value cannot be outside this range (if it is, then we have an
4880 -- overflow situation, which is a separate check, we are talking here
4881 -- only about the expression value).
4883 -- First a check, never try to find the bounds of a generic type, since
4884 -- these bounds are always junk values, and it is only valid to look at
4885 -- the bounds in an instance.
4887 if Is_Generic_Type
(Typ
) then
4892 -- First step, change to use base type unless we know the value is valid
4894 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
4895 or else Assume_No_Invalid_Values
4896 or else Assume_Valid
4900 Typ
:= Underlying_Type
(Base_Type
(Typ
));
4903 -- Retrieve the base type. Handle the case where the base type is a
4906 Btyp
:= Base_Type
(Typ
);
4908 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
4909 Btyp
:= Full_View
(Btyp
);
4912 -- We use the actual bound unless it is dynamic, in which case use the
4913 -- corresponding base type bound if possible. If we can't get a bound
4914 -- then we figure we can't determine the range (a peculiar case, that
4915 -- perhaps cannot happen, but there is no point in bombing in this
4916 -- optimization circuit).
4918 -- First the low bound
4920 Bound
:= Type_Low_Bound
(Typ
);
4922 if Compile_Time_Known_Value
(Bound
) then
4923 Lo
:= Expr_Value_R
(Bound
);
4925 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
4926 Lo
:= Expr_Value_R
(Type_Low_Bound
(Btyp
));
4933 -- Now the high bound
4935 Bound
:= Type_High_Bound
(Typ
);
4937 -- We need the high bound of the base type later on, and this should
4938 -- always be compile time known. Again, it is not clear that this
4939 -- can ever be false, but no point in bombing.
4941 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
4942 Hbound
:= Expr_Value_R
(Type_High_Bound
(Btyp
));
4950 -- If we have a static subtype, then that may have a tighter bound so
4951 -- use the upper bound of the subtype instead in this case.
4953 if Compile_Time_Known_Value
(Bound
) then
4954 Hi
:= Expr_Value_R
(Bound
);
4957 -- We may be able to refine this value in certain situations. If any
4958 -- refinement is possible, then Lor and Hir are set to possibly tighter
4959 -- bounds, and OK1 is set to True.
4963 -- For unary plus, result is limited by range of operand
4967 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4969 -- For unary minus, determine range of operand, and negate it
4973 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4980 -- For binary addition, get range of each operand and do the
4981 -- addition to get the result range.
4985 Lor
:= Round_Machine
(Lo_Left
+ Lo_Right
);
4986 Hir
:= Round_Machine
(Hi_Left
+ Hi_Right
);
4989 -- For binary subtraction, get range of each operand and do the worst
4990 -- case subtraction to get the result range.
4992 when N_Op_Subtract
=>
4994 Lor
:= Round_Machine
(Lo_Left
- Hi_Right
);
4995 Hir
:= Round_Machine
(Hi_Left
- Lo_Right
);
4998 -- For multiplication, get range of each operand and do the
4999 -- four multiplications to get the result range.
5001 when N_Op_Multiply
=>
5004 M1
: constant Ureal
:= Round_Machine
(Lo_Left
* Lo_Right
);
5005 M2
: constant Ureal
:= Round_Machine
(Lo_Left
* Hi_Right
);
5006 M3
: constant Ureal
:= Round_Machine
(Hi_Left
* Lo_Right
);
5007 M4
: constant Ureal
:= Round_Machine
(Hi_Left
* Hi_Right
);
5009 Lor
:= UR_Min
(UR_Min
(M1
, M2
), UR_Min
(M3
, M4
));
5010 Hir
:= UR_Max
(UR_Max
(M1
, M2
), UR_Max
(M3
, M4
));
5014 -- For division, consider separately the cases where the right
5015 -- operand is positive or negative. Otherwise, the right operand
5016 -- can be arbitrarily close to zero, so the result is likely to
5017 -- be unbounded in one direction, do not attempt to compute it.
5022 -- Right operand is positive
5024 if Lo_Right
> Ureal_0
then
5026 -- If the low bound of the left operand is negative, obtain
5027 -- the overall low bound by dividing it by the smallest
5028 -- value of the right operand, and otherwise by the largest
5029 -- value of the right operand.
5031 if Lo_Left
< Ureal_0
then
5032 Lor
:= Round_Machine
(Lo_Left
/ Lo_Right
);
5034 Lor
:= Round_Machine
(Lo_Left
/ Hi_Right
);
5037 -- If the high bound of the left operand is negative, obtain
5038 -- the overall high bound by dividing it by the largest
5039 -- value of the right operand, and otherwise by the
5040 -- smallest value of the right operand.
5042 if Hi_Left
< Ureal_0
then
5043 Hir
:= Round_Machine
(Hi_Left
/ Hi_Right
);
5045 Hir
:= Round_Machine
(Hi_Left
/ Lo_Right
);
5048 -- Right operand is negative
5050 elsif Hi_Right
< Ureal_0
then
5052 -- If the low bound of the left operand is negative, obtain
5053 -- the overall low bound by dividing it by the largest
5054 -- value of the right operand, and otherwise by the smallest
5055 -- value of the right operand.
5057 if Lo_Left
< Ureal_0
then
5058 Lor
:= Round_Machine
(Lo_Left
/ Hi_Right
);
5060 Lor
:= Round_Machine
(Lo_Left
/ Lo_Right
);
5063 -- If the high bound of the left operand is negative, obtain
5064 -- the overall high bound by dividing it by the smallest
5065 -- value of the right operand, and otherwise by the
5066 -- largest value of the right operand.
5068 if Hi_Left
< Ureal_0
then
5069 Hir
:= Round_Machine
(Hi_Left
/ Lo_Right
);
5071 Hir
:= Round_Machine
(Hi_Left
/ Hi_Right
);
5079 -- For type conversion from one floating-point type to another, we
5080 -- can refine the range using the converted value.
5082 when N_Type_Conversion
=>
5083 Determine_Range_R
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
5085 -- Nothing special to do for all other expression kinds
5093 -- At this stage, if OK1 is true, then we know that the actual result of
5094 -- the computed expression is in the range Lor .. Hir. We can use this
5095 -- to restrict the possible range of results.
5099 -- If the refined value of the low bound is greater than the type
5100 -- low bound, then reset it to the more restrictive value.
5106 -- Similarly, if the refined value of the high bound is less than the
5107 -- value so far, then reset it to the more restrictive value.
5114 -- Set cache entry for future call and we are all done
5116 Determine_Range_Cache_N
(Cindex
) := N
;
5117 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
5118 Determine_Range_Cache_Lo_R
(Cindex
) := Lo
;
5119 Determine_Range_Cache_Hi_R
(Cindex
) := Hi
;
5122 -- If any exception occurs, it means that we have some bug in the compiler,
5123 -- possibly triggered by a previous error, or by some unforeseen peculiar
5124 -- occurrence. However, this is only an optimization attempt, so there is
5125 -- really no point in crashing the compiler. Instead we just decide, too
5126 -- bad, we can't figure out a range in this case after all.
5131 -- Debug flag K disables this behavior (useful for debugging)
5133 if Debug_Flag_K
then
5141 end Determine_Range_R
;
5143 ------------------------------------
5144 -- Discriminant_Checks_Suppressed --
5145 ------------------------------------
5147 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5150 if Is_Unchecked_Union
(E
) then
5152 elsif Checks_May_Be_Suppressed
(E
) then
5153 return Is_Check_Suppressed
(E
, Discriminant_Check
);
5157 return Scope_Suppress
.Suppress
(Discriminant_Check
);
5158 end Discriminant_Checks_Suppressed
;
5160 --------------------------------
5161 -- Division_Checks_Suppressed --
5162 --------------------------------
5164 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5166 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
5167 return Is_Check_Suppressed
(E
, Division_Check
);
5169 return Scope_Suppress
.Suppress
(Division_Check
);
5171 end Division_Checks_Suppressed
;
5173 --------------------------------------
5174 -- Duplicated_Tag_Checks_Suppressed --
5175 --------------------------------------
5177 function Duplicated_Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5179 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
5180 return Is_Check_Suppressed
(E
, Duplicated_Tag_Check
);
5182 return Scope_Suppress
.Suppress
(Duplicated_Tag_Check
);
5184 end Duplicated_Tag_Checks_Suppressed
;
5186 -----------------------------------
5187 -- Elaboration_Checks_Suppressed --
5188 -----------------------------------
5190 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5192 -- The complication in this routine is that if we are in the dynamic
5193 -- model of elaboration, we also check All_Checks, since All_Checks
5194 -- does not set Elaboration_Check explicitly.
5197 if Kill_Elaboration_Checks
(E
) then
5200 elsif Checks_May_Be_Suppressed
(E
) then
5201 if Is_Check_Suppressed
(E
, Elaboration_Check
) then
5203 elsif Dynamic_Elaboration_Checks
then
5204 return Is_Check_Suppressed
(E
, All_Checks
);
5211 if Scope_Suppress
.Suppress
(Elaboration_Check
) then
5213 elsif Dynamic_Elaboration_Checks
then
5214 return Scope_Suppress
.Suppress
(All_Checks
);
5218 end Elaboration_Checks_Suppressed
;
5220 ---------------------------
5221 -- Enable_Overflow_Check --
5222 ---------------------------
5224 procedure Enable_Overflow_Check
(N
: Node_Id
) is
5225 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
5226 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
5234 Do_Ovflow_Check
: Boolean;
5237 if Debug_Flag_CC
then
5238 w
("Enable_Overflow_Check for node ", Int
(N
));
5239 Write_Str
(" Source location = ");
5244 -- No check if overflow checks suppressed for type of node
5246 if Overflow_Checks_Suppressed
(Etype
(N
)) then
5249 -- Nothing to do for unsigned integer types, which do not overflow
5251 elsif Is_Modular_Integer_Type
(Typ
) then
5255 -- This is the point at which processing for STRICT mode diverges
5256 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
5257 -- probably more extreme that it needs to be, but what is going on here
5258 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
5259 -- to leave the processing for STRICT mode untouched. There were
5260 -- two reasons for this. First it avoided any incompatible change of
5261 -- behavior. Second, it guaranteed that STRICT mode continued to be
5264 -- The big difference is that in STRICT mode there is a fair amount of
5265 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
5266 -- know that no check is needed. We skip all that in the two new modes,
5267 -- since really overflow checking happens over a whole subtree, and we
5268 -- do the corresponding optimizations later on when applying the checks.
5270 if Mode
in Minimized_Or_Eliminated
then
5271 if not (Overflow_Checks_Suppressed
(Etype
(N
)))
5272 and then not (Is_Entity_Name
(N
)
5273 and then Overflow_Checks_Suppressed
(Entity
(N
)))
5275 Activate_Overflow_Check
(N
);
5278 if Debug_Flag_CC
then
5279 w
("Minimized/Eliminated mode");
5285 -- Remainder of processing is for STRICT case, and is unchanged from
5286 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
5288 -- Nothing to do if the range of the result is known OK. We skip this
5289 -- for conversions, since the caller already did the check, and in any
5290 -- case the condition for deleting the check for a type conversion is
5293 if Nkind
(N
) /= N_Type_Conversion
then
5294 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
5296 -- Note in the test below that we assume that the range is not OK
5297 -- if a bound of the range is equal to that of the type. That's not
5298 -- quite accurate but we do this for the following reasons:
5300 -- a) The way that Determine_Range works, it will typically report
5301 -- the bounds of the value as being equal to the bounds of the
5302 -- type, because it either can't tell anything more precise, or
5303 -- does not think it is worth the effort to be more precise.
5305 -- b) It is very unusual to have a situation in which this would
5306 -- generate an unnecessary overflow check (an example would be
5307 -- a subtype with a range 0 .. Integer'Last - 1 to which the
5308 -- literal value one is added).
5310 -- c) The alternative is a lot of special casing in this routine
5311 -- which would partially duplicate Determine_Range processing.
5314 Do_Ovflow_Check
:= True;
5316 -- Note that the following checks are quite deliberately > and <
5317 -- rather than >= and <= as explained above.
5319 if Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
5321 Hi
< Expr_Value
(Type_High_Bound
(Typ
))
5323 Do_Ovflow_Check
:= False;
5325 -- Despite the comments above, it is worth dealing specially with
5326 -- division specially. The only case where integer division can
5327 -- overflow is (largest negative number) / (-1). So we will do
5328 -- an extra range analysis to see if this is possible.
5330 elsif Nkind
(N
) = N_Op_Divide
then
5332 (Left_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
5334 if OK
and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
)) then
5335 Do_Ovflow_Check
:= False;
5339 (Right_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
5341 if OK
and then (Lo
> Uint_Minus_1
5345 Do_Ovflow_Check
:= False;
5350 -- If no overflow check required, we are done
5352 if not Do_Ovflow_Check
then
5353 if Debug_Flag_CC
then
5354 w
("No overflow check required");
5362 -- If not in optimizing mode, set flag and we are done. We are also done
5363 -- (and just set the flag) if the type is not a discrete type, since it
5364 -- is not worth the effort to eliminate checks for other than discrete
5365 -- types. In addition, we take this same path if we have stored the
5366 -- maximum number of checks possible already (a very unlikely situation,
5367 -- but we do not want to blow up).
5369 if Optimization_Level
= 0
5370 or else not Is_Discrete_Type
(Etype
(N
))
5371 or else Num_Saved_Checks
= Saved_Checks
'Last
5373 Activate_Overflow_Check
(N
);
5375 if Debug_Flag_CC
then
5376 w
("Optimization off");
5382 -- Otherwise evaluate and check the expression
5387 Target_Type
=> Empty
,
5393 if Debug_Flag_CC
then
5394 w
("Called Find_Check");
5398 w
(" Check_Num = ", Chk
);
5399 w
(" Ent = ", Int
(Ent
));
5400 Write_Str
(" Ofs = ");
5405 -- If check is not of form to optimize, then set flag and we are done
5408 Activate_Overflow_Check
(N
);
5412 -- If check is already performed, then return without setting flag
5415 if Debug_Flag_CC
then
5416 w
("Check suppressed!");
5422 -- Here we will make a new entry for the new check
5424 Activate_Overflow_Check
(N
);
5425 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
5426 Saved_Checks
(Num_Saved_Checks
) :=
5431 Target_Type
=> Empty
);
5433 if Debug_Flag_CC
then
5434 w
("Make new entry, check number = ", Num_Saved_Checks
);
5435 w
(" Entity = ", Int
(Ent
));
5436 Write_Str
(" Offset = ");
5438 w
(" Check_Type = O");
5439 w
(" Target_Type = Empty");
5442 -- If we get an exception, then something went wrong, probably because of
5443 -- an error in the structure of the tree due to an incorrect program. Or
5444 -- it may be a bug in the optimization circuit. In either case the safest
5445 -- thing is simply to set the check flag unconditionally.
5449 Activate_Overflow_Check
(N
);
5451 if Debug_Flag_CC
then
5452 w
(" exception occurred, overflow flag set");
5456 end Enable_Overflow_Check
;
5458 ------------------------
5459 -- Enable_Range_Check --
5460 ------------------------
5462 procedure Enable_Range_Check
(N
: Node_Id
) is
5471 -- Return if unchecked type conversion with range check killed. In this
5472 -- case we never set the flag (that's what Kill_Range_Check is about).
5474 if Nkind
(N
) = N_Unchecked_Type_Conversion
5475 and then Kill_Range_Check
(N
)
5480 -- Do not set range check flag if parent is assignment statement or
5481 -- object declaration with Suppress_Assignment_Checks flag set
5483 if Nkind_In
(Parent
(N
), N_Assignment_Statement
, N_Object_Declaration
)
5484 and then Suppress_Assignment_Checks
(Parent
(N
))
5489 -- Check for various cases where we should suppress the range check
5491 -- No check if range checks suppressed for type of node
5493 if Present
(Etype
(N
)) and then Range_Checks_Suppressed
(Etype
(N
)) then
5496 -- No check if node is an entity name, and range checks are suppressed
5497 -- for this entity, or for the type of this entity.
5499 elsif Is_Entity_Name
(N
)
5500 and then (Range_Checks_Suppressed
(Entity
(N
))
5501 or else Range_Checks_Suppressed
(Etype
(Entity
(N
))))
5505 -- No checks if index of array, and index checks are suppressed for
5506 -- the array object or the type of the array.
5508 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
then
5510 Pref
: constant Node_Id
:= Prefix
(Parent
(N
));
5512 if Is_Entity_Name
(Pref
)
5513 and then Index_Checks_Suppressed
(Entity
(Pref
))
5516 elsif Index_Checks_Suppressed
(Etype
(Pref
)) then
5522 -- Debug trace output
5524 if Debug_Flag_CC
then
5525 w
("Enable_Range_Check for node ", Int
(N
));
5526 Write_Str
(" Source location = ");
5531 -- If not in optimizing mode, set flag and we are done. We are also done
5532 -- (and just set the flag) if the type is not a discrete type, since it
5533 -- is not worth the effort to eliminate checks for other than discrete
5534 -- types. In addition, we take this same path if we have stored the
5535 -- maximum number of checks possible already (a very unlikely situation,
5536 -- but we do not want to blow up).
5538 if Optimization_Level
= 0
5539 or else No
(Etype
(N
))
5540 or else not Is_Discrete_Type
(Etype
(N
))
5541 or else Num_Saved_Checks
= Saved_Checks
'Last
5543 Activate_Range_Check
(N
);
5545 if Debug_Flag_CC
then
5546 w
("Optimization off");
5552 -- Otherwise find out the target type
5556 -- For assignment, use left side subtype
5558 if Nkind
(P
) = N_Assignment_Statement
5559 and then Expression
(P
) = N
5561 Ttyp
:= Etype
(Name
(P
));
5563 -- For indexed component, use subscript subtype
5565 elsif Nkind
(P
) = N_Indexed_Component
then
5572 Atyp
:= Etype
(Prefix
(P
));
5574 if Is_Access_Type
(Atyp
) then
5575 Atyp
:= Designated_Type
(Atyp
);
5577 -- If the prefix is an access to an unconstrained array,
5578 -- perform check unconditionally: it depends on the bounds of
5579 -- an object and we cannot currently recognize whether the test
5580 -- may be redundant.
5582 if not Is_Constrained
(Atyp
) then
5583 Activate_Range_Check
(N
);
5587 -- Ditto if prefix is simply an unconstrained array. We used
5588 -- to think this case was OK, if the prefix was not an explicit
5589 -- dereference, but we have now seen a case where this is not
5590 -- true, so it is safer to just suppress the optimization in this
5591 -- case. The back end is getting better at eliminating redundant
5592 -- checks in any case, so the loss won't be important.
5594 elsif Is_Array_Type
(Atyp
)
5595 and then not Is_Constrained
(Atyp
)
5597 Activate_Range_Check
(N
);
5601 Indx
:= First_Index
(Atyp
);
5602 Subs
:= First
(Expressions
(P
));
5605 Ttyp
:= Etype
(Indx
);
5614 -- For now, ignore all other cases, they are not so interesting
5617 if Debug_Flag_CC
then
5618 w
(" target type not found, flag set");
5621 Activate_Range_Check
(N
);
5625 -- Evaluate and check the expression
5630 Target_Type
=> Ttyp
,
5636 if Debug_Flag_CC
then
5637 w
("Called Find_Check");
5638 w
("Target_Typ = ", Int
(Ttyp
));
5642 w
(" Check_Num = ", Chk
);
5643 w
(" Ent = ", Int
(Ent
));
5644 Write_Str
(" Ofs = ");
5649 -- If check is not of form to optimize, then set flag and we are done
5652 if Debug_Flag_CC
then
5653 w
(" expression not of optimizable type, flag set");
5656 Activate_Range_Check
(N
);
5660 -- If check is already performed, then return without setting flag
5663 if Debug_Flag_CC
then
5664 w
("Check suppressed!");
5670 -- Here we will make a new entry for the new check
5672 Activate_Range_Check
(N
);
5673 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
5674 Saved_Checks
(Num_Saved_Checks
) :=
5679 Target_Type
=> Ttyp
);
5681 if Debug_Flag_CC
then
5682 w
("Make new entry, check number = ", Num_Saved_Checks
);
5683 w
(" Entity = ", Int
(Ent
));
5684 Write_Str
(" Offset = ");
5686 w
(" Check_Type = R");
5687 w
(" Target_Type = ", Int
(Ttyp
));
5688 pg
(Union_Id
(Ttyp
));
5691 -- If we get an exception, then something went wrong, probably because of
5692 -- an error in the structure of the tree due to an incorrect program. Or
5693 -- it may be a bug in the optimization circuit. In either case the safest
5694 -- thing is simply to set the check flag unconditionally.
5698 Activate_Range_Check
(N
);
5700 if Debug_Flag_CC
then
5701 w
(" exception occurred, range flag set");
5705 end Enable_Range_Check
;
5711 procedure Ensure_Valid
5713 Holes_OK
: Boolean := False;
5714 Related_Id
: Entity_Id
:= Empty
;
5715 Is_Low_Bound
: Boolean := False;
5716 Is_High_Bound
: Boolean := False)
5718 Typ
: constant Entity_Id
:= Etype
(Expr
);
5721 -- Ignore call if we are not doing any validity checking
5723 if not Validity_Checks_On
then
5726 -- Ignore call if range or validity checks suppressed on entity or type
5728 elsif Range_Or_Validity_Checks_Suppressed
(Expr
) then
5731 -- No check required if expression is from the expander, we assume the
5732 -- expander will generate whatever checks are needed. Note that this is
5733 -- not just an optimization, it avoids infinite recursions.
5735 -- Unchecked conversions must be checked, unless they are initialized
5736 -- scalar values, as in a component assignment in an init proc.
5738 -- In addition, we force a check if Force_Validity_Checks is set
5740 elsif not Comes_From_Source
(Expr
)
5741 and then not Force_Validity_Checks
5742 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
5743 or else Kill_Range_Check
(Expr
))
5747 -- No check required if expression is known to have valid value
5749 elsif Expr_Known_Valid
(Expr
) then
5752 -- Ignore case of enumeration with holes where the flag is set not to
5753 -- worry about holes, since no special validity check is needed
5755 elsif Is_Enumeration_Type
(Typ
)
5756 and then Has_Non_Standard_Rep
(Typ
)
5761 -- No check required on the left-hand side of an assignment
5763 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
5764 and then Expr
= Name
(Parent
(Expr
))
5768 -- No check on a universal real constant. The context will eventually
5769 -- convert it to a machine number for some target type, or report an
5772 elsif Nkind
(Expr
) = N_Real_Literal
5773 and then Etype
(Expr
) = Universal_Real
5777 -- If the expression denotes a component of a packed boolean array,
5778 -- no possible check applies. We ignore the old ACATS chestnuts that
5779 -- involve Boolean range True..True.
5781 -- Note: validity checks are generated for expressions that yield a
5782 -- scalar type, when it is possible to create a value that is outside of
5783 -- the type. If this is a one-bit boolean no such value exists. This is
5784 -- an optimization, and it also prevents compiler blowing up during the
5785 -- elaboration of improperly expanded packed array references.
5787 elsif Nkind
(Expr
) = N_Indexed_Component
5788 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Expr
)))
5789 and then Root_Type
(Etype
(Expr
)) = Standard_Boolean
5793 -- For an expression with actions, we want to insert the validity check
5794 -- on the final Expression.
5796 elsif Nkind
(Expr
) = N_Expression_With_Actions
then
5797 Ensure_Valid
(Expression
(Expr
));
5800 -- An annoying special case. If this is an out parameter of a scalar
5801 -- type, then the value is not going to be accessed, therefore it is
5802 -- inappropriate to do any validity check at the call site.
5805 -- Only need to worry about scalar types
5807 if Is_Scalar_Type
(Typ
) then
5817 -- Find actual argument (which may be a parameter association)
5818 -- and the parent of the actual argument (the call statement)
5823 if Nkind
(P
) = N_Parameter_Association
then
5828 -- Only need to worry if we are argument of a procedure call
5829 -- since functions don't have out parameters. If this is an
5830 -- indirect or dispatching call, get signature from the
5833 if Nkind
(P
) = N_Procedure_Call_Statement
then
5834 L
:= Parameter_Associations
(P
);
5836 if Is_Entity_Name
(Name
(P
)) then
5837 E
:= Entity
(Name
(P
));
5839 pragma Assert
(Nkind
(Name
(P
)) = N_Explicit_Dereference
);
5840 E
:= Etype
(Name
(P
));
5843 -- Only need to worry if there are indeed actuals, and if
5844 -- this could be a procedure call, otherwise we cannot get a
5845 -- match (either we are not an argument, or the mode of the
5846 -- formal is not OUT). This test also filters out the
5849 if Is_Non_Empty_List
(L
) and then Is_Subprogram
(E
) then
5851 -- This is the loop through parameters, looking for an
5852 -- OUT parameter for which we are the argument.
5854 F
:= First_Formal
(E
);
5856 while Present
(F
) loop
5857 if Ekind
(F
) = E_Out_Parameter
and then A
= N
then
5870 -- If this is a boolean expression, only its elementary operands need
5871 -- checking: if they are valid, a boolean or short-circuit operation
5872 -- with them will be valid as well.
5874 if Base_Type
(Typ
) = Standard_Boolean
5876 (Nkind
(Expr
) in N_Op
or else Nkind
(Expr
) in N_Short_Circuit
)
5881 -- If we fall through, a validity check is required
5883 Insert_Valid_Check
(Expr
, Related_Id
, Is_Low_Bound
, Is_High_Bound
);
5885 if Is_Entity_Name
(Expr
)
5886 and then Safe_To_Capture_Value
(Expr
, Entity
(Expr
))
5888 Set_Is_Known_Valid
(Entity
(Expr
));
5892 ----------------------
5893 -- Expr_Known_Valid --
5894 ----------------------
5896 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
5897 Typ
: constant Entity_Id
:= Etype
(Expr
);
5900 -- Non-scalar types are always considered valid, since they never give
5901 -- rise to the issues of erroneous or bounded error behavior that are
5902 -- the concern. In formal reference manual terms the notion of validity
5903 -- only applies to scalar types. Note that even when packed arrays are
5904 -- represented using modular types, they are still arrays semantically,
5905 -- so they are also always valid (in particular, the unused bits can be
5906 -- random rubbish without affecting the validity of the array value).
5908 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Impl_Type
(Typ
) then
5911 -- If no validity checking, then everything is considered valid
5913 elsif not Validity_Checks_On
then
5916 -- Floating-point types are considered valid unless floating-point
5917 -- validity checks have been specifically turned on.
5919 elsif Is_Floating_Point_Type
(Typ
)
5920 and then not Validity_Check_Floating_Point
5924 -- If the expression is the value of an object that is known to be
5925 -- valid, then clearly the expression value itself is valid.
5927 elsif Is_Entity_Name
(Expr
)
5928 and then Is_Known_Valid
(Entity
(Expr
))
5930 -- Exclude volatile variables
5932 and then not Treat_As_Volatile
(Entity
(Expr
))
5936 -- References to discriminants are always considered valid. The value
5937 -- of a discriminant gets checked when the object is built. Within the
5938 -- record, we consider it valid, and it is important to do so, since
5939 -- otherwise we can try to generate bogus validity checks which
5940 -- reference discriminants out of scope. Discriminants of concurrent
5941 -- types are excluded for the same reason.
5943 elsif Is_Entity_Name
(Expr
)
5944 and then Denotes_Discriminant
(Expr
, Check_Concurrent
=> True)
5948 -- If the type is one for which all values are known valid, then we are
5949 -- sure that the value is valid except in the slightly odd case where
5950 -- the expression is a reference to a variable whose size has been
5951 -- explicitly set to a value greater than the object size.
5953 elsif Is_Known_Valid
(Typ
) then
5954 if Is_Entity_Name
(Expr
)
5955 and then Ekind
(Entity
(Expr
)) = E_Variable
5956 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
5963 -- Integer and character literals always have valid values, where
5964 -- appropriate these will be range checked in any case.
5966 elsif Nkind_In
(Expr
, N_Integer_Literal
, N_Character_Literal
) then
5969 -- If we have a type conversion or a qualification of a known valid
5970 -- value, then the result will always be valid.
5972 elsif Nkind_In
(Expr
, N_Type_Conversion
, N_Qualified_Expression
) then
5973 return Expr_Known_Valid
(Expression
(Expr
));
5975 -- Case of expression is a non-floating-point operator. In this case we
5976 -- can assume the result is valid the generated code for the operator
5977 -- will include whatever checks are needed (e.g. range checks) to ensure
5978 -- validity. This assumption does not hold for the floating-point case,
5979 -- since floating-point operators can generate Infinite or NaN results
5980 -- which are considered invalid.
5982 -- Historical note: in older versions, the exemption of floating-point
5983 -- types from this assumption was done only in cases where the parent
5984 -- was an assignment, function call or parameter association. Presumably
5985 -- the idea was that in other contexts, the result would be checked
5986 -- elsewhere, but this list of cases was missing tests (at least the
5987 -- N_Object_Declaration case, as shown by a reported missing validity
5988 -- check), and it is not clear why function calls but not procedure
5989 -- calls were tested for. It really seems more accurate and much
5990 -- safer to recognize that expressions which are the result of a
5991 -- floating-point operator can never be assumed to be valid.
5993 elsif Nkind
(Expr
) in N_Op
and then not Is_Floating_Point_Type
(Typ
) then
5996 -- The result of a membership test is always valid, since it is true or
5997 -- false, there are no other possibilities.
5999 elsif Nkind
(Expr
) in N_Membership_Test
then
6002 -- For all other cases, we do not know the expression is valid
6007 end Expr_Known_Valid
;
6013 procedure Find_Check
6015 Check_Type
: Character;
6016 Target_Type
: Entity_Id
;
6017 Entry_OK
: out Boolean;
6018 Check_Num
: out Nat
;
6019 Ent
: out Entity_Id
;
6022 function Within_Range_Of
6023 (Target_Type
: Entity_Id
;
6024 Check_Type
: Entity_Id
) return Boolean;
6025 -- Given a requirement for checking a range against Target_Type, and
6026 -- and a range Check_Type against which a check has already been made,
6027 -- determines if the check against check type is sufficient to ensure
6028 -- that no check against Target_Type is required.
6030 ---------------------
6031 -- Within_Range_Of --
6032 ---------------------
6034 function Within_Range_Of
6035 (Target_Type
: Entity_Id
;
6036 Check_Type
: Entity_Id
) return Boolean
6039 if Target_Type
= Check_Type
then
6044 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
6045 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
6046 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
6047 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
6051 or else (Compile_Time_Known_Value
(Tlo
)
6053 Compile_Time_Known_Value
(Clo
)
6055 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
6058 or else (Compile_Time_Known_Value
(Thi
)
6060 Compile_Time_Known_Value
(Chi
)
6062 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
6070 end Within_Range_Of
;
6072 -- Start of processing for Find_Check
6075 -- Establish default, in case no entry is found
6079 -- Case of expression is simple entity reference
6081 if Is_Entity_Name
(Expr
) then
6082 Ent
:= Entity
(Expr
);
6085 -- Case of expression is entity + known constant
6087 elsif Nkind
(Expr
) = N_Op_Add
6088 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
6089 and then Is_Entity_Name
(Left_Opnd
(Expr
))
6091 Ent
:= Entity
(Left_Opnd
(Expr
));
6092 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
6094 -- Case of expression is entity - known constant
6096 elsif Nkind
(Expr
) = N_Op_Subtract
6097 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
6098 and then Is_Entity_Name
(Left_Opnd
(Expr
))
6100 Ent
:= Entity
(Left_Opnd
(Expr
));
6101 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
6103 -- Any other expression is not of the right form
6112 -- Come here with expression of appropriate form, check if entity is an
6113 -- appropriate one for our purposes.
6115 if (Ekind
(Ent
) = E_Variable
6116 or else Is_Constant_Object
(Ent
))
6117 and then not Is_Library_Level_Entity
(Ent
)
6125 -- See if there is matching check already
6127 for J
in reverse 1 .. Num_Saved_Checks
loop
6129 SC
: Saved_Check
renames Saved_Checks
(J
);
6131 if SC
.Killed
= False
6132 and then SC
.Entity
= Ent
6133 and then SC
.Offset
= Ofs
6134 and then SC
.Check_Type
= Check_Type
6135 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
6143 -- If we fall through entry was not found
6148 ---------------------------------
6149 -- Generate_Discriminant_Check --
6150 ---------------------------------
6152 -- Note: the code for this procedure is derived from the
6153 -- Emit_Discriminant_Check Routine in trans.c.
6155 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
6156 Loc
: constant Source_Ptr
:= Sloc
(N
);
6157 Pref
: constant Node_Id
:= Prefix
(N
);
6158 Sel
: constant Node_Id
:= Selector_Name
(N
);
6160 Orig_Comp
: constant Entity_Id
:=
6161 Original_Record_Component
(Entity
(Sel
));
6162 -- The original component to be checked
6164 Discr_Fct
: constant Entity_Id
:=
6165 Discriminant_Checking_Func
(Orig_Comp
);
6166 -- The discriminant checking function
6169 -- One discriminant to be checked in the type
6171 Real_Discr
: Entity_Id
;
6172 -- Actual discriminant in the call
6174 Pref_Type
: Entity_Id
;
6175 -- Type of relevant prefix (ignoring private/access stuff)
6178 -- List of arguments for function call
6181 -- Keep track of the formal corresponding to the actual we build for
6182 -- each discriminant, in order to be able to perform the necessary type
6186 -- Selected component reference for checking function argument
6189 Pref_Type
:= Etype
(Pref
);
6191 -- Force evaluation of the prefix, so that it does not get evaluated
6192 -- twice (once for the check, once for the actual reference). Such a
6193 -- double evaluation is always a potential source of inefficiency, and
6194 -- is functionally incorrect in the volatile case, or when the prefix
6195 -- may have side-effects. A non-volatile entity or a component of a
6196 -- non-volatile entity requires no evaluation.
6198 if Is_Entity_Name
(Pref
) then
6199 if Treat_As_Volatile
(Entity
(Pref
)) then
6200 Force_Evaluation
(Pref
, Name_Req
=> True);
6203 elsif Treat_As_Volatile
(Etype
(Pref
)) then
6204 Force_Evaluation
(Pref
, Name_Req
=> True);
6206 elsif Nkind
(Pref
) = N_Selected_Component
6207 and then Is_Entity_Name
(Prefix
(Pref
))
6212 Force_Evaluation
(Pref
, Name_Req
=> True);
6215 -- For a tagged type, use the scope of the original component to
6216 -- obtain the type, because ???
6218 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
6219 Pref_Type
:= Scope
(Orig_Comp
);
6221 -- For an untagged derived type, use the discriminants of the parent
6222 -- which have been renamed in the derivation, possibly by a one-to-many
6223 -- discriminant constraint. For untagged type, initially get the Etype
6227 if Is_Derived_Type
(Pref_Type
)
6228 and then Number_Discriminants
(Pref_Type
) /=
6229 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
6231 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
6235 -- We definitely should have a checking function, This routine should
6236 -- not be called if no discriminant checking function is present.
6238 pragma Assert
(Present
(Discr_Fct
));
6240 -- Create the list of the actual parameters for the call. This list
6241 -- is the list of the discriminant fields of the record expression to
6242 -- be discriminant checked.
6245 Formal
:= First_Formal
(Discr_Fct
);
6246 Discr
:= First_Discriminant
(Pref_Type
);
6247 while Present
(Discr
) loop
6249 -- If we have a corresponding discriminant field, and a parent
6250 -- subtype is present, then we want to use the corresponding
6251 -- discriminant since this is the one with the useful value.
6253 if Present
(Corresponding_Discriminant
(Discr
))
6254 and then Ekind
(Pref_Type
) = E_Record_Type
6255 and then Present
(Parent_Subtype
(Pref_Type
))
6257 Real_Discr
:= Corresponding_Discriminant
(Discr
);
6259 Real_Discr
:= Discr
;
6262 -- Construct the reference to the discriminant
6265 Make_Selected_Component
(Loc
,
6267 Unchecked_Convert_To
(Pref_Type
,
6268 Duplicate_Subexpr
(Pref
)),
6269 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
6271 -- Manually analyze and resolve this selected component. We really
6272 -- want it just as it appears above, and do not want the expander
6273 -- playing discriminal games etc with this reference. Then we append
6274 -- the argument to the list we are gathering.
6276 Set_Etype
(Scomp
, Etype
(Real_Discr
));
6277 Set_Analyzed
(Scomp
, True);
6278 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
6280 Next_Formal_With_Extras
(Formal
);
6281 Next_Discriminant
(Discr
);
6284 -- Now build and insert the call
6287 Make_Raise_Constraint_Error
(Loc
,
6289 Make_Function_Call
(Loc
,
6290 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
6291 Parameter_Associations
=> Args
),
6292 Reason
=> CE_Discriminant_Check_Failed
));
6293 end Generate_Discriminant_Check
;
6295 ---------------------------
6296 -- Generate_Index_Checks --
6297 ---------------------------
6299 procedure Generate_Index_Checks
(N
: Node_Id
) is
6301 function Entity_Of_Prefix
return Entity_Id
;
6302 -- Returns the entity of the prefix of N (or Empty if not found)
6304 ----------------------
6305 -- Entity_Of_Prefix --
6306 ----------------------
6308 function Entity_Of_Prefix
return Entity_Id
is
6313 while not Is_Entity_Name
(P
) loop
6314 if not Nkind_In
(P
, N_Selected_Component
,
6315 N_Indexed_Component
)
6324 end Entity_Of_Prefix
;
6328 Loc
: constant Source_Ptr
:= Sloc
(N
);
6329 A
: constant Node_Id
:= Prefix
(N
);
6330 A_Ent
: constant Entity_Id
:= Entity_Of_Prefix
;
6333 -- Start of processing for Generate_Index_Checks
6336 -- Ignore call if the prefix is not an array since we have a serious
6337 -- error in the sources. Ignore it also if index checks are suppressed
6338 -- for array object or type.
6340 if not Is_Array_Type
(Etype
(A
))
6341 or else (Present
(A_Ent
) and then Index_Checks_Suppressed
(A_Ent
))
6342 or else Index_Checks_Suppressed
(Etype
(A
))
6346 -- The indexed component we are dealing with contains 'Loop_Entry in its
6347 -- prefix. This case arises when analysis has determined that constructs
6350 -- Prefix'Loop_Entry (Expr)
6351 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
6353 -- require rewriting for error detection purposes. A side effect of this
6354 -- action is the generation of index checks that mention 'Loop_Entry.
6355 -- Delay the generation of the check until 'Loop_Entry has been properly
6356 -- expanded. This is done in Expand_Loop_Entry_Attributes.
6358 elsif Nkind
(Prefix
(N
)) = N_Attribute_Reference
6359 and then Attribute_Name
(Prefix
(N
)) = Name_Loop_Entry
6364 -- Generate a raise of constraint error with the appropriate reason and
6365 -- a condition of the form:
6367 -- Base_Type (Sub) not in Array'Range (Subscript)
6369 -- Note that the reason we generate the conversion to the base type here
6370 -- is that we definitely want the range check to take place, even if it
6371 -- looks like the subtype is OK. Optimization considerations that allow
6372 -- us to omit the check have already been taken into account in the
6373 -- setting of the Do_Range_Check flag earlier on.
6375 Sub
:= First
(Expressions
(N
));
6377 -- Handle string literals
6379 if Ekind
(Etype
(A
)) = E_String_Literal_Subtype
then
6380 if Do_Range_Check
(Sub
) then
6381 Set_Do_Range_Check
(Sub
, False);
6383 -- For string literals we obtain the bounds of the string from the
6384 -- associated subtype.
6387 Make_Raise_Constraint_Error
(Loc
,
6391 Convert_To
(Base_Type
(Etype
(Sub
)),
6392 Duplicate_Subexpr_Move_Checks
(Sub
)),
6394 Make_Attribute_Reference
(Loc
,
6395 Prefix
=> New_Occurrence_Of
(Etype
(A
), Loc
),
6396 Attribute_Name
=> Name_Range
)),
6397 Reason
=> CE_Index_Check_Failed
));
6404 A_Idx
: Node_Id
:= Empty
;
6411 A_Idx
:= First_Index
(Etype
(A
));
6413 while Present
(Sub
) loop
6414 if Do_Range_Check
(Sub
) then
6415 Set_Do_Range_Check
(Sub
, False);
6417 -- Force evaluation except for the case of a simple name of
6418 -- a non-volatile entity.
6420 if not Is_Entity_Name
(Sub
)
6421 or else Treat_As_Volatile
(Entity
(Sub
))
6423 Force_Evaluation
(Sub
);
6426 if Nkind
(A_Idx
) = N_Range
then
6429 elsif Nkind
(A_Idx
) = N_Identifier
6430 or else Nkind
(A_Idx
) = N_Expanded_Name
6432 A_Range
:= Scalar_Range
(Entity
(A_Idx
));
6434 else pragma Assert
(Nkind
(A_Idx
) = N_Subtype_Indication
);
6435 A_Range
:= Range_Expression
(Constraint
(A_Idx
));
6438 -- For array objects with constant bounds we can generate
6439 -- the index check using the bounds of the type of the index
6442 and then Ekind
(A_Ent
) = E_Variable
6443 and then Is_Constant_Bound
(Low_Bound
(A_Range
))
6444 and then Is_Constant_Bound
(High_Bound
(A_Range
))
6447 Make_Attribute_Reference
(Loc
,
6449 New_Occurrence_Of
(Etype
(A_Idx
), Loc
),
6450 Attribute_Name
=> Name_Range
);
6452 -- For arrays with non-constant bounds we cannot generate
6453 -- the index check using the bounds of the type of the index
6454 -- since it may reference discriminants of some enclosing
6455 -- type. We obtain the bounds directly from the prefix
6462 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
6466 Make_Attribute_Reference
(Loc
,
6468 Duplicate_Subexpr_Move_Checks
(A
, Name_Req
=> True),
6469 Attribute_Name
=> Name_Range
,
6470 Expressions
=> Num
);
6474 Make_Raise_Constraint_Error
(Loc
,
6478 Convert_To
(Base_Type
(Etype
(Sub
)),
6479 Duplicate_Subexpr_Move_Checks
(Sub
)),
6480 Right_Opnd
=> Range_N
),
6481 Reason
=> CE_Index_Check_Failed
));
6484 A_Idx
:= Next_Index
(A_Idx
);
6490 end Generate_Index_Checks
;
6492 --------------------------
6493 -- Generate_Range_Check --
6494 --------------------------
6496 procedure Generate_Range_Check
6498 Target_Type
: Entity_Id
;
6499 Reason
: RT_Exception_Code
)
6501 Loc
: constant Source_Ptr
:= Sloc
(N
);
6502 Source_Type
: constant Entity_Id
:= Etype
(N
);
6503 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
6504 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
6506 procedure Convert_And_Check_Range
;
6507 -- Convert the conversion operand to the target base type and save in
6508 -- a temporary. Then check the converted value against the range of the
6511 -----------------------------
6512 -- Convert_And_Check_Range --
6513 -----------------------------
6515 procedure Convert_And_Check_Range
is
6516 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
6519 -- We make a temporary to hold the value of the converted value
6520 -- (converted to the base type), and then do the test against this
6521 -- temporary. The conversion itself is replaced by an occurrence of
6522 -- Tnn and followed by the explicit range check. Note that checks
6523 -- are suppressed for this code, since we don't want a recursive
6524 -- range check popping up.
6526 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
6527 -- [constraint_error when Tnn not in Target_Type]
6529 Insert_Actions
(N
, New_List
(
6530 Make_Object_Declaration
(Loc
,
6531 Defining_Identifier
=> Tnn
,
6532 Object_Definition
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
6533 Constant_Present
=> True,
6535 Make_Type_Conversion
(Loc
,
6536 Subtype_Mark
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
6537 Expression
=> Duplicate_Subexpr
(N
))),
6539 Make_Raise_Constraint_Error
(Loc
,
6542 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
6543 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
6545 Suppress
=> All_Checks
);
6547 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
6549 -- Set the type of N, because the declaration for Tnn might not
6550 -- be analyzed yet, as is the case if N appears within a record
6551 -- declaration, as a discriminant constraint or expression.
6553 Set_Etype
(N
, Target_Base_Type
);
6554 end Convert_And_Check_Range
;
6556 -- Start of processing for Generate_Range_Check
6559 -- First special case, if the source type is already within the range
6560 -- of the target type, then no check is needed (probably we should have
6561 -- stopped Do_Range_Check from being set in the first place, but better
6562 -- late than never in preventing junk code and junk flag settings.
6564 if In_Subrange_Of
(Source_Type
, Target_Type
)
6566 -- We do NOT apply this if the source node is a literal, since in this
6567 -- case the literal has already been labeled as having the subtype of
6571 (Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
, N_Character_Literal
)
6574 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
6576 Set_Do_Range_Check
(N
, False);
6580 -- Here a check is needed. If the expander is not active, or if we are
6581 -- in GNATProve mode, then simply set the Do_Range_Check flag and we
6582 -- are done. In both these cases, we just want to see the range check
6583 -- flag set, we do not want to generate the explicit range check code.
6585 if GNATprove_Mode
or else not Expander_Active
then
6586 Set_Do_Range_Check
(N
, True);
6590 -- Here we will generate an explicit range check, so we don't want to
6591 -- set the Do_Range check flag, since the range check is taken care of
6592 -- by the code we will generate.
6594 Set_Do_Range_Check
(N
, False);
6596 -- Force evaluation of the node, so that it does not get evaluated twice
6597 -- (once for the check, once for the actual reference). Such a double
6598 -- evaluation is always a potential source of inefficiency, and is
6599 -- functionally incorrect in the volatile case.
6601 if not Is_Entity_Name
(N
) or else Treat_As_Volatile
(Entity
(N
)) then
6602 Force_Evaluation
(N
);
6605 -- The easiest case is when Source_Base_Type and Target_Base_Type are
6606 -- the same since in this case we can simply do a direct check of the
6607 -- value of N against the bounds of Target_Type.
6609 -- [constraint_error when N not in Target_Type]
6611 -- Note: this is by far the most common case, for example all cases of
6612 -- checks on the RHS of assignments are in this category, but not all
6613 -- cases are like this. Notably conversions can involve two types.
6615 if Source_Base_Type
= Target_Base_Type
then
6617 -- Insert the explicit range check. Note that we suppress checks for
6618 -- this code, since we don't want a recursive range check popping up.
6621 Make_Raise_Constraint_Error
(Loc
,
6624 Left_Opnd
=> Duplicate_Subexpr
(N
),
6625 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
6627 Suppress
=> All_Checks
);
6629 -- Next test for the case where the target type is within the bounds
6630 -- of the base type of the source type, since in this case we can
6631 -- simply convert these bounds to the base type of T to do the test.
6633 -- [constraint_error when N not in
6634 -- Source_Base_Type (Target_Type'First)
6636 -- Source_Base_Type(Target_Type'Last))]
6638 -- The conversions will always work and need no check
6640 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
6641 -- of converting from an enumeration value to an integer type, such as
6642 -- occurs for the case of generating a range check on Enum'Val(Exp)
6643 -- (which used to be handled by gigi). This is OK, since the conversion
6644 -- itself does not require a check.
6646 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
6648 -- Insert the explicit range check. Note that we suppress checks for
6649 -- this code, since we don't want a recursive range check popping up.
6651 if Is_Discrete_Type
(Source_Base_Type
)
6653 Is_Discrete_Type
(Target_Base_Type
)
6656 Make_Raise_Constraint_Error
(Loc
,
6659 Left_Opnd
=> Duplicate_Subexpr
(N
),
6664 Unchecked_Convert_To
(Source_Base_Type
,
6665 Make_Attribute_Reference
(Loc
,
6667 New_Occurrence_Of
(Target_Type
, Loc
),
6668 Attribute_Name
=> Name_First
)),
6671 Unchecked_Convert_To
(Source_Base_Type
,
6672 Make_Attribute_Reference
(Loc
,
6674 New_Occurrence_Of
(Target_Type
, Loc
),
6675 Attribute_Name
=> Name_Last
)))),
6677 Suppress
=> All_Checks
);
6679 -- For conversions involving at least one type that is not discrete,
6680 -- first convert to target type and then generate the range check.
6681 -- This avoids problems with values that are close to a bound of the
6682 -- target type that would fail a range check when done in a larger
6683 -- source type before converting but would pass if converted with
6684 -- rounding and then checked (such as in float-to-float conversions).
6687 Convert_And_Check_Range
;
6690 -- Note that at this stage we now that the Target_Base_Type is not in
6691 -- the range of the Source_Base_Type (since even the Target_Type itself
6692 -- is not in this range). It could still be the case that Source_Type is
6693 -- in range of the target base type since we have not checked that case.
6695 -- If that is the case, we can freely convert the source to the target,
6696 -- and then test the target result against the bounds.
6698 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
6699 Convert_And_Check_Range
;
6701 -- At this stage, we know that we have two scalar types, which are
6702 -- directly convertible, and where neither scalar type has a base
6703 -- range that is in the range of the other scalar type.
6705 -- The only way this can happen is with a signed and unsigned type.
6706 -- So test for these two cases:
6709 -- Case of the source is unsigned and the target is signed
6711 if Is_Unsigned_Type
(Source_Base_Type
)
6712 and then not Is_Unsigned_Type
(Target_Base_Type
)
6714 -- If the source is unsigned and the target is signed, then we
6715 -- know that the source is not shorter than the target (otherwise
6716 -- the source base type would be in the target base type range).
6718 -- In other words, the unsigned type is either the same size as
6719 -- the target, or it is larger. It cannot be smaller.
6722 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
6724 -- We only need to check the low bound if the low bound of the
6725 -- target type is non-negative. If the low bound of the target
6726 -- type is negative, then we know that we will fit fine.
6728 -- If the high bound of the target type is negative, then we
6729 -- know we have a constraint error, since we can't possibly
6730 -- have a negative source.
6732 -- With these two checks out of the way, we can do the check
6733 -- using the source type safely
6735 -- This is definitely the most annoying case.
6737 -- [constraint_error
6738 -- when (Target_Type'First >= 0
6740 -- N < Source_Base_Type (Target_Type'First))
6741 -- or else Target_Type'Last < 0
6742 -- or else N > Source_Base_Type (Target_Type'Last)];
6744 -- We turn off all checks since we know that the conversions
6745 -- will work fine, given the guards for negative values.
6748 Make_Raise_Constraint_Error
(Loc
,
6754 Left_Opnd
=> Make_Op_Ge
(Loc
,
6756 Make_Attribute_Reference
(Loc
,
6758 New_Occurrence_Of
(Target_Type
, Loc
),
6759 Attribute_Name
=> Name_First
),
6760 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
6764 Left_Opnd
=> Duplicate_Subexpr
(N
),
6766 Convert_To
(Source_Base_Type
,
6767 Make_Attribute_Reference
(Loc
,
6769 New_Occurrence_Of
(Target_Type
, Loc
),
6770 Attribute_Name
=> Name_First
)))),
6775 Make_Attribute_Reference
(Loc
,
6776 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
6777 Attribute_Name
=> Name_Last
),
6778 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
6782 Left_Opnd
=> Duplicate_Subexpr
(N
),
6784 Convert_To
(Source_Base_Type
,
6785 Make_Attribute_Reference
(Loc
,
6786 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
6787 Attribute_Name
=> Name_Last
)))),
6790 Suppress
=> All_Checks
);
6792 -- Only remaining possibility is that the source is signed and
6793 -- the target is unsigned.
6796 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
6797 and then Is_Unsigned_Type
(Target_Base_Type
));
6799 -- If the source is signed and the target is unsigned, then we
6800 -- know that the target is not shorter than the source (otherwise
6801 -- the target base type would be in the source base type range).
6803 -- In other words, the unsigned type is either the same size as
6804 -- the target, or it is larger. It cannot be smaller.
6806 -- Clearly we have an error if the source value is negative since
6807 -- no unsigned type can have negative values. If the source type
6808 -- is non-negative, then the check can be done using the target
6811 -- Tnn : constant Target_Base_Type (N) := Target_Type;
6813 -- [constraint_error
6814 -- when N < 0 or else Tnn not in Target_Type];
6816 -- We turn off all checks for the conversion of N to the target
6817 -- base type, since we generate the explicit check to ensure that
6818 -- the value is non-negative
6821 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
6824 Insert_Actions
(N
, New_List
(
6825 Make_Object_Declaration
(Loc
,
6826 Defining_Identifier
=> Tnn
,
6827 Object_Definition
=>
6828 New_Occurrence_Of
(Target_Base_Type
, Loc
),
6829 Constant_Present
=> True,
6831 Make_Unchecked_Type_Conversion
(Loc
,
6833 New_Occurrence_Of
(Target_Base_Type
, Loc
),
6834 Expression
=> Duplicate_Subexpr
(N
))),
6836 Make_Raise_Constraint_Error
(Loc
,
6841 Left_Opnd
=> Duplicate_Subexpr
(N
),
6842 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
6846 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
6848 New_Occurrence_Of
(Target_Type
, Loc
))),
6851 Suppress
=> All_Checks
);
6853 -- Set the Etype explicitly, because Insert_Actions may have
6854 -- placed the declaration in the freeze list for an enclosing
6855 -- construct, and thus it is not analyzed yet.
6857 Set_Etype
(Tnn
, Target_Base_Type
);
6858 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
6862 end Generate_Range_Check
;
6868 function Get_Check_Id
(N
: Name_Id
) return Check_Id
is
6870 -- For standard check name, we can do a direct computation
6872 if N
in First_Check_Name
.. Last_Check_Name
then
6873 return Check_Id
(N
- (First_Check_Name
- 1));
6875 -- For non-standard names added by pragma Check_Name, search table
6878 for J
in All_Checks
+ 1 .. Check_Names
.Last
loop
6879 if Check_Names
.Table
(J
) = N
then
6885 -- No matching name found
6890 ---------------------
6891 -- Get_Discriminal --
6892 ---------------------
6894 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
6895 Loc
: constant Source_Ptr
:= Sloc
(E
);
6900 -- The bound can be a bona fide parameter of a protected operation,
6901 -- rather than a prival encoded as an in-parameter.
6903 if No
(Discriminal_Link
(Entity
(Bound
))) then
6907 -- Climb the scope stack looking for an enclosing protected type. If
6908 -- we run out of scopes, return the bound itself.
6911 while Present
(Sc
) loop
6912 if Sc
= Standard_Standard
then
6914 elsif Ekind
(Sc
) = E_Protected_Type
then
6921 D
:= First_Discriminant
(Sc
);
6922 while Present
(D
) loop
6923 if Chars
(D
) = Chars
(Bound
) then
6924 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
6927 Next_Discriminant
(D
);
6931 end Get_Discriminal
;
6933 ----------------------
6934 -- Get_Range_Checks --
6935 ----------------------
6937 function Get_Range_Checks
6939 Target_Typ
: Entity_Id
;
6940 Source_Typ
: Entity_Id
:= Empty
;
6941 Warn_Node
: Node_Id
:= Empty
) return Check_Result
6945 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Warn_Node
);
6946 end Get_Range_Checks
;
6952 function Guard_Access
6955 Ck_Node
: Node_Id
) return Node_Id
6958 if Nkind
(Cond
) = N_Or_Else
then
6959 Set_Paren_Count
(Cond
, 1);
6962 if Nkind
(Ck_Node
) = N_Allocator
then
6970 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
6971 Right_Opnd
=> Make_Null
(Loc
)),
6972 Right_Opnd
=> Cond
);
6976 -----------------------------
6977 -- Index_Checks_Suppressed --
6978 -----------------------------
6980 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6982 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6983 return Is_Check_Suppressed
(E
, Index_Check
);
6985 return Scope_Suppress
.Suppress
(Index_Check
);
6987 end Index_Checks_Suppressed
;
6993 procedure Initialize
is
6995 for J
in Determine_Range_Cache_N
'Range loop
6996 Determine_Range_Cache_N
(J
) := Empty
;
7001 for J
in Int
range 1 .. All_Checks
loop
7002 Check_Names
.Append
(Name_Id
(Int
(First_Check_Name
) + J
- 1));
7006 -------------------------
7007 -- Insert_Range_Checks --
7008 -------------------------
7010 procedure Insert_Range_Checks
7011 (Checks
: Check_Result
;
7013 Suppress_Typ
: Entity_Id
;
7014 Static_Sloc
: Source_Ptr
:= No_Location
;
7015 Flag_Node
: Node_Id
:= Empty
;
7016 Do_Before
: Boolean := False)
7018 Internal_Flag_Node
: Node_Id
:= Flag_Node
;
7019 Internal_Static_Sloc
: Source_Ptr
:= Static_Sloc
;
7021 Check_Node
: Node_Id
;
7022 Checks_On
: constant Boolean :=
7023 (not Index_Checks_Suppressed
(Suppress_Typ
))
7024 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
7027 -- For now we just return if Checks_On is false, however this should be
7028 -- enhanced to check for an always True value in the condition and to
7029 -- generate a compilation warning???
7031 if not Expander_Active
or not Checks_On
then
7035 if Static_Sloc
= No_Location
then
7036 Internal_Static_Sloc
:= Sloc
(Node
);
7039 if No
(Flag_Node
) then
7040 Internal_Flag_Node
:= Node
;
7043 for J
in 1 .. 2 loop
7044 exit when No
(Checks
(J
));
7046 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
7047 and then Present
(Condition
(Checks
(J
)))
7049 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
7050 Check_Node
:= Checks
(J
);
7051 Mark_Rewrite_Insertion
(Check_Node
);
7054 Insert_Before_And_Analyze
(Node
, Check_Node
);
7056 Insert_After_And_Analyze
(Node
, Check_Node
);
7059 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
7064 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
7065 Reason
=> CE_Range_Check_Failed
);
7066 Mark_Rewrite_Insertion
(Check_Node
);
7069 Insert_Before_And_Analyze
(Node
, Check_Node
);
7071 Insert_After_And_Analyze
(Node
, Check_Node
);
7075 end Insert_Range_Checks
;
7077 ------------------------
7078 -- Insert_Valid_Check --
7079 ------------------------
7081 procedure Insert_Valid_Check
7083 Related_Id
: Entity_Id
:= Empty
;
7084 Is_Low_Bound
: Boolean := False;
7085 Is_High_Bound
: Boolean := False)
7087 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
7088 Typ
: constant Entity_Id
:= Etype
(Expr
);
7092 -- Do not insert if checks off, or if not checking validity or if
7093 -- expression is known to be valid.
7095 if not Validity_Checks_On
7096 or else Range_Or_Validity_Checks_Suppressed
(Expr
)
7097 or else Expr_Known_Valid
(Expr
)
7102 -- Do not insert checks within a predicate function. This will arise
7103 -- if the current unit and the predicate function are being compiled
7104 -- with validity checks enabled.
7106 if Present
(Predicate_Function
(Typ
))
7107 and then Current_Scope
= Predicate_Function
(Typ
)
7112 -- If the expression is a packed component of a modular type of the
7113 -- right size, the data is always valid.
7115 if Nkind
(Expr
) = N_Selected_Component
7116 and then Present
(Component_Clause
(Entity
(Selector_Name
(Expr
))))
7117 and then Is_Modular_Integer_Type
(Typ
)
7118 and then Modulus
(Typ
) = 2 ** Esize
(Entity
(Selector_Name
(Expr
)))
7123 -- If we have a checked conversion, then validity check applies to
7124 -- the expression inside the conversion, not the result, since if
7125 -- the expression inside is valid, then so is the conversion result.
7128 while Nkind
(Exp
) = N_Type_Conversion
loop
7129 Exp
:= Expression
(Exp
);
7132 -- We are about to insert the validity check for Exp. We save and
7133 -- reset the Do_Range_Check flag over this validity check, and then
7134 -- put it back for the final original reference (Exp may be rewritten).
7137 DRC
: constant Boolean := Do_Range_Check
(Exp
);
7142 Set_Do_Range_Check
(Exp
, False);
7144 -- Force evaluation to avoid multiple reads for atomic/volatile
7146 -- Note: we set Name_Req to False. We used to set it to True, with
7147 -- the thinking that a name is required as the prefix of the 'Valid
7148 -- call, but in fact the check that the prefix of an attribute is
7149 -- a name is in the parser, and we just don't require it here.
7150 -- Moreover, when we set Name_Req to True, that interfered with the
7151 -- checking for Volatile, since we couldn't just capture the value.
7153 if Is_Entity_Name
(Exp
)
7154 and then Is_Volatile
(Entity
(Exp
))
7156 -- Same reasoning as above for setting Name_Req to False
7158 Force_Evaluation
(Exp
, Name_Req
=> False);
7161 -- Build the prefix for the 'Valid call
7164 Duplicate_Subexpr_No_Checks
7167 Related_Id
=> Related_Id
,
7168 Is_Low_Bound
=> Is_Low_Bound
,
7169 Is_High_Bound
=> Is_High_Bound
);
7171 -- A rather specialized test. If PV is an analyzed expression which
7172 -- is an indexed component of a packed array that has not been
7173 -- properly expanded, turn off its Analyzed flag to make sure it
7174 -- gets properly reexpanded. If the prefix is an access value,
7175 -- the dereference will be added later.
7177 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
7178 -- an analyze with the old parent pointer. This may point e.g. to
7179 -- a subprogram call, which deactivates this expansion.
7182 and then Nkind
(PV
) = N_Indexed_Component
7183 and then Is_Array_Type
(Etype
(Prefix
(PV
)))
7184 and then Present
(Packed_Array_Impl_Type
(Etype
(Prefix
(PV
))))
7186 Set_Analyzed
(PV
, False);
7189 -- Build the raise CE node to check for validity. We build a type
7190 -- qualification for the prefix, since it may not be of the form of
7191 -- a name, and we don't care in this context!
7194 Make_Raise_Constraint_Error
(Loc
,
7198 Make_Attribute_Reference
(Loc
,
7200 Attribute_Name
=> Name_Valid
)),
7201 Reason
=> CE_Invalid_Data
);
7203 -- Insert the validity check. Note that we do this with validity
7204 -- checks turned off, to avoid recursion, we do not want validity
7205 -- checks on the validity checking code itself.
7207 Insert_Action
(Expr
, CE
, Suppress
=> Validity_Check
);
7209 -- If the expression is a reference to an element of a bit-packed
7210 -- array, then it is rewritten as a renaming declaration. If the
7211 -- expression is an actual in a call, it has not been expanded,
7212 -- waiting for the proper point at which to do it. The same happens
7213 -- with renamings, so that we have to force the expansion now. This
7214 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
7217 if Is_Entity_Name
(Exp
)
7218 and then Nkind
(Parent
(Entity
(Exp
))) =
7219 N_Object_Renaming_Declaration
7222 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
7224 if Nkind
(Old_Exp
) = N_Indexed_Component
7225 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
7227 Expand_Packed_Element_Reference
(Old_Exp
);
7232 -- Put back the Do_Range_Check flag on the resulting (possibly
7233 -- rewritten) expression.
7235 -- Note: it might be thought that a validity check is not required
7236 -- when a range check is present, but that's not the case, because
7237 -- the back end is allowed to assume for the range check that the
7238 -- operand is within its declared range (an assumption that validity
7239 -- checking is all about NOT assuming).
7241 -- Note: no need to worry about Possible_Local_Raise here, it will
7242 -- already have been called if original node has Do_Range_Check set.
7244 Set_Do_Range_Check
(Exp
, DRC
);
7246 end Insert_Valid_Check
;
7248 -------------------------------------
7249 -- Is_Signed_Integer_Arithmetic_Op --
7250 -------------------------------------
7252 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean is
7255 when N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
7256 N_Op_Minus | N_Op_Mod | N_Op_Multiply | N_Op_Plus |
7257 N_Op_Rem | N_Op_Subtract
=>
7258 return Is_Signed_Integer_Type
(Etype
(N
));
7260 when N_If_Expression | N_Case_Expression
=>
7261 return Is_Signed_Integer_Type
(Etype
(N
));
7266 end Is_Signed_Integer_Arithmetic_Op
;
7268 ----------------------------------
7269 -- Install_Null_Excluding_Check --
7270 ----------------------------------
7272 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
7273 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
7274 Typ
: constant Entity_Id
:= Etype
(N
);
7276 function Safe_To_Capture_In_Parameter_Value
return Boolean;
7277 -- Determines if it is safe to capture Known_Non_Null status for an
7278 -- the entity referenced by node N. The caller ensures that N is indeed
7279 -- an entity name. It is safe to capture the non-null status for an IN
7280 -- parameter when the reference occurs within a declaration that is sure
7281 -- to be executed as part of the declarative region.
7283 procedure Mark_Non_Null
;
7284 -- After installation of check, if the node in question is an entity
7285 -- name, then mark this entity as non-null if possible.
7287 function Safe_To_Capture_In_Parameter_Value
return Boolean is
7288 E
: constant Entity_Id
:= Entity
(N
);
7289 S
: constant Entity_Id
:= Current_Scope
;
7293 if Ekind
(E
) /= E_In_Parameter
then
7297 -- Two initial context checks. We must be inside a subprogram body
7298 -- with declarations and reference must not appear in nested scopes.
7300 if (Ekind
(S
) /= E_Function
and then Ekind
(S
) /= E_Procedure
)
7301 or else Scope
(E
) /= S
7306 S_Par
:= Parent
(Parent
(S
));
7308 if Nkind
(S_Par
) /= N_Subprogram_Body
7309 or else No
(Declarations
(S_Par
))
7319 -- Retrieve the declaration node of N (if any). Note that N
7320 -- may be a part of a complex initialization expression.
7324 while Present
(P
) loop
7326 -- If we have a short circuit form, and we are within the right
7327 -- hand expression, we return false, since the right hand side
7328 -- is not guaranteed to be elaborated.
7330 if Nkind
(P
) in N_Short_Circuit
7331 and then N
= Right_Opnd
(P
)
7336 -- Similarly, if we are in an if expression and not part of the
7337 -- condition, then we return False, since neither the THEN or
7338 -- ELSE dependent expressions will always be elaborated.
7340 if Nkind
(P
) = N_If_Expression
7341 and then N
/= First
(Expressions
(P
))
7346 -- If within a case expression, and not part of the expression,
7347 -- then return False, since a particular dependent expression
7348 -- may not always be elaborated
7350 if Nkind
(P
) = N_Case_Expression
7351 and then N
/= Expression
(P
)
7356 -- While traversing the parent chain, if node N belongs to a
7357 -- statement, then it may never appear in a declarative region.
7359 if Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
7360 or else Nkind
(P
) = N_Procedure_Call_Statement
7365 -- If we are at a declaration, record it and exit
7367 if Nkind
(P
) in N_Declaration
7368 and then Nkind
(P
) not in N_Subprogram_Specification
7381 return List_Containing
(N_Decl
) = Declarations
(S_Par
);
7383 end Safe_To_Capture_In_Parameter_Value
;
7389 procedure Mark_Non_Null
is
7391 -- Only case of interest is if node N is an entity name
7393 if Is_Entity_Name
(N
) then
7395 -- For sure, we want to clear an indication that this is known to
7396 -- be null, since if we get past this check, it definitely is not.
7398 Set_Is_Known_Null
(Entity
(N
), False);
7400 -- We can mark the entity as known to be non-null if either it is
7401 -- safe to capture the value, or in the case of an IN parameter,
7402 -- which is a constant, if the check we just installed is in the
7403 -- declarative region of the subprogram body. In this latter case,
7404 -- a check is decisive for the rest of the body if the expression
7405 -- is sure to be elaborated, since we know we have to elaborate
7406 -- all declarations before executing the body.
7408 -- Couldn't this always be part of Safe_To_Capture_Value ???
7410 if Safe_To_Capture_Value
(N
, Entity
(N
))
7411 or else Safe_To_Capture_In_Parameter_Value
7413 Set_Is_Known_Non_Null
(Entity
(N
));
7418 -- Start of processing for Install_Null_Excluding_Check
7421 pragma Assert
(Is_Access_Type
(Typ
));
7423 -- No check inside a generic, check will be emitted in instance
7425 if Inside_A_Generic
then
7429 -- No check needed if known to be non-null
7431 if Known_Non_Null
(N
) then
7435 -- If known to be null, here is where we generate a compile time check
7437 if Known_Null
(N
) then
7439 -- Avoid generating warning message inside init procs. In SPARK mode
7440 -- we can go ahead and call Apply_Compile_Time_Constraint_Error
7441 -- since it will be turned into an error in any case.
7443 if (not Inside_Init_Proc
or else SPARK_Mode
= On
)
7445 -- Do not emit the warning within a conditional expression,
7446 -- where the expression might not be evaluated, and the warning
7447 -- appear as extraneous noise.
7449 and then not Within_Case_Or_If_Expression
(N
)
7451 Apply_Compile_Time_Constraint_Error
7452 (N
, "null value not allowed here??", CE_Access_Check_Failed
);
7454 -- Remaining cases, where we silently insert the raise
7458 Make_Raise_Constraint_Error
(Loc
,
7459 Reason
=> CE_Access_Check_Failed
));
7466 -- If entity is never assigned, for sure a warning is appropriate
7468 if Is_Entity_Name
(N
) then
7469 Check_Unset_Reference
(N
);
7472 -- No check needed if checks are suppressed on the range. Note that we
7473 -- don't set Is_Known_Non_Null in this case (we could legitimately do
7474 -- so, since the program is erroneous, but we don't like to casually
7475 -- propagate such conclusions from erroneosity).
7477 if Access_Checks_Suppressed
(Typ
) then
7481 -- No check needed for access to concurrent record types generated by
7482 -- the expander. This is not just an optimization (though it does indeed
7483 -- remove junk checks). It also avoids generation of junk warnings.
7485 if Nkind
(N
) in N_Has_Chars
7486 and then Chars
(N
) = Name_uObject
7487 and then Is_Concurrent_Record_Type
7488 (Directly_Designated_Type
(Etype
(N
)))
7493 -- No check needed in interface thunks since the runtime check is
7494 -- already performed at the caller side.
7496 if Is_Thunk
(Current_Scope
) then
7500 -- No check needed for the Get_Current_Excep.all.all idiom generated by
7501 -- the expander within exception handlers, since we know that the value
7502 -- can never be null.
7504 -- Is this really the right way to do this? Normally we generate such
7505 -- code in the expander with checks off, and that's how we suppress this
7506 -- kind of junk check ???
7508 if Nkind
(N
) = N_Function_Call
7509 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
7510 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
7511 and then Is_RTE
(Entity
(Prefix
(Name
(N
))), RE_Get_Current_Excep
)
7516 -- Otherwise install access check
7519 Make_Raise_Constraint_Error
(Loc
,
7522 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
7523 Right_Opnd
=> Make_Null
(Loc
)),
7524 Reason
=> CE_Access_Check_Failed
));
7527 end Install_Null_Excluding_Check
;
7529 --------------------------
7530 -- Install_Static_Check --
7531 --------------------------
7533 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
7534 Stat
: constant Boolean := Is_OK_Static_Expression
(R_Cno
);
7535 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
7539 Make_Raise_Constraint_Error
(Loc
,
7540 Reason
=> CE_Range_Check_Failed
));
7541 Set_Analyzed
(R_Cno
);
7542 Set_Etype
(R_Cno
, Typ
);
7543 Set_Raises_Constraint_Error
(R_Cno
);
7544 Set_Is_Static_Expression
(R_Cno
, Stat
);
7546 -- Now deal with possible local raise handling
7548 Possible_Local_Raise
(R_Cno
, Standard_Constraint_Error
);
7549 end Install_Static_Check
;
7551 -------------------------
7552 -- Is_Check_Suppressed --
7553 -------------------------
7555 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
7556 Ptr
: Suppress_Stack_Entry_Ptr
;
7559 -- First search the local entity suppress stack. We search this from the
7560 -- top of the stack down so that we get the innermost entry that applies
7561 -- to this case if there are nested entries.
7563 Ptr
:= Local_Suppress_Stack_Top
;
7564 while Ptr
/= null loop
7565 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
7566 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
7568 return Ptr
.Suppress
;
7574 -- Now search the global entity suppress table for a matching entry.
7575 -- We also search this from the top down so that if there are multiple
7576 -- pragmas for the same entity, the last one applies (not clear what
7577 -- or whether the RM specifies this handling, but it seems reasonable).
7579 Ptr
:= Global_Suppress_Stack_Top
;
7580 while Ptr
/= null loop
7581 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
7582 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
7584 return Ptr
.Suppress
;
7590 -- If we did not find a matching entry, then use the normal scope
7591 -- suppress value after all (actually this will be the global setting
7592 -- since it clearly was not overridden at any point). For a predefined
7593 -- check, we test the specific flag. For a user defined check, we check
7594 -- the All_Checks flag. The Overflow flag requires special handling to
7595 -- deal with the General vs Assertion case
7597 if C
= Overflow_Check
then
7598 return Overflow_Checks_Suppressed
(Empty
);
7599 elsif C
in Predefined_Check_Id
then
7600 return Scope_Suppress
.Suppress
(C
);
7602 return Scope_Suppress
.Suppress
(All_Checks
);
7604 end Is_Check_Suppressed
;
7606 ---------------------
7607 -- Kill_All_Checks --
7608 ---------------------
7610 procedure Kill_All_Checks
is
7612 if Debug_Flag_CC
then
7613 w
("Kill_All_Checks");
7616 -- We reset the number of saved checks to zero, and also modify all
7617 -- stack entries for statement ranges to indicate that the number of
7618 -- checks at each level is now zero.
7620 Num_Saved_Checks
:= 0;
7622 -- Note: the Int'Min here avoids any possibility of J being out of
7623 -- range when called from e.g. Conditional_Statements_Begin.
7625 for J
in 1 .. Int
'Min (Saved_Checks_TOS
, Saved_Checks_Stack
'Last) loop
7626 Saved_Checks_Stack
(J
) := 0;
7628 end Kill_All_Checks
;
7634 procedure Kill_Checks
(V
: Entity_Id
) is
7636 if Debug_Flag_CC
then
7637 w
("Kill_Checks for entity", Int
(V
));
7640 for J
in 1 .. Num_Saved_Checks
loop
7641 if Saved_Checks
(J
).Entity
= V
then
7642 if Debug_Flag_CC
then
7643 w
(" Checks killed for saved check ", J
);
7646 Saved_Checks
(J
).Killed
:= True;
7651 ------------------------------
7652 -- Length_Checks_Suppressed --
7653 ------------------------------
7655 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7657 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7658 return Is_Check_Suppressed
(E
, Length_Check
);
7660 return Scope_Suppress
.Suppress
(Length_Check
);
7662 end Length_Checks_Suppressed
;
7664 -----------------------
7665 -- Make_Bignum_Block --
7666 -----------------------
7668 function Make_Bignum_Block
(Loc
: Source_Ptr
) return Node_Id
is
7669 M
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uM
);
7672 Make_Block_Statement
(Loc
,
7674 New_List
(Build_SS_Mark_Call
(Loc
, M
)),
7675 Handled_Statement_Sequence
=>
7676 Make_Handled_Sequence_Of_Statements
(Loc
,
7677 Statements
=> New_List
(Build_SS_Release_Call
(Loc
, M
))));
7678 end Make_Bignum_Block
;
7680 ----------------------------------
7681 -- Minimize_Eliminate_Overflows --
7682 ----------------------------------
7684 -- This is a recursive routine that is called at the top of an expression
7685 -- tree to properly process overflow checking for a whole subtree by making
7686 -- recursive calls to process operands. This processing may involve the use
7687 -- of bignum or long long integer arithmetic, which will change the types
7688 -- of operands and results. That's why we can't do this bottom up (since
7689 -- it would interfere with semantic analysis).
7691 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
7692 -- the operator expansion routines, as well as the expansion routines for
7693 -- if/case expression, do nothing (for the moment) except call the routine
7694 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
7695 -- routine does nothing for non top-level nodes, so at the point where the
7696 -- call is made for the top level node, the entire expression subtree has
7697 -- not been expanded, or processed for overflow. All that has to happen as
7698 -- a result of the top level call to this routine.
7700 -- As noted above, the overflow processing works by making recursive calls
7701 -- for the operands, and figuring out what to do, based on the processing
7702 -- of these operands (e.g. if a bignum operand appears, the parent op has
7703 -- to be done in bignum mode), and the determined ranges of the operands.
7705 -- After possible rewriting of a constituent subexpression node, a call is
7706 -- made to either reexpand the node (if nothing has changed) or reanalyze
7707 -- the node (if it has been modified by the overflow check processing). The
7708 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
7709 -- a recursive call into the whole overflow apparatus, an important rule
7710 -- for this call is that the overflow handling mode must be temporarily set
7713 procedure Minimize_Eliminate_Overflows
7717 Top_Level
: Boolean)
7719 Rtyp
: constant Entity_Id
:= Etype
(N
);
7720 pragma Assert
(Is_Signed_Integer_Type
(Rtyp
));
7721 -- Result type, must be a signed integer type
7723 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
7724 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
7726 Loc
: constant Source_Ptr
:= Sloc
(N
);
7729 -- Ranges of values for right operand (operator case)
7732 -- Ranges of values for left operand (operator case)
7734 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
7735 -- Operands and results are of this type when we convert
7737 LLLo
: constant Uint
:= Intval
(Type_Low_Bound
(LLIB
));
7738 LLHi
: constant Uint
:= Intval
(Type_High_Bound
(LLIB
));
7739 -- Bounds of Long_Long_Integer
7741 Binary
: constant Boolean := Nkind
(N
) in N_Binary_Op
;
7742 -- Indicates binary operator case
7745 -- Used in call to Determine_Range
7747 Bignum_Operands
: Boolean;
7748 -- Set True if one or more operands is already of type Bignum, meaning
7749 -- that for sure (regardless of Top_Level setting) we are committed to
7750 -- doing the operation in Bignum mode (or in the case of a case or if
7751 -- expression, converting all the dependent expressions to Bignum).
7753 Long_Long_Integer_Operands
: Boolean;
7754 -- Set True if one or more operands is already of type Long_Long_Integer
7755 -- which means that if the result is known to be in the result type
7756 -- range, then we must convert such operands back to the result type.
7758 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False);
7759 -- This is called when we have modified the node and we therefore need
7760 -- to reanalyze it. It is important that we reset the mode to STRICT for
7761 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
7762 -- we would reenter this routine recursively which would not be good.
7763 -- The argument Suppress is set True if we also want to suppress
7764 -- overflow checking for the reexpansion (this is set when we know
7765 -- overflow is not possible). Typ is the type for the reanalysis.
7767 procedure Reexpand
(Suppress
: Boolean := False);
7768 -- This is like Reanalyze, but does not do the Analyze step, it only
7769 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
7770 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
7771 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
7772 -- Note that skipping reanalysis is not just an optimization, testing
7773 -- has showed up several complex cases in which reanalyzing an already
7774 -- analyzed node causes incorrect behavior.
7776 function In_Result_Range
return Boolean;
7777 -- Returns True iff Lo .. Hi are within range of the result type
7779 procedure Max
(A
: in out Uint
; B
: Uint
);
7780 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
7782 procedure Min
(A
: in out Uint
; B
: Uint
);
7783 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
7785 ---------------------
7786 -- In_Result_Range --
7787 ---------------------
7789 function In_Result_Range
return Boolean is
7791 if Lo
= No_Uint
or else Hi
= No_Uint
then
7794 elsif Is_OK_Static_Subtype
(Etype
(N
)) then
7795 return Lo
>= Expr_Value
(Type_Low_Bound
(Rtyp
))
7797 Hi
<= Expr_Value
(Type_High_Bound
(Rtyp
));
7800 return Lo
>= Expr_Value
(Type_Low_Bound
(Base_Type
(Rtyp
)))
7802 Hi
<= Expr_Value
(Type_High_Bound
(Base_Type
(Rtyp
)));
7804 end In_Result_Range
;
7810 procedure Max
(A
: in out Uint
; B
: Uint
) is
7812 if A
= No_Uint
or else B
> A
then
7821 procedure Min
(A
: in out Uint
; B
: Uint
) is
7823 if A
= No_Uint
or else B
< A
then
7832 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False) is
7833 Svg
: constant Overflow_Mode_Type
:=
7834 Scope_Suppress
.Overflow_Mode_General
;
7835 Sva
: constant Overflow_Mode_Type
:=
7836 Scope_Suppress
.Overflow_Mode_Assertions
;
7837 Svo
: constant Boolean :=
7838 Scope_Suppress
.Suppress
(Overflow_Check
);
7841 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7842 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7845 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
7848 Analyze_And_Resolve
(N
, Typ
);
7850 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
7851 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
7852 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
7859 procedure Reexpand
(Suppress
: Boolean := False) is
7860 Svg
: constant Overflow_Mode_Type
:=
7861 Scope_Suppress
.Overflow_Mode_General
;
7862 Sva
: constant Overflow_Mode_Type
:=
7863 Scope_Suppress
.Overflow_Mode_Assertions
;
7864 Svo
: constant Boolean :=
7865 Scope_Suppress
.Suppress
(Overflow_Check
);
7868 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7869 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7870 Set_Analyzed
(N
, False);
7873 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
7878 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
7879 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
7880 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
7883 -- Start of processing for Minimize_Eliminate_Overflows
7886 -- Case where we do not have a signed integer arithmetic operation
7888 if not Is_Signed_Integer_Arithmetic_Op
(N
) then
7890 -- Use the normal Determine_Range routine to get the range. We
7891 -- don't require operands to be valid, invalid values may result in
7892 -- rubbish results where the result has not been properly checked for
7893 -- overflow, that's fine.
7895 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> False);
7897 -- If Determine_Range did not work (can this in fact happen? Not
7898 -- clear but might as well protect), use type bounds.
7901 Lo
:= Intval
(Type_Low_Bound
(Base_Type
(Etype
(N
))));
7902 Hi
:= Intval
(Type_High_Bound
(Base_Type
(Etype
(N
))));
7905 -- If we don't have a binary operator, all we have to do is to set
7906 -- the Hi/Lo range, so we are done.
7910 -- Processing for if expression
7912 elsif Nkind
(N
) = N_If_Expression
then
7914 Then_DE
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
7915 Else_DE
: constant Node_Id
:= Next
(Then_DE
);
7918 Bignum_Operands
:= False;
7920 Minimize_Eliminate_Overflows
7921 (Then_DE
, Lo
, Hi
, Top_Level
=> False);
7923 if Lo
= No_Uint
then
7924 Bignum_Operands
:= True;
7927 Minimize_Eliminate_Overflows
7928 (Else_DE
, Rlo
, Rhi
, Top_Level
=> False);
7930 if Rlo
= No_Uint
then
7931 Bignum_Operands
:= True;
7933 Long_Long_Integer_Operands
:=
7934 Etype
(Then_DE
) = LLIB
or else Etype
(Else_DE
) = LLIB
;
7940 -- If at least one of our operands is now Bignum, we must rebuild
7941 -- the if expression to use Bignum operands. We will analyze the
7942 -- rebuilt if expression with overflow checks off, since once we
7943 -- are in bignum mode, we are all done with overflow checks.
7945 if Bignum_Operands
then
7947 Make_If_Expression
(Loc
,
7948 Expressions
=> New_List
(
7949 Remove_Head
(Expressions
(N
)),
7950 Convert_To_Bignum
(Then_DE
),
7951 Convert_To_Bignum
(Else_DE
)),
7952 Is_Elsif
=> Is_Elsif
(N
)));
7954 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
7956 -- If we have no Long_Long_Integer operands, then we are in result
7957 -- range, since it means that none of our operands felt the need
7958 -- to worry about overflow (otherwise it would have already been
7959 -- converted to long long integer or bignum). We reexpand to
7960 -- complete the expansion of the if expression (but we do not
7961 -- need to reanalyze).
7963 elsif not Long_Long_Integer_Operands
then
7964 Set_Do_Overflow_Check
(N
, False);
7967 -- Otherwise convert us to long long integer mode. Note that we
7968 -- don't need any further overflow checking at this level.
7971 Convert_To_And_Rewrite
(LLIB
, Then_DE
);
7972 Convert_To_And_Rewrite
(LLIB
, Else_DE
);
7973 Set_Etype
(N
, LLIB
);
7975 -- Now reanalyze with overflow checks off
7977 Set_Do_Overflow_Check
(N
, False);
7978 Reanalyze
(LLIB
, Suppress
=> True);
7984 -- Here for case expression
7986 elsif Nkind
(N
) = N_Case_Expression
then
7987 Bignum_Operands
:= False;
7988 Long_Long_Integer_Operands
:= False;
7994 -- Loop through expressions applying recursive call
7996 Alt
:= First
(Alternatives
(N
));
7997 while Present
(Alt
) loop
7999 Aexp
: constant Node_Id
:= Expression
(Alt
);
8002 Minimize_Eliminate_Overflows
8003 (Aexp
, Lo
, Hi
, Top_Level
=> False);
8005 if Lo
= No_Uint
then
8006 Bignum_Operands
:= True;
8007 elsif Etype
(Aexp
) = LLIB
then
8008 Long_Long_Integer_Operands
:= True;
8015 -- If we have no bignum or long long integer operands, it means
8016 -- that none of our dependent expressions could raise overflow.
8017 -- In this case, we simply return with no changes except for
8018 -- resetting the overflow flag, since we are done with overflow
8019 -- checks for this node. We will reexpand to get the needed
8020 -- expansion for the case expression, but we do not need to
8021 -- reanalyze, since nothing has changed.
8023 if not (Bignum_Operands
or Long_Long_Integer_Operands
) then
8024 Set_Do_Overflow_Check
(N
, False);
8025 Reexpand
(Suppress
=> True);
8027 -- Otherwise we are going to rebuild the case expression using
8028 -- either bignum or long long integer operands throughout.
8037 New_Alts
:= New_List
;
8038 Alt
:= First
(Alternatives
(N
));
8039 while Present
(Alt
) loop
8040 if Bignum_Operands
then
8041 New_Exp
:= Convert_To_Bignum
(Expression
(Alt
));
8042 Rtype
:= RTE
(RE_Bignum
);
8044 New_Exp
:= Convert_To
(LLIB
, Expression
(Alt
));
8048 Append_To
(New_Alts
,
8049 Make_Case_Expression_Alternative
(Sloc
(Alt
),
8051 Discrete_Choices
=> Discrete_Choices
(Alt
),
8052 Expression
=> New_Exp
));
8058 Make_Case_Expression
(Loc
,
8059 Expression
=> Expression
(N
),
8060 Alternatives
=> New_Alts
));
8062 Reanalyze
(Rtype
, Suppress
=> True);
8070 -- If we have an arithmetic operator we make recursive calls on the
8071 -- operands to get the ranges (and to properly process the subtree
8072 -- that lies below us).
8074 Minimize_Eliminate_Overflows
8075 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
8078 Minimize_Eliminate_Overflows
8079 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
8082 -- Record if we have Long_Long_Integer operands
8084 Long_Long_Integer_Operands
:=
8085 Etype
(Right_Opnd
(N
)) = LLIB
8086 or else (Binary
and then Etype
(Left_Opnd
(N
)) = LLIB
);
8088 -- If either operand is a bignum, then result will be a bignum and we
8089 -- don't need to do any range analysis. As previously discussed we could
8090 -- do range analysis in such cases, but it could mean working with giant
8091 -- numbers at compile time for very little gain (the number of cases
8092 -- in which we could slip back from bignum mode is small).
8094 if Rlo
= No_Uint
or else (Binary
and then Llo
= No_Uint
) then
8097 Bignum_Operands
:= True;
8099 -- Otherwise compute result range
8102 Bignum_Operands
:= False;
8110 Hi
:= UI_Max
(abs Rlo
, abs Rhi
);
8122 -- If the right operand can only be zero, set 0..0
8124 if Rlo
= 0 and then Rhi
= 0 then
8128 -- Possible bounds of division must come from dividing end
8129 -- values of the input ranges (four possibilities), provided
8130 -- zero is not included in the possible values of the right
8133 -- Otherwise, we just consider two intervals of values for
8134 -- the right operand: the interval of negative values (up to
8135 -- -1) and the interval of positive values (starting at 1).
8136 -- Since division by 1 is the identity, and division by -1
8137 -- is negation, we get all possible bounds of division in that
8138 -- case by considering:
8139 -- - all values from the division of end values of input
8141 -- - the end values of the left operand;
8142 -- - the negation of the end values of the left operand.
8146 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
8147 -- Mark so we can release the RR and Ev values
8155 -- Discard extreme values of zero for the divisor, since
8156 -- they will simply result in an exception in any case.
8164 -- Compute possible bounds coming from dividing end
8165 -- values of the input ranges.
8172 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
8173 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
8175 -- If the right operand can be both negative or positive,
8176 -- include the end values of the left operand in the
8177 -- extreme values, as well as their negation.
8179 if Rlo
< 0 and then Rhi
> 0 then
8186 UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
)));
8188 UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
)));
8191 -- Release the RR and Ev values
8193 Release_And_Save
(Mrk
, Lo
, Hi
);
8201 -- Discard negative values for the exponent, since they will
8202 -- simply result in an exception in any case.
8210 -- Estimate number of bits in result before we go computing
8211 -- giant useless bounds. Basically the number of bits in the
8212 -- result is the number of bits in the base multiplied by the
8213 -- value of the exponent. If this is big enough that the result
8214 -- definitely won't fit in Long_Long_Integer, switch to bignum
8215 -- mode immediately, and avoid computing giant bounds.
8217 -- The comparison here is approximate, but conservative, it
8218 -- only clicks on cases that are sure to exceed the bounds.
8220 if Num_Bits
(UI_Max
(abs Llo
, abs Lhi
)) * Rhi
+ 1 > 100 then
8224 -- If right operand is zero then result is 1
8231 -- High bound comes either from exponentiation of largest
8232 -- positive value to largest exponent value, or from
8233 -- the exponentiation of most negative value to an
8247 if Rhi
mod 2 = 0 then
8250 Hi2
:= Llo
** (Rhi
- 1);
8256 Hi
:= UI_Max
(Hi1
, Hi2
);
8259 -- Result can only be negative if base can be negative
8262 if Rhi
mod 2 = 0 then
8263 Lo
:= Llo
** (Rhi
- 1);
8268 -- Otherwise low bound is minimum ** minimum
8285 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
8286 -- This is the maximum absolute value of the result
8292 -- The result depends only on the sign and magnitude of
8293 -- the right operand, it does not depend on the sign or
8294 -- magnitude of the left operand.
8307 when N_Op_Multiply
=>
8309 -- Possible bounds of multiplication must come from multiplying
8310 -- end values of the input ranges (four possibilities).
8313 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
8314 -- Mark so we can release the Ev values
8316 Ev1
: constant Uint
:= Llo
* Rlo
;
8317 Ev2
: constant Uint
:= Llo
* Rhi
;
8318 Ev3
: constant Uint
:= Lhi
* Rlo
;
8319 Ev4
: constant Uint
:= Lhi
* Rhi
;
8322 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
8323 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
8325 -- Release the Ev values
8327 Release_And_Save
(Mrk
, Lo
, Hi
);
8330 -- Plus operator (affirmation)
8340 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
8341 -- This is the maximum absolute value of the result. Note
8342 -- that the result range does not depend on the sign of the
8349 -- Case of left operand negative, which results in a range
8350 -- of -Maxabs .. 0 for those negative values. If there are
8351 -- no negative values then Lo value of result is always 0.
8357 -- Case of left operand positive
8366 when N_Op_Subtract
=>
8370 -- Nothing else should be possible
8373 raise Program_Error
;
8377 -- Here for the case where we have not rewritten anything (no bignum
8378 -- operands or long long integer operands), and we know the result.
8379 -- If we know we are in the result range, and we do not have Bignum
8380 -- operands or Long_Long_Integer operands, we can just reexpand with
8381 -- overflow checks turned off (since we know we cannot have overflow).
8382 -- As always the reexpansion is required to complete expansion of the
8383 -- operator, but we do not need to reanalyze, and we prevent recursion
8384 -- by suppressing the check.
8386 if not (Bignum_Operands
or Long_Long_Integer_Operands
)
8387 and then In_Result_Range
8389 Set_Do_Overflow_Check
(N
, False);
8390 Reexpand
(Suppress
=> True);
8393 -- Here we know that we are not in the result range, and in the general
8394 -- case we will move into either the Bignum or Long_Long_Integer domain
8395 -- to compute the result. However, there is one exception. If we are
8396 -- at the top level, and we do not have Bignum or Long_Long_Integer
8397 -- operands, we will have to immediately convert the result back to
8398 -- the result type, so there is no point in Bignum/Long_Long_Integer
8402 and then not (Bignum_Operands
or Long_Long_Integer_Operands
)
8404 -- One further refinement. If we are at the top level, but our parent
8405 -- is a type conversion, then go into bignum or long long integer node
8406 -- since the result will be converted to that type directly without
8407 -- going through the result type, and we may avoid an overflow. This
8408 -- is the case for example of Long_Long_Integer (A ** 4), where A is
8409 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
8410 -- but does not fit in Integer.
8412 and then Nkind
(Parent
(N
)) /= N_Type_Conversion
8414 -- Here keep original types, but we need to complete analysis
8416 -- One subtlety. We can't just go ahead and do an analyze operation
8417 -- here because it will cause recursion into the whole MINIMIZED/
8418 -- ELIMINATED overflow processing which is not what we want. Here
8419 -- we are at the top level, and we need a check against the result
8420 -- mode (i.e. we want to use STRICT mode). So do exactly that.
8421 -- Also, we have not modified the node, so this is a case where
8422 -- we need to reexpand, but not reanalyze.
8427 -- Cases where we do the operation in Bignum mode. This happens either
8428 -- because one of our operands is in Bignum mode already, or because
8429 -- the computed bounds are outside the bounds of Long_Long_Integer,
8430 -- which in some cases can be indicated by Hi and Lo being No_Uint.
8432 -- Note: we could do better here and in some cases switch back from
8433 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
8434 -- 0 .. 1, but the cases are rare and it is not worth the effort.
8435 -- Failing to do this switching back is only an efficiency issue.
8437 elsif Lo
= No_Uint
or else Lo
< LLLo
or else Hi
> LLHi
then
8439 -- OK, we are definitely outside the range of Long_Long_Integer. The
8440 -- question is whether to move to Bignum mode, or stay in the domain
8441 -- of Long_Long_Integer, signalling that an overflow check is needed.
8443 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
8444 -- the Bignum business. In ELIMINATED mode, we will normally move
8445 -- into Bignum mode, but there is an exception if neither of our
8446 -- operands is Bignum now, and we are at the top level (Top_Level
8447 -- set True). In this case, there is no point in moving into Bignum
8448 -- mode to prevent overflow if the caller will immediately convert
8449 -- the Bignum value back to LLI with an overflow check. It's more
8450 -- efficient to stay in LLI mode with an overflow check (if needed)
8452 if Check_Mode
= Minimized
8453 or else (Top_Level
and not Bignum_Operands
)
8455 if Do_Overflow_Check
(N
) then
8456 Enable_Overflow_Check
(N
);
8459 -- The result now has to be in Long_Long_Integer mode, so adjust
8460 -- the possible range to reflect this. Note these calls also
8461 -- change No_Uint values from the top level case to LLI bounds.
8466 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
8469 pragma Assert
(Check_Mode
= Eliminated
);
8478 Fent
:= RTE
(RE_Big_Abs
);
8481 Fent
:= RTE
(RE_Big_Add
);
8484 Fent
:= RTE
(RE_Big_Div
);
8487 Fent
:= RTE
(RE_Big_Exp
);
8490 Fent
:= RTE
(RE_Big_Neg
);
8493 Fent
:= RTE
(RE_Big_Mod
);
8495 when N_Op_Multiply
=>
8496 Fent
:= RTE
(RE_Big_Mul
);
8499 Fent
:= RTE
(RE_Big_Rem
);
8501 when N_Op_Subtract
=>
8502 Fent
:= RTE
(RE_Big_Sub
);
8504 -- Anything else is an internal error, this includes the
8505 -- N_Op_Plus case, since how can plus cause the result
8506 -- to be out of range if the operand is in range?
8509 raise Program_Error
;
8512 -- Construct argument list for Bignum call, converting our
8513 -- operands to Bignum form if they are not already there.
8518 Append_To
(Args
, Convert_To_Bignum
(Left_Opnd
(N
)));
8521 Append_To
(Args
, Convert_To_Bignum
(Right_Opnd
(N
)));
8523 -- Now rewrite the arithmetic operator with a call to the
8524 -- corresponding bignum function.
8527 Make_Function_Call
(Loc
,
8528 Name
=> New_Occurrence_Of
(Fent
, Loc
),
8529 Parameter_Associations
=> Args
));
8530 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
8532 -- Indicate result is Bignum mode
8540 -- Otherwise we are in range of Long_Long_Integer, so no overflow
8541 -- check is required, at least not yet.
8544 Set_Do_Overflow_Check
(N
, False);
8547 -- Here we are not in Bignum territory, but we may have long long
8548 -- integer operands that need special handling. First a special check:
8549 -- If an exponentiation operator exponent is of type Long_Long_Integer,
8550 -- it means we converted it to prevent overflow, but exponentiation
8551 -- requires a Natural right operand, so convert it back to Natural.
8552 -- This conversion may raise an exception which is fine.
8554 if Nkind
(N
) = N_Op_Expon
and then Etype
(Right_Opnd
(N
)) = LLIB
then
8555 Convert_To_And_Rewrite
(Standard_Natural
, Right_Opnd
(N
));
8558 -- Here we will do the operation in Long_Long_Integer. We do this even
8559 -- if we know an overflow check is required, better to do this in long
8560 -- long integer mode, since we are less likely to overflow.
8562 -- Convert right or only operand to Long_Long_Integer, except that
8563 -- we do not touch the exponentiation right operand.
8565 if Nkind
(N
) /= N_Op_Expon
then
8566 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
8569 -- Convert left operand to Long_Long_Integer for binary case
8572 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
8575 -- Reset node to unanalyzed
8577 Set_Analyzed
(N
, False);
8578 Set_Etype
(N
, Empty
);
8579 Set_Entity
(N
, Empty
);
8581 -- Now analyze this new node. This reanalysis will complete processing
8582 -- for the node. In particular we will complete the expansion of an
8583 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
8584 -- we will complete any division checks (since we have not changed the
8585 -- setting of the Do_Division_Check flag).
8587 -- We do this reanalysis in STRICT mode to avoid recursion into the
8588 -- MINIMIZED/ELIMINATED handling, since we are now done with that.
8591 SG
: constant Overflow_Mode_Type
:=
8592 Scope_Suppress
.Overflow_Mode_General
;
8593 SA
: constant Overflow_Mode_Type
:=
8594 Scope_Suppress
.Overflow_Mode_Assertions
;
8597 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
8598 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
8600 if not Do_Overflow_Check
(N
) then
8601 Reanalyze
(LLIB
, Suppress
=> True);
8606 Scope_Suppress
.Overflow_Mode_General
:= SG
;
8607 Scope_Suppress
.Overflow_Mode_Assertions
:= SA
;
8609 end Minimize_Eliminate_Overflows
;
8611 -------------------------
8612 -- Overflow_Check_Mode --
8613 -------------------------
8615 function Overflow_Check_Mode
return Overflow_Mode_Type
is
8617 if In_Assertion_Expr
= 0 then
8618 return Scope_Suppress
.Overflow_Mode_General
;
8620 return Scope_Suppress
.Overflow_Mode_Assertions
;
8622 end Overflow_Check_Mode
;
8624 --------------------------------
8625 -- Overflow_Checks_Suppressed --
8626 --------------------------------
8628 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
8630 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
8631 return Is_Check_Suppressed
(E
, Overflow_Check
);
8633 return Scope_Suppress
.Suppress
(Overflow_Check
);
8635 end Overflow_Checks_Suppressed
;
8637 ---------------------------------
8638 -- Predicate_Checks_Suppressed --
8639 ---------------------------------
8641 function Predicate_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
8643 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
8644 return Is_Check_Suppressed
(E
, Predicate_Check
);
8646 return Scope_Suppress
.Suppress
(Predicate_Check
);
8648 end Predicate_Checks_Suppressed
;
8650 -----------------------------
8651 -- Range_Checks_Suppressed --
8652 -----------------------------
8654 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
8657 if Kill_Range_Checks
(E
) then
8660 elsif Checks_May_Be_Suppressed
(E
) then
8661 return Is_Check_Suppressed
(E
, Range_Check
);
8665 return Scope_Suppress
.Suppress
(Range_Check
);
8666 end Range_Checks_Suppressed
;
8668 -----------------------------------------
8669 -- Range_Or_Validity_Checks_Suppressed --
8670 -----------------------------------------
8672 -- Note: the coding would be simpler here if we simply made appropriate
8673 -- calls to Range/Validity_Checks_Suppressed, but that would result in
8674 -- duplicated checks which we prefer to avoid.
8676 function Range_Or_Validity_Checks_Suppressed
8677 (Expr
: Node_Id
) return Boolean
8680 -- Immediate return if scope checks suppressed for either check
8682 if Scope_Suppress
.Suppress
(Range_Check
)
8684 Scope_Suppress
.Suppress
(Validity_Check
)
8689 -- If no expression, that's odd, decide that checks are suppressed,
8690 -- since we don't want anyone trying to do checks in this case, which
8691 -- is most likely the result of some other error.
8697 -- Expression is present, so perform suppress checks on type
8700 Typ
: constant Entity_Id
:= Etype
(Expr
);
8702 if Checks_May_Be_Suppressed
(Typ
)
8703 and then (Is_Check_Suppressed
(Typ
, Range_Check
)
8705 Is_Check_Suppressed
(Typ
, Validity_Check
))
8711 -- If expression is an entity name, perform checks on this entity
8713 if Is_Entity_Name
(Expr
) then
8715 Ent
: constant Entity_Id
:= Entity
(Expr
);
8717 if Checks_May_Be_Suppressed
(Ent
) then
8718 return Is_Check_Suppressed
(Ent
, Range_Check
)
8719 or else Is_Check_Suppressed
(Ent
, Validity_Check
);
8724 -- If we fall through, no checks suppressed
8727 end Range_Or_Validity_Checks_Suppressed
;
8733 procedure Remove_Checks
(Expr
: Node_Id
) is
8734 function Process
(N
: Node_Id
) return Traverse_Result
;
8735 -- Process a single node during the traversal
8737 procedure Traverse
is new Traverse_Proc
(Process
);
8738 -- The traversal procedure itself
8744 function Process
(N
: Node_Id
) return Traverse_Result
is
8746 if Nkind
(N
) not in N_Subexpr
then
8750 Set_Do_Range_Check
(N
, False);
8754 Traverse
(Left_Opnd
(N
));
8757 when N_Attribute_Reference
=>
8758 Set_Do_Overflow_Check
(N
, False);
8760 when N_Function_Call
=>
8761 Set_Do_Tag_Check
(N
, False);
8764 Set_Do_Overflow_Check
(N
, False);
8768 Set_Do_Division_Check
(N
, False);
8771 Set_Do_Length_Check
(N
, False);
8774 Set_Do_Division_Check
(N
, False);
8777 Set_Do_Length_Check
(N
, False);
8780 Set_Do_Division_Check
(N
, False);
8783 Set_Do_Length_Check
(N
, False);
8790 Traverse
(Left_Opnd
(N
));
8793 when N_Selected_Component
=>
8794 Set_Do_Discriminant_Check
(N
, False);
8796 when N_Type_Conversion
=>
8797 Set_Do_Length_Check
(N
, False);
8798 Set_Do_Tag_Check
(N
, False);
8799 Set_Do_Overflow_Check
(N
, False);
8808 -- Start of processing for Remove_Checks
8814 ----------------------------
8815 -- Selected_Length_Checks --
8816 ----------------------------
8818 function Selected_Length_Checks
8820 Target_Typ
: Entity_Id
;
8821 Source_Typ
: Entity_Id
;
8822 Warn_Node
: Node_Id
) return Check_Result
8824 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
8827 Expr_Actual
: Node_Id
;
8829 Cond
: Node_Id
:= Empty
;
8830 Do_Access
: Boolean := False;
8831 Wnode
: Node_Id
:= Warn_Node
;
8832 Ret_Result
: Check_Result
:= (Empty
, Empty
);
8833 Num_Checks
: Natural := 0;
8835 procedure Add_Check
(N
: Node_Id
);
8836 -- Adds the action given to Ret_Result if N is non-Empty
8838 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
8839 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8840 -- Comments required ???
8842 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
8843 -- True for equal literals and for nodes that denote the same constant
8844 -- entity, even if its value is not a static constant. This includes the
8845 -- case of a discriminal reference within an init proc. Removes some
8846 -- obviously superfluous checks.
8848 function Length_E_Cond
8849 (Exptyp
: Entity_Id
;
8851 Indx
: Nat
) return Node_Id
;
8852 -- Returns expression to compute:
8853 -- Typ'Length /= Exptyp'Length
8855 function Length_N_Cond
8858 Indx
: Nat
) return Node_Id
;
8859 -- Returns expression to compute:
8860 -- Typ'Length /= Expr'Length
8866 procedure Add_Check
(N
: Node_Id
) is
8870 -- For now, ignore attempt to place more than two checks ???
8871 -- This is really worrisome, are we really discarding checks ???
8873 if Num_Checks
= 2 then
8877 pragma Assert
(Num_Checks
<= 1);
8878 Num_Checks
:= Num_Checks
+ 1;
8879 Ret_Result
(Num_Checks
) := N
;
8887 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
8888 SE
: constant Entity_Id
:= Scope
(E
);
8890 E1
: Entity_Id
:= E
;
8893 if Ekind
(Scope
(E
)) = E_Record_Type
8894 and then Has_Discriminants
(Scope
(E
))
8896 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
8899 Insert_Action
(Ck_Node
, N
);
8900 E1
:= Defining_Identifier
(N
);
8904 if Ekind
(E1
) = E_String_Literal_Subtype
then
8906 Make_Integer_Literal
(Loc
,
8907 Intval
=> String_Literal_Length
(E1
));
8909 elsif SE
/= Standard_Standard
8910 and then Ekind
(Scope
(SE
)) = E_Protected_Type
8911 and then Has_Discriminants
(Scope
(SE
))
8912 and then Has_Completion
(Scope
(SE
))
8913 and then not Inside_Init_Proc
8915 -- If the type whose length is needed is a private component
8916 -- constrained by a discriminant, we must expand the 'Length
8917 -- attribute into an explicit computation, using the discriminal
8918 -- of the current protected operation. This is because the actual
8919 -- type of the prival is constructed after the protected opera-
8920 -- tion has been fully expanded.
8923 Indx_Type
: Node_Id
;
8926 Do_Expand
: Boolean := False;
8929 Indx_Type
:= First_Index
(E
);
8931 for J
in 1 .. Indx
- 1 loop
8932 Next_Index
(Indx_Type
);
8935 Get_Index_Bounds
(Indx_Type
, Lo
, Hi
);
8937 if Nkind
(Lo
) = N_Identifier
8938 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
8940 Lo
:= Get_Discriminal
(E
, Lo
);
8944 if Nkind
(Hi
) = N_Identifier
8945 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
8947 Hi
:= Get_Discriminal
(E
, Hi
);
8952 if not Is_Entity_Name
(Lo
) then
8953 Lo
:= Duplicate_Subexpr_No_Checks
(Lo
);
8956 if not Is_Entity_Name
(Hi
) then
8957 Lo
:= Duplicate_Subexpr_No_Checks
(Hi
);
8963 Make_Op_Subtract
(Loc
,
8967 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
8972 Make_Attribute_Reference
(Loc
,
8973 Attribute_Name
=> Name_Length
,
8975 New_Occurrence_Of
(E1
, Loc
));
8978 Set_Expressions
(N
, New_List
(
8979 Make_Integer_Literal
(Loc
, Indx
)));
8988 Make_Attribute_Reference
(Loc
,
8989 Attribute_Name
=> Name_Length
,
8991 New_Occurrence_Of
(E1
, Loc
));
8994 Set_Expressions
(N
, New_List
(
8995 Make_Integer_Literal
(Loc
, Indx
)));
9006 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
9009 Make_Attribute_Reference
(Loc
,
9010 Attribute_Name
=> Name_Length
,
9012 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
9013 Expressions
=> New_List
(
9014 Make_Integer_Literal
(Loc
, Indx
)));
9021 function Length_E_Cond
9022 (Exptyp
: Entity_Id
;
9024 Indx
: Nat
) return Node_Id
9029 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
9030 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
9037 function Length_N_Cond
9040 Indx
: Nat
) return Node_Id
9045 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
9046 Right_Opnd
=> Get_N_Length
(Expr
, Indx
));
9053 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
9056 (Nkind
(L
) = N_Integer_Literal
9057 and then Nkind
(R
) = N_Integer_Literal
9058 and then Intval
(L
) = Intval
(R
))
9062 and then Ekind
(Entity
(L
)) = E_Constant
9063 and then ((Is_Entity_Name
(R
)
9064 and then Entity
(L
) = Entity
(R
))
9066 (Nkind
(R
) = N_Type_Conversion
9067 and then Is_Entity_Name
(Expression
(R
))
9068 and then Entity
(L
) = Entity
(Expression
(R
)))))
9072 and then Ekind
(Entity
(R
)) = E_Constant
9073 and then Nkind
(L
) = N_Type_Conversion
9074 and then Is_Entity_Name
(Expression
(L
))
9075 and then Entity
(R
) = Entity
(Expression
(L
)))
9079 and then Is_Entity_Name
(R
)
9080 and then Entity
(L
) = Entity
(R
)
9081 and then Ekind
(Entity
(L
)) = E_In_Parameter
9082 and then Inside_Init_Proc
);
9085 -- Start of processing for Selected_Length_Checks
9088 if not Expander_Active
then
9092 if Target_Typ
= Any_Type
9093 or else Target_Typ
= Any_Composite
9094 or else Raises_Constraint_Error
(Ck_Node
)
9103 T_Typ
:= Target_Typ
;
9105 if No
(Source_Typ
) then
9106 S_Typ
:= Etype
(Ck_Node
);
9108 S_Typ
:= Source_Typ
;
9111 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
9115 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
9116 S_Typ
:= Designated_Type
(S_Typ
);
9117 T_Typ
:= Designated_Type
(T_Typ
);
9120 -- A simple optimization for the null case
9122 if Known_Null
(Ck_Node
) then
9127 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
9128 if Is_Constrained
(T_Typ
) then
9130 -- The checking code to be generated will freeze the corresponding
9131 -- array type. However, we must freeze the type now, so that the
9132 -- freeze node does not appear within the generated if expression,
9135 Freeze_Before
(Ck_Node
, T_Typ
);
9137 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
9138 Exptyp
:= Get_Actual_Subtype
(Ck_Node
);
9140 if Is_Access_Type
(Exptyp
) then
9141 Exptyp
:= Designated_Type
(Exptyp
);
9144 -- String_Literal case. This needs to be handled specially be-
9145 -- cause no index types are available for string literals. The
9146 -- condition is simply:
9148 -- T_Typ'Length = string-literal-length
9150 if Nkind
(Expr_Actual
) = N_String_Literal
9151 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
9155 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
9157 Make_Integer_Literal
(Loc
,
9159 String_Literal_Length
(Etype
(Expr_Actual
))));
9161 -- General array case. Here we have a usable actual subtype for
9162 -- the expression, and the condition is built from the two types
9165 -- T_Typ'Length /= Exptyp'Length or else
9166 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
9167 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
9170 elsif Is_Constrained
(Exptyp
) then
9172 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9185 -- At the library level, we need to ensure that the type of
9186 -- the object is elaborated before the check itself is
9187 -- emitted. This is only done if the object is in the
9188 -- current compilation unit, otherwise the type is frozen
9189 -- and elaborated in its unit.
9191 if Is_Itype
(Exptyp
)
9193 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
9195 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
9196 and then In_Open_Scopes
(Scope
(Exptyp
))
9198 Ref_Node
:= Make_Itype_Reference
(Sloc
(Ck_Node
));
9199 Set_Itype
(Ref_Node
, Exptyp
);
9200 Insert_Action
(Ck_Node
, Ref_Node
);
9203 L_Index
:= First_Index
(T_Typ
);
9204 R_Index
:= First_Index
(Exptyp
);
9206 for Indx
in 1 .. Ndims
loop
9207 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
9209 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
9211 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
9212 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
9214 -- Deal with compile time length check. Note that we
9215 -- skip this in the access case, because the access
9216 -- value may be null, so we cannot know statically.
9219 and then Compile_Time_Known_Value
(L_Low
)
9220 and then Compile_Time_Known_Value
(L_High
)
9221 and then Compile_Time_Known_Value
(R_Low
)
9222 and then Compile_Time_Known_Value
(R_High
)
9224 if Expr_Value
(L_High
) >= Expr_Value
(L_Low
) then
9225 L_Length
:= Expr_Value
(L_High
) -
9226 Expr_Value
(L_Low
) + 1;
9228 L_Length
:= UI_From_Int
(0);
9231 if Expr_Value
(R_High
) >= Expr_Value
(R_Low
) then
9232 R_Length
:= Expr_Value
(R_High
) -
9233 Expr_Value
(R_Low
) + 1;
9235 R_Length
:= UI_From_Int
(0);
9238 if L_Length
> R_Length
then
9240 (Compile_Time_Constraint_Error
9241 (Wnode
, "too few elements for}??", T_Typ
));
9243 elsif L_Length
< R_Length
then
9245 (Compile_Time_Constraint_Error
9246 (Wnode
, "too many elements for}??", T_Typ
));
9249 -- The comparison for an individual index subtype
9250 -- is omitted if the corresponding index subtypes
9251 -- statically match, since the result is known to
9252 -- be true. Note that this test is worth while even
9253 -- though we do static evaluation, because non-static
9254 -- subtypes can statically match.
9257 Subtypes_Statically_Match
9258 (Etype
(L_Index
), Etype
(R_Index
))
9261 (Same_Bounds
(L_Low
, R_Low
)
9262 and then Same_Bounds
(L_High
, R_High
))
9265 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
9274 -- Handle cases where we do not get a usable actual subtype that
9275 -- is constrained. This happens for example in the function call
9276 -- and explicit dereference cases. In these cases, we have to get
9277 -- the length or range from the expression itself, making sure we
9278 -- do not evaluate it more than once.
9280 -- Here Ck_Node is the original expression, or more properly the
9281 -- result of applying Duplicate_Expr to the original tree, forcing
9282 -- the result to be a name.
9286 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9289 -- Build the condition for the explicit dereference case
9291 for Indx
in 1 .. Ndims
loop
9293 (Cond
, Length_N_Cond
(Ck_Node
, T_Typ
, Indx
));
9300 -- Construct the test and insert into the tree
9302 if Present
(Cond
) then
9304 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
9308 (Make_Raise_Constraint_Error
(Loc
,
9310 Reason
=> CE_Length_Check_Failed
));
9314 end Selected_Length_Checks
;
9316 ---------------------------
9317 -- Selected_Range_Checks --
9318 ---------------------------
9320 function Selected_Range_Checks
9322 Target_Typ
: Entity_Id
;
9323 Source_Typ
: Entity_Id
;
9324 Warn_Node
: Node_Id
) return Check_Result
9326 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
9329 Expr_Actual
: Node_Id
;
9331 Cond
: Node_Id
:= Empty
;
9332 Do_Access
: Boolean := False;
9333 Wnode
: Node_Id
:= Warn_Node
;
9334 Ret_Result
: Check_Result
:= (Empty
, Empty
);
9335 Num_Checks
: Integer := 0;
9337 procedure Add_Check
(N
: Node_Id
);
9338 -- Adds the action given to Ret_Result if N is non-Empty
9340 function Discrete_Range_Cond
9342 Typ
: Entity_Id
) return Node_Id
;
9343 -- Returns expression to compute:
9344 -- Low_Bound (Expr) < Typ'First
9346 -- High_Bound (Expr) > Typ'Last
9348 function Discrete_Expr_Cond
9350 Typ
: Entity_Id
) return Node_Id
;
9351 -- Returns expression to compute:
9356 function Get_E_First_Or_Last
9360 Nam
: Name_Id
) return Node_Id
;
9361 -- Returns an attribute reference
9362 -- E'First or E'Last
9363 -- with a source location of Loc.
9365 -- Nam is Name_First or Name_Last, according to which attribute is
9366 -- desired. If Indx is non-zero, it is passed as a literal in the
9367 -- Expressions of the attribute reference (identifying the desired
9368 -- array dimension).
9370 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
9371 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
9372 -- Returns expression to compute:
9373 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
9375 function Range_E_Cond
9376 (Exptyp
: Entity_Id
;
9380 -- Returns expression to compute:
9381 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
9383 function Range_Equal_E_Cond
9384 (Exptyp
: Entity_Id
;
9386 Indx
: Nat
) return Node_Id
;
9387 -- Returns expression to compute:
9388 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
9390 function Range_N_Cond
9393 Indx
: Nat
) return Node_Id
;
9394 -- Return expression to compute:
9395 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
9401 procedure Add_Check
(N
: Node_Id
) is
9405 -- For now, ignore attempt to place more than 2 checks ???
9407 if Num_Checks
= 2 then
9411 pragma Assert
(Num_Checks
<= 1);
9412 Num_Checks
:= Num_Checks
+ 1;
9413 Ret_Result
(Num_Checks
) := N
;
9417 -------------------------
9418 -- Discrete_Expr_Cond --
9419 -------------------------
9421 function Discrete_Expr_Cond
9423 Typ
: Entity_Id
) return Node_Id
9431 Convert_To
(Base_Type
(Typ
),
9432 Duplicate_Subexpr_No_Checks
(Expr
)),
9434 Convert_To
(Base_Type
(Typ
),
9435 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
))),
9440 Convert_To
(Base_Type
(Typ
),
9441 Duplicate_Subexpr_No_Checks
(Expr
)),
9445 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
))));
9446 end Discrete_Expr_Cond
;
9448 -------------------------
9449 -- Discrete_Range_Cond --
9450 -------------------------
9452 function Discrete_Range_Cond
9454 Typ
: Entity_Id
) return Node_Id
9456 LB
: Node_Id
:= Low_Bound
(Expr
);
9457 HB
: Node_Id
:= High_Bound
(Expr
);
9459 Left_Opnd
: Node_Id
;
9460 Right_Opnd
: Node_Id
;
9463 if Nkind
(LB
) = N_Identifier
9464 and then Ekind
(Entity
(LB
)) = E_Discriminant
9466 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
9473 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
9478 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
)));
9480 if Nkind
(HB
) = N_Identifier
9481 and then Ekind
(Entity
(HB
)) = E_Discriminant
9483 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
9490 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
9495 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
)));
9497 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
9498 end Discrete_Range_Cond
;
9500 -------------------------
9501 -- Get_E_First_Or_Last --
9502 -------------------------
9504 function Get_E_First_Or_Last
9508 Nam
: Name_Id
) return Node_Id
9513 Exprs
:= New_List
(Make_Integer_Literal
(Loc
, UI_From_Int
(Indx
)));
9518 return Make_Attribute_Reference
(Loc
,
9519 Prefix
=> New_Occurrence_Of
(E
, Loc
),
9520 Attribute_Name
=> Nam
,
9521 Expressions
=> Exprs
);
9522 end Get_E_First_Or_Last
;
9528 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
9531 Make_Attribute_Reference
(Loc
,
9532 Attribute_Name
=> Name_First
,
9534 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
9535 Expressions
=> New_List
(
9536 Make_Integer_Literal
(Loc
, Indx
)));
9543 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
9546 Make_Attribute_Reference
(Loc
,
9547 Attribute_Name
=> Name_Last
,
9549 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
9550 Expressions
=> New_List
(
9551 Make_Integer_Literal
(Loc
, Indx
)));
9558 function Range_E_Cond
9559 (Exptyp
: Entity_Id
;
9561 Indx
: Nat
) return Node_Id
9569 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
9571 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
9576 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
9578 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
9581 ------------------------
9582 -- Range_Equal_E_Cond --
9583 ------------------------
9585 function Range_Equal_E_Cond
9586 (Exptyp
: Entity_Id
;
9588 Indx
: Nat
) return Node_Id
9596 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
9598 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
9603 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
9605 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
9606 end Range_Equal_E_Cond
;
9612 function Range_N_Cond
9615 Indx
: Nat
) return Node_Id
9623 Get_N_First
(Expr
, Indx
),
9625 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
9630 Get_N_Last
(Expr
, Indx
),
9632 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
9635 -- Start of processing for Selected_Range_Checks
9638 if not Expander_Active
then
9642 if Target_Typ
= Any_Type
9643 or else Target_Typ
= Any_Composite
9644 or else Raises_Constraint_Error
(Ck_Node
)
9653 T_Typ
:= Target_Typ
;
9655 if No
(Source_Typ
) then
9656 S_Typ
:= Etype
(Ck_Node
);
9658 S_Typ
:= Source_Typ
;
9661 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
9665 -- The order of evaluating T_Typ before S_Typ seems to be critical
9666 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
9667 -- in, and since Node can be an N_Range node, it might be invalid.
9668 -- Should there be an assert check somewhere for taking the Etype of
9669 -- an N_Range node ???
9671 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
9672 S_Typ
:= Designated_Type
(S_Typ
);
9673 T_Typ
:= Designated_Type
(T_Typ
);
9676 -- A simple optimization for the null case
9678 if Known_Null
(Ck_Node
) then
9683 -- For an N_Range Node, check for a null range and then if not
9684 -- null generate a range check action.
9686 if Nkind
(Ck_Node
) = N_Range
then
9688 -- There's no point in checking a range against itself
9690 if Ck_Node
= Scalar_Range
(T_Typ
) then
9695 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
9696 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
9697 Known_T_LB
: constant Boolean := Compile_Time_Known_Value
(T_LB
);
9698 Known_T_HB
: constant Boolean := Compile_Time_Known_Value
(T_HB
);
9700 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
9701 HB
: Node_Id
:= High_Bound
(Ck_Node
);
9705 Null_Range
: Boolean;
9706 Out_Of_Range_L
: Boolean;
9707 Out_Of_Range_H
: Boolean;
9710 -- Compute what is known at compile time
9712 if Known_T_LB
and Known_T_HB
then
9713 if Compile_Time_Known_Value
(LB
) then
9716 -- There's no point in checking that a bound is within its
9717 -- own range so pretend that it is known in this case. First
9718 -- deal with low bound.
9720 elsif Ekind
(Etype
(LB
)) = E_Signed_Integer_Subtype
9721 and then Scalar_Range
(Etype
(LB
)) = Scalar_Range
(T_Typ
)
9730 -- Likewise for the high bound
9732 if Compile_Time_Known_Value
(HB
) then
9735 elsif Ekind
(Etype
(HB
)) = E_Signed_Integer_Subtype
9736 and then Scalar_Range
(Etype
(HB
)) = Scalar_Range
(T_Typ
)
9745 -- Check for case where everything is static and we can do the
9746 -- check at compile time. This is skipped if we have an access
9747 -- type, since the access value may be null.
9749 -- ??? This code can be improved since you only need to know that
9750 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
9751 -- compile time to emit pertinent messages.
9753 if Known_T_LB
and Known_T_HB
and Known_LB
and Known_HB
9756 -- Floating-point case
9758 if Is_Floating_Point_Type
(S_Typ
) then
9759 Null_Range
:= Expr_Value_R
(HB
) < Expr_Value_R
(LB
);
9761 (Expr_Value_R
(LB
) < Expr_Value_R
(T_LB
))
9763 (Expr_Value_R
(LB
) > Expr_Value_R
(T_HB
));
9766 (Expr_Value_R
(HB
) > Expr_Value_R
(T_HB
))
9768 (Expr_Value_R
(HB
) < Expr_Value_R
(T_LB
));
9770 -- Fixed or discrete type case
9773 Null_Range
:= Expr_Value
(HB
) < Expr_Value
(LB
);
9775 (Expr_Value
(LB
) < Expr_Value
(T_LB
))
9777 (Expr_Value
(LB
) > Expr_Value
(T_HB
));
9780 (Expr_Value
(HB
) > Expr_Value
(T_HB
))
9782 (Expr_Value
(HB
) < Expr_Value
(T_LB
));
9785 if not Null_Range
then
9786 if Out_Of_Range_L
then
9787 if No
(Warn_Node
) then
9789 (Compile_Time_Constraint_Error
9790 (Low_Bound
(Ck_Node
),
9791 "static value out of range of}??", T_Typ
));
9795 (Compile_Time_Constraint_Error
9797 "static range out of bounds of}??", T_Typ
));
9801 if Out_Of_Range_H
then
9802 if No
(Warn_Node
) then
9804 (Compile_Time_Constraint_Error
9805 (High_Bound
(Ck_Node
),
9806 "static value out of range of}??", T_Typ
));
9810 (Compile_Time_Constraint_Error
9812 "static range out of bounds of}??", T_Typ
));
9819 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
9820 HB
: Node_Id
:= High_Bound
(Ck_Node
);
9823 -- If either bound is a discriminant and we are within the
9824 -- record declaration, it is a use of the discriminant in a
9825 -- constraint of a component, and nothing can be checked
9826 -- here. The check will be emitted within the init proc.
9827 -- Before then, the discriminal has no real meaning.
9828 -- Similarly, if the entity is a discriminal, there is no
9829 -- check to perform yet.
9831 -- The same holds within a discriminated synchronized type,
9832 -- where the discriminant may constrain a component or an
9835 if Nkind
(LB
) = N_Identifier
9836 and then Denotes_Discriminant
(LB
, True)
9838 if Current_Scope
= Scope
(Entity
(LB
))
9839 or else Is_Concurrent_Type
(Current_Scope
)
9840 or else Ekind
(Entity
(LB
)) /= E_Discriminant
9845 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
9849 if Nkind
(HB
) = N_Identifier
9850 and then Denotes_Discriminant
(HB
, True)
9852 if Current_Scope
= Scope
(Entity
(HB
))
9853 or else Is_Concurrent_Type
(Current_Scope
)
9854 or else Ekind
(Entity
(HB
)) /= E_Discriminant
9859 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
9863 Cond
:= Discrete_Range_Cond
(Ck_Node
, T_Typ
);
9864 Set_Paren_Count
(Cond
, 1);
9871 Convert_To
(Base_Type
(Etype
(HB
)),
9872 Duplicate_Subexpr_No_Checks
(HB
)),
9874 Convert_To
(Base_Type
(Etype
(LB
)),
9875 Duplicate_Subexpr_No_Checks
(LB
))),
9876 Right_Opnd
=> Cond
);
9881 elsif Is_Scalar_Type
(S_Typ
) then
9883 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
9884 -- except the above simply sets a flag in the node and lets
9885 -- gigi generate the check base on the Etype of the expression.
9886 -- Sometimes, however we want to do a dynamic check against an
9887 -- arbitrary target type, so we do that here.
9889 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
9890 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9892 -- For literals, we can tell if the constraint error will be
9893 -- raised at compile time, so we never need a dynamic check, but
9894 -- if the exception will be raised, then post the usual warning,
9895 -- and replace the literal with a raise constraint error
9896 -- expression. As usual, skip this for access types
9898 elsif Compile_Time_Known_Value
(Ck_Node
) and then not Do_Access
then
9900 LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
9901 UB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
9903 Out_Of_Range
: Boolean;
9904 Static_Bounds
: constant Boolean :=
9905 Compile_Time_Known_Value
(LB
)
9906 and Compile_Time_Known_Value
(UB
);
9909 -- Following range tests should use Sem_Eval routine ???
9911 if Static_Bounds
then
9912 if Is_Floating_Point_Type
(S_Typ
) then
9914 (Expr_Value_R
(Ck_Node
) < Expr_Value_R
(LB
))
9916 (Expr_Value_R
(Ck_Node
) > Expr_Value_R
(UB
));
9918 -- Fixed or discrete type
9922 Expr_Value
(Ck_Node
) < Expr_Value
(LB
)
9924 Expr_Value
(Ck_Node
) > Expr_Value
(UB
);
9927 -- Bounds of the type are static and the literal is out of
9928 -- range so output a warning message.
9930 if Out_Of_Range
then
9931 if No
(Warn_Node
) then
9933 (Compile_Time_Constraint_Error
9935 "static value out of range of}??", T_Typ
));
9939 (Compile_Time_Constraint_Error
9941 "static value out of range of}??", T_Typ
));
9946 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9950 -- Here for the case of a non-static expression, we need a runtime
9951 -- check unless the source type range is guaranteed to be in the
9952 -- range of the target type.
9955 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
9956 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9961 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
9962 if Is_Constrained
(T_Typ
) then
9964 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
9965 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
9967 if Is_Access_Type
(Exptyp
) then
9968 Exptyp
:= Designated_Type
(Exptyp
);
9971 -- String_Literal case. This needs to be handled specially be-
9972 -- cause no index types are available for string literals. The
9973 -- condition is simply:
9975 -- T_Typ'Length = string-literal-length
9977 if Nkind
(Expr_Actual
) = N_String_Literal
then
9980 -- General array case. Here we have a usable actual subtype for
9981 -- the expression, and the condition is built from the two types
9983 -- T_Typ'First < Exptyp'First or else
9984 -- T_Typ'Last > Exptyp'Last or else
9985 -- T_Typ'First(1) < Exptyp'First(1) or else
9986 -- T_Typ'Last(1) > Exptyp'Last(1) or else
9989 elsif Is_Constrained
(Exptyp
) then
9991 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9997 L_Index
:= First_Index
(T_Typ
);
9998 R_Index
:= First_Index
(Exptyp
);
10000 for Indx
in 1 .. Ndims
loop
10001 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
10003 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
10005 -- Deal with compile time length check. Note that we
10006 -- skip this in the access case, because the access
10007 -- value may be null, so we cannot know statically.
10010 Subtypes_Statically_Match
10011 (Etype
(L_Index
), Etype
(R_Index
))
10013 -- If the target type is constrained then we
10014 -- have to check for exact equality of bounds
10015 -- (required for qualified expressions).
10017 if Is_Constrained
(T_Typ
) then
10020 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
10023 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
10033 -- Handle cases where we do not get a usable actual subtype that
10034 -- is constrained. This happens for example in the function call
10035 -- and explicit dereference cases. In these cases, we have to get
10036 -- the length or range from the expression itself, making sure we
10037 -- do not evaluate it more than once.
10039 -- Here Ck_Node is the original expression, or more properly the
10040 -- result of applying Duplicate_Expr to the original tree,
10041 -- forcing the result to be a name.
10045 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
10048 -- Build the condition for the explicit dereference case
10050 for Indx
in 1 .. Ndims
loop
10052 (Cond
, Range_N_Cond
(Ck_Node
, T_Typ
, Indx
));
10058 -- For a conversion to an unconstrained array type, generate an
10059 -- Action to check that the bounds of the source value are within
10060 -- the constraints imposed by the target type (RM 4.6(38)). No
10061 -- check is needed for a conversion to an access to unconstrained
10062 -- array type, as 4.6(24.15/2) requires the designated subtypes
10063 -- of the two access types to statically match.
10065 if Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
10066 and then not Do_Access
10069 Opnd_Index
: Node_Id
;
10070 Targ_Index
: Node_Id
;
10071 Opnd_Range
: Node_Id
;
10074 Opnd_Index
:= First_Index
(Get_Actual_Subtype
(Ck_Node
));
10075 Targ_Index
:= First_Index
(T_Typ
);
10076 while Present
(Opnd_Index
) loop
10078 -- If the index is a range, use its bounds. If it is an
10079 -- entity (as will be the case if it is a named subtype
10080 -- or an itype created for a slice) retrieve its range.
10082 if Is_Entity_Name
(Opnd_Index
)
10083 and then Is_Type
(Entity
(Opnd_Index
))
10085 Opnd_Range
:= Scalar_Range
(Entity
(Opnd_Index
));
10087 Opnd_Range
:= Opnd_Index
;
10090 if Nkind
(Opnd_Range
) = N_Range
then
10092 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
10093 Assume_Valid
=> True)
10096 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
10097 Assume_Valid
=> True)
10101 -- If null range, no check needed
10104 Compile_Time_Known_Value
(High_Bound
(Opnd_Range
))
10106 Compile_Time_Known_Value
(Low_Bound
(Opnd_Range
))
10108 Expr_Value
(High_Bound
(Opnd_Range
)) <
10109 Expr_Value
(Low_Bound
(Opnd_Range
))
10113 elsif Is_Out_Of_Range
10114 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
10115 Assume_Valid
=> True)
10118 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
10119 Assume_Valid
=> True)
10122 (Compile_Time_Constraint_Error
10123 (Wnode
, "value out of range of}??", T_Typ
));
10128 Discrete_Range_Cond
10129 (Opnd_Range
, Etype
(Targ_Index
)));
10133 Next_Index
(Opnd_Index
);
10134 Next_Index
(Targ_Index
);
10141 -- Construct the test and insert into the tree
10143 if Present
(Cond
) then
10145 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
10149 (Make_Raise_Constraint_Error
(Loc
,
10151 Reason
=> CE_Range_Check_Failed
));
10155 end Selected_Range_Checks
;
10157 -------------------------------
10158 -- Storage_Checks_Suppressed --
10159 -------------------------------
10161 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
10163 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
10164 return Is_Check_Suppressed
(E
, Storage_Check
);
10166 return Scope_Suppress
.Suppress
(Storage_Check
);
10168 end Storage_Checks_Suppressed
;
10170 ---------------------------
10171 -- Tag_Checks_Suppressed --
10172 ---------------------------
10174 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
10177 and then Checks_May_Be_Suppressed
(E
)
10179 return Is_Check_Suppressed
(E
, Tag_Check
);
10181 return Scope_Suppress
.Suppress
(Tag_Check
);
10183 end Tag_Checks_Suppressed
;
10185 ---------------------------------------
10186 -- Validate_Alignment_Check_Warnings --
10187 ---------------------------------------
10189 procedure Validate_Alignment_Check_Warnings
is
10191 for J
in Alignment_Warnings
.First
.. Alignment_Warnings
.Last
loop
10193 AWR
: Alignment_Warnings_Record
10194 renames Alignment_Warnings
.Table
(J
);
10196 if Known_Alignment
(AWR
.E
)
10197 and then AWR
.A
mod Alignment
(AWR
.E
) = 0
10199 Delete_Warning_And_Continuations
(AWR
.W
);
10203 end Validate_Alignment_Check_Warnings
;
10205 --------------------------
10206 -- Validity_Check_Range --
10207 --------------------------
10209 procedure Validity_Check_Range
10211 Related_Id
: Entity_Id
:= Empty
)
10214 if Validity_Checks_On
and Validity_Check_Operands
then
10215 if Nkind
(N
) = N_Range
then
10217 (Expr
=> Low_Bound
(N
),
10218 Related_Id
=> Related_Id
,
10219 Is_Low_Bound
=> True);
10222 (Expr
=> High_Bound
(N
),
10223 Related_Id
=> Related_Id
,
10224 Is_High_Bound
=> True);
10227 end Validity_Check_Range
;
10229 --------------------------------
10230 -- Validity_Checks_Suppressed --
10231 --------------------------------
10233 function Validity_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
10235 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
10236 return Is_Check_Suppressed
(E
, Validity_Check
);
10238 return Scope_Suppress
.Suppress
(Validity_Check
);
10240 end Validity_Checks_Suppressed
;