1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, 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
753 -- the object X has an alignment that is compatible with the object E.
754 -- If it hasn't or we don't know, we defer issuing the warning until
755 -- the end 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
759 and then Has_Compatible_Alignment
(E
, Prefix
(Expr
)) = Known_Compatible
764 -- Here we do not know if the value is acceptable. Strictly we don't
765 -- have to do anything, since if the alignment is bad, we have an
766 -- erroneous program. However we are allowed to check for erroneous
767 -- conditions and we decide to do this by default if the check is not
770 -- However, don't do the check if elaboration code is unwanted
772 if Restriction_Active
(No_Elaboration_Code
) then
775 -- Generate a check to raise PE if alignment may be inappropriate
778 -- If the original expression is a non-static constant, use the
779 -- name of the constant itself rather than duplicating its
780 -- defining expression, which was extracted above.
782 -- Note: Expr is empty if the address-clause is applied to in-mode
783 -- actuals (allowed by 13.1(22)).
785 if not Present
(Expr
)
787 (Is_Entity_Name
(Expression
(AC
))
788 and then Ekind
(Entity
(Expression
(AC
))) = E_Constant
789 and then Nkind
(Parent
(Entity
(Expression
(AC
))))
790 = N_Object_Declaration
)
792 Expr
:= New_Copy_Tree
(Expression
(AC
));
794 Remove_Side_Effects
(Expr
);
797 if No
(Actions
(N
)) then
798 Set_Actions
(N
, New_List
);
801 Prepend_To
(Actions
(N
),
802 Make_Raise_Program_Error
(Loc
,
809 (RTE
(RE_Integer_Address
), Expr
),
811 Make_Attribute_Reference
(Loc
,
812 Prefix
=> New_Occurrence_Of
(E
, Loc
),
813 Attribute_Name
=> Name_Alignment
)),
814 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
815 Reason
=> PE_Misaligned_Address_Value
));
817 Warning_Msg
:= No_Error_Msg
;
818 Analyze
(First
(Actions
(N
)), Suppress
=> All_Checks
);
820 -- If the address clause generated a warning message (for example,
821 -- from Warn_On_Non_Local_Exception mode with the active restriction
822 -- No_Exception_Propagation).
824 if Warning_Msg
/= No_Error_Msg
then
826 -- If the expression has a known at compile time value, then
827 -- once we know the alignment of the type, we can check if the
828 -- exception will be raised or not, and if not, we don't need
829 -- the warning so we will kill the warning later on.
831 if Compile_Time_Known_Value
(Expr
) then
832 Alignment_Warnings
.Append
833 ((E
=> E
, A
=> Expr_Value
(Expr
), W
=> Warning_Msg
));
836 -- Add explanation of the warning that is generated by the check
839 ("\address value may be incompatible with alignment "
840 & "of object?X?", AC
);
847 -- If we have some missing run time component in configurable run time
848 -- mode then just skip the check (it is not required in any case).
850 when RE_Not_Available
=>
852 end Apply_Address_Clause_Check
;
854 -------------------------------------
855 -- Apply_Arithmetic_Overflow_Check --
856 -------------------------------------
858 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
860 -- Use old routine in almost all cases (the only case we are treating
861 -- specially is the case of a signed integer arithmetic op with the
862 -- overflow checking mode set to MINIMIZED or ELIMINATED).
864 if Overflow_Check_Mode
= Strict
865 or else not Is_Signed_Integer_Arithmetic_Op
(N
)
867 Apply_Arithmetic_Overflow_Strict
(N
);
869 -- Otherwise use the new routine for the case of a signed integer
870 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
871 -- mode is MINIMIZED or ELIMINATED.
874 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
876 end Apply_Arithmetic_Overflow_Check
;
878 --------------------------------------
879 -- Apply_Arithmetic_Overflow_Strict --
880 --------------------------------------
882 -- This routine is called only if the type is an integer type, and a
883 -- software arithmetic overflow check may be needed for op (add, subtract,
884 -- or multiply). This check is performed only if Software_Overflow_Checking
885 -- is enabled and Do_Overflow_Check is set. In this case we expand the
886 -- operation into a more complex sequence of tests that ensures that
887 -- overflow is properly caught.
889 -- This is used in CHECKED modes. It is identical to the code for this
890 -- cases before the big overflow earthquake, thus ensuring that in this
891 -- modes we have compatible behavior (and reliability) to what was there
892 -- before. It is also called for types other than signed integers, and if
893 -- the Do_Overflow_Check flag is off.
895 -- Note: we also call this routine if we decide in the MINIMIZED case
896 -- to give up and just generate an overflow check without any fuss.
898 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
) is
899 Loc
: constant Source_Ptr
:= Sloc
(N
);
900 Typ
: constant Entity_Id
:= Etype
(N
);
901 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
904 -- Nothing to do if Do_Overflow_Check not set or overflow checks
907 if not Do_Overflow_Check
(N
) then
911 -- An interesting special case. If the arithmetic operation appears as
912 -- the operand of a type conversion:
916 -- and all the following conditions apply:
918 -- arithmetic operation is for a signed integer type
919 -- target type type1 is a static integer subtype
920 -- range of x and y are both included in the range of type1
921 -- range of x op y is included in the range of type1
922 -- size of type1 is at least twice the result size of op
924 -- then we don't do an overflow check in any case, instead we transform
925 -- the operation so that we end up with:
927 -- type1 (type1 (x) op type1 (y))
929 -- This avoids intermediate overflow before the conversion. It is
930 -- explicitly permitted by RM 3.5.4(24):
932 -- For the execution of a predefined operation of a signed integer
933 -- type, the implementation need not raise Constraint_Error if the
934 -- result is outside the base range of the type, so long as the
935 -- correct result is produced.
937 -- It's hard to imagine that any programmer counts on the exception
938 -- being raised in this case, and in any case it's wrong coding to
939 -- have this expectation, given the RM permission. Furthermore, other
940 -- Ada compilers do allow such out of range results.
942 -- Note that we do this transformation even if overflow checking is
943 -- off, since this is precisely about giving the "right" result and
944 -- avoiding the need for an overflow check.
946 -- Note: this circuit is partially redundant with respect to the similar
947 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
948 -- with cases that do not come through here. We still need the following
949 -- processing even with the Exp_Ch4 code in place, since we want to be
950 -- sure not to generate the arithmetic overflow check in these cases
951 -- (Exp_Ch4 would have a hard time removing them once generated).
953 if Is_Signed_Integer_Type
(Typ
)
954 and then Nkind
(Parent
(N
)) = N_Type_Conversion
956 Conversion_Optimization
: declare
957 Target_Type
: constant Entity_Id
:=
958 Base_Type
(Entity
(Subtype_Mark
(Parent
(N
))));
972 if Is_Integer_Type
(Target_Type
)
973 and then RM_Size
(Root_Type
(Target_Type
)) >= 2 * RM_Size
(Rtyp
)
975 Tlo
:= Expr_Value
(Type_Low_Bound
(Target_Type
));
976 Thi
:= Expr_Value
(Type_High_Bound
(Target_Type
));
979 (Left_Opnd
(N
), LOK
, Llo
, Lhi
, Assume_Valid
=> True);
981 (Right_Opnd
(N
), ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
984 and then Tlo
<= Llo
and then Lhi
<= Thi
985 and then Tlo
<= Rlo
and then Rhi
<= Thi
987 Determine_Range
(N
, VOK
, Vlo
, Vhi
, Assume_Valid
=> True);
989 if VOK
and then Tlo
<= Vlo
and then Vhi
<= Thi
then
990 Rewrite
(Left_Opnd
(N
),
991 Make_Type_Conversion
(Loc
,
992 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
993 Expression
=> Relocate_Node
(Left_Opnd
(N
))));
995 Rewrite
(Right_Opnd
(N
),
996 Make_Type_Conversion
(Loc
,
997 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
998 Expression
=> Relocate_Node
(Right_Opnd
(N
))));
1000 -- Rewrite the conversion operand so that the original
1001 -- node is retained, in order to avoid the warning for
1002 -- redundant conversions in Resolve_Type_Conversion.
1004 Rewrite
(N
, Relocate_Node
(N
));
1006 Set_Etype
(N
, Target_Type
);
1008 Analyze_And_Resolve
(Left_Opnd
(N
), Target_Type
);
1009 Analyze_And_Resolve
(Right_Opnd
(N
), Target_Type
);
1011 -- Given that the target type is twice the size of the
1012 -- source type, overflow is now impossible, so we can
1013 -- safely kill the overflow check and return.
1015 Set_Do_Overflow_Check
(N
, False);
1020 end Conversion_Optimization
;
1023 -- Now see if an overflow check is required
1026 Siz
: constant Int
:= UI_To_Int
(Esize
(Rtyp
));
1027 Dsiz
: constant Int
:= Siz
* 2;
1034 -- Skip check if back end does overflow checks, or the overflow flag
1035 -- is not set anyway, or we are not doing code expansion, or the
1036 -- parent node is a type conversion whose operand is an arithmetic
1037 -- operation on signed integers on which the expander can promote
1038 -- later the operands to type Integer (see Expand_N_Type_Conversion).
1040 -- Special case CLI target, where arithmetic overflow checks can be
1041 -- performed for integer and long_integer
1043 if Backend_Overflow_Checks_On_Target
1044 or else not Do_Overflow_Check
(N
)
1045 or else not Expander_Active
1046 or else (Present
(Parent
(N
))
1047 and then Nkind
(Parent
(N
)) = N_Type_Conversion
1048 and then Integer_Promotion_Possible
(Parent
(N
)))
1050 (VM_Target
= CLI_Target
and then Siz
>= Standard_Integer_Size
)
1055 -- Otherwise, generate the full general code for front end overflow
1056 -- detection, which works by doing arithmetic in a larger type:
1062 -- Typ (Checktyp (x) op Checktyp (y));
1064 -- where Typ is the type of the original expression, and Checktyp is
1065 -- an integer type of sufficient length to hold the largest possible
1068 -- If the size of check type exceeds the size of Long_Long_Integer,
1069 -- we use a different approach, expanding to:
1071 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
1073 -- where xxx is Add, Multiply or Subtract as appropriate
1075 -- Find check type if one exists
1077 if Dsiz
<= Standard_Integer_Size
then
1078 Ctyp
:= Standard_Integer
;
1080 elsif Dsiz
<= Standard_Long_Long_Integer_Size
then
1081 Ctyp
:= Standard_Long_Long_Integer
;
1083 -- No check type exists, use runtime call
1086 if Nkind
(N
) = N_Op_Add
then
1087 Cent
:= RE_Add_With_Ovflo_Check
;
1089 elsif Nkind
(N
) = N_Op_Multiply
then
1090 Cent
:= RE_Multiply_With_Ovflo_Check
;
1093 pragma Assert
(Nkind
(N
) = N_Op_Subtract
);
1094 Cent
:= RE_Subtract_With_Ovflo_Check
;
1099 Make_Function_Call
(Loc
,
1100 Name
=> New_Occurrence_Of
(RTE
(Cent
), Loc
),
1101 Parameter_Associations
=> New_List
(
1102 OK_Convert_To
(RTE
(RE_Integer_64
), Left_Opnd
(N
)),
1103 OK_Convert_To
(RTE
(RE_Integer_64
), Right_Opnd
(N
))))));
1105 Analyze_And_Resolve
(N
, Typ
);
1109 -- If we fall through, we have the case where we do the arithmetic
1110 -- in the next higher type and get the check by conversion. In these
1111 -- cases Ctyp is set to the type to be used as the check type.
1113 Opnod
:= Relocate_Node
(N
);
1115 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
1118 Set_Etype
(Opnd
, Ctyp
);
1119 Set_Analyzed
(Opnd
, True);
1120 Set_Left_Opnd
(Opnod
, Opnd
);
1122 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
1125 Set_Etype
(Opnd
, Ctyp
);
1126 Set_Analyzed
(Opnd
, True);
1127 Set_Right_Opnd
(Opnod
, Opnd
);
1129 -- The type of the operation changes to the base type of the check
1130 -- type, and we reset the overflow check indication, since clearly no
1131 -- overflow is possible now that we are using a double length type.
1132 -- We also set the Analyzed flag to avoid a recursive attempt to
1135 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
1136 Set_Do_Overflow_Check
(Opnod
, False);
1137 Set_Analyzed
(Opnod
, True);
1139 -- Now build the outer conversion
1141 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
1143 Set_Etype
(Opnd
, Typ
);
1145 -- In the discrete type case, we directly generate the range check
1146 -- for the outer operand. This range check will implement the
1147 -- required overflow check.
1149 if Is_Discrete_Type
(Typ
) then
1151 Generate_Range_Check
1152 (Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
1154 -- For other types, we enable overflow checking on the conversion,
1155 -- after setting the node as analyzed to prevent recursive attempts
1156 -- to expand the conversion node.
1159 Set_Analyzed
(Opnd
, True);
1160 Enable_Overflow_Check
(Opnd
);
1165 when RE_Not_Available
=>
1168 end Apply_Arithmetic_Overflow_Strict
;
1170 ----------------------------------------------------
1171 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1172 ----------------------------------------------------
1174 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
) is
1175 pragma Assert
(Is_Signed_Integer_Arithmetic_Op
(Op
));
1177 Loc
: constant Source_Ptr
:= Sloc
(Op
);
1178 P
: constant Node_Id
:= Parent
(Op
);
1180 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
1181 -- Operands and results are of this type when we convert
1183 Result_Type
: constant Entity_Id
:= Etype
(Op
);
1184 -- Original result type
1186 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1187 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
1190 -- Ranges of values for result
1193 -- Nothing to do if our parent is one of the following:
1195 -- Another signed integer arithmetic op
1196 -- A membership operation
1197 -- A comparison operation
1199 -- In all these cases, we will process at the higher level (and then
1200 -- this node will be processed during the downwards recursion that
1201 -- is part of the processing in Minimize_Eliminate_Overflows).
1203 if Is_Signed_Integer_Arithmetic_Op
(P
)
1204 or else Nkind
(P
) in N_Membership_Test
1205 or else Nkind
(P
) in N_Op_Compare
1207 -- This is also true for an alternative in a case expression
1209 or else Nkind
(P
) = N_Case_Expression_Alternative
1211 -- This is also true for a range operand in a membership test
1213 or else (Nkind
(P
) = N_Range
1214 and then Nkind
(Parent
(P
)) in N_Membership_Test
)
1219 -- Otherwise, we have a top level arithmetic operation node, and this
1220 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1221 -- modes. This is the case where we tell the machinery not to move into
1222 -- Bignum mode at this top level (of course the top level operation
1223 -- will still be in Bignum mode if either of its operands are of type
1226 Minimize_Eliminate_Overflows
(Op
, Lo
, Hi
, Top_Level
=> True);
1228 -- That call may but does not necessarily change the result type of Op.
1229 -- It is the job of this routine to undo such changes, so that at the
1230 -- top level, we have the proper type. This "undoing" is a point at
1231 -- which a final overflow check may be applied.
1233 -- If the result type was not fiddled we are all set. We go to base
1234 -- types here because things may have been rewritten to generate the
1235 -- base type of the operand types.
1237 if Base_Type
(Etype
(Op
)) = Base_Type
(Result_Type
) then
1242 elsif Is_RTE
(Etype
(Op
), RE_Bignum
) then
1244 -- We need a sequence that looks like:
1246 -- Rnn : Result_Type;
1249 -- M : Mark_Id := SS_Mark;
1251 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1255 -- This block is inserted (using Insert_Actions), and then the node
1256 -- is replaced with a reference to Rnn.
1258 -- A special case arises if our parent is a conversion node. In this
1259 -- case no point in generating a conversion to Result_Type, we will
1260 -- let the parent handle this. Note that this special case is not
1261 -- just about optimization. Consider
1265 -- X := Long_Long_Integer'Base (A * (B ** C));
1267 -- Now the product may fit in Long_Long_Integer but not in Integer.
1268 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1269 -- overflow exception for this intermediate value.
1272 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
1273 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R', Op
);
1279 RHS
:= Convert_From_Bignum
(Op
);
1281 if Nkind
(P
) /= N_Type_Conversion
then
1282 Convert_To_And_Rewrite
(Result_Type
, RHS
);
1283 Rtype
:= Result_Type
;
1285 -- Interesting question, do we need a check on that conversion
1286 -- operation. Answer, not if we know the result is in range.
1287 -- At the moment we are not taking advantage of this. To be
1288 -- looked at later ???
1295 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
1296 Make_Assignment_Statement
(Loc
,
1297 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
1298 Expression
=> RHS
));
1300 Insert_Actions
(Op
, New_List
(
1301 Make_Object_Declaration
(Loc
,
1302 Defining_Identifier
=> Rnn
,
1303 Object_Definition
=> New_Occurrence_Of
(Rtype
, Loc
)),
1306 Rewrite
(Op
, New_Occurrence_Of
(Rnn
, Loc
));
1307 Analyze_And_Resolve
(Op
);
1310 -- Here we know the result is Long_Long_Integer'Base, of that it has
1311 -- been rewritten because the parent operation is a conversion. See
1312 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1316 (Etype
(Op
) = LLIB
or else Nkind
(Parent
(Op
)) = N_Type_Conversion
);
1318 -- All we need to do here is to convert the result to the proper
1319 -- result type. As explained above for the Bignum case, we can
1320 -- omit this if our parent is a type conversion.
1322 if Nkind
(P
) /= N_Type_Conversion
then
1323 Convert_To_And_Rewrite
(Result_Type
, Op
);
1326 Analyze_And_Resolve
(Op
);
1328 end Apply_Arithmetic_Overflow_Minimized_Eliminated
;
1330 ----------------------------
1331 -- Apply_Constraint_Check --
1332 ----------------------------
1334 procedure Apply_Constraint_Check
1337 No_Sliding
: Boolean := False)
1339 Desig_Typ
: Entity_Id
;
1342 -- No checks inside a generic (check the instantiations)
1344 if Inside_A_Generic
then
1348 -- Apply required constraint checks
1350 if Is_Scalar_Type
(Typ
) then
1351 Apply_Scalar_Range_Check
(N
, Typ
);
1353 elsif Is_Array_Type
(Typ
) then
1355 -- A useful optimization: an aggregate with only an others clause
1356 -- always has the right bounds.
1358 if Nkind
(N
) = N_Aggregate
1359 and then No
(Expressions
(N
))
1361 (First
(Choices
(First
(Component_Associations
(N
)))))
1367 if Is_Constrained
(Typ
) then
1368 Apply_Length_Check
(N
, Typ
);
1371 Apply_Range_Check
(N
, Typ
);
1374 Apply_Range_Check
(N
, Typ
);
1377 elsif (Is_Record_Type
(Typ
) or else Is_Private_Type
(Typ
))
1378 and then Has_Discriminants
(Base_Type
(Typ
))
1379 and then Is_Constrained
(Typ
)
1381 Apply_Discriminant_Check
(N
, Typ
);
1383 elsif Is_Access_Type
(Typ
) then
1385 Desig_Typ
:= Designated_Type
(Typ
);
1387 -- No checks necessary if expression statically null
1389 if Known_Null
(N
) then
1390 if Can_Never_Be_Null
(Typ
) then
1391 Install_Null_Excluding_Check
(N
);
1394 -- No sliding possible on access to arrays
1396 elsif Is_Array_Type
(Desig_Typ
) then
1397 if Is_Constrained
(Desig_Typ
) then
1398 Apply_Length_Check
(N
, Typ
);
1401 Apply_Range_Check
(N
, Typ
);
1403 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
1404 and then Is_Constrained
(Desig_Typ
)
1406 Apply_Discriminant_Check
(N
, Typ
);
1409 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1410 -- this check if the constraint node is illegal, as shown by having
1411 -- an error posted. This additional guard prevents cascaded errors
1412 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1414 if Can_Never_Be_Null
(Typ
)
1415 and then not Can_Never_Be_Null
(Etype
(N
))
1416 and then not Error_Posted
(N
)
1418 Install_Null_Excluding_Check
(N
);
1421 end Apply_Constraint_Check
;
1423 ------------------------------
1424 -- Apply_Discriminant_Check --
1425 ------------------------------
1427 procedure Apply_Discriminant_Check
1430 Lhs
: Node_Id
:= Empty
)
1432 Loc
: constant Source_Ptr
:= Sloc
(N
);
1433 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1434 S_Typ
: Entity_Id
:= Etype
(N
);
1438 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean;
1439 -- A heap object with an indefinite subtype is constrained by its
1440 -- initial value, and assigning to it requires a constraint_check.
1441 -- The target may be an explicit dereference, or a renaming of one.
1443 function Is_Aliased_Unconstrained_Component
return Boolean;
1444 -- It is possible for an aliased component to have a nominal
1445 -- unconstrained subtype (through instantiation). If this is a
1446 -- discriminated component assigned in the expansion of an aggregate
1447 -- in an initialization, the check must be suppressed. This unusual
1448 -- situation requires a predicate of its own.
1450 ----------------------------------
1451 -- Denotes_Explicit_Dereference --
1452 ----------------------------------
1454 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean is
1457 Nkind
(Obj
) = N_Explicit_Dereference
1459 (Is_Entity_Name
(Obj
)
1460 and then Present
(Renamed_Object
(Entity
(Obj
)))
1461 and then Nkind
(Renamed_Object
(Entity
(Obj
))) =
1462 N_Explicit_Dereference
);
1463 end Denotes_Explicit_Dereference
;
1465 ----------------------------------------
1466 -- Is_Aliased_Unconstrained_Component --
1467 ----------------------------------------
1469 function Is_Aliased_Unconstrained_Component
return Boolean is
1474 if Nkind
(Lhs
) /= N_Selected_Component
then
1477 Comp
:= Entity
(Selector_Name
(Lhs
));
1478 Pref
:= Prefix
(Lhs
);
1481 if Ekind
(Comp
) /= E_Component
1482 or else not Is_Aliased
(Comp
)
1487 return not Comes_From_Source
(Pref
)
1488 and then In_Instance
1489 and then not Is_Constrained
(Etype
(Comp
));
1490 end Is_Aliased_Unconstrained_Component
;
1492 -- Start of processing for Apply_Discriminant_Check
1496 T_Typ
:= Designated_Type
(Typ
);
1501 -- Nothing to do if discriminant checks are suppressed or else no code
1502 -- is to be generated
1504 if not Expander_Active
1505 or else Discriminant_Checks_Suppressed
(T_Typ
)
1510 -- No discriminant checks necessary for an access when expression is
1511 -- statically Null. This is not only an optimization, it is fundamental
1512 -- because otherwise discriminant checks may be generated in init procs
1513 -- for types containing an access to a not-yet-frozen record, causing a
1514 -- deadly forward reference.
1516 -- Also, if the expression is of an access type whose designated type is
1517 -- incomplete, then the access value must be null and we suppress the
1520 if Known_Null
(N
) then
1523 elsif Is_Access_Type
(S_Typ
) then
1524 S_Typ
:= Designated_Type
(S_Typ
);
1526 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1531 -- If an assignment target is present, then we need to generate the
1532 -- actual subtype if the target is a parameter or aliased object with
1533 -- an unconstrained nominal subtype.
1535 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1536 -- subtype to the parameter and dereference cases, since other aliased
1537 -- objects are unconstrained (unless the nominal subtype is explicitly
1541 and then (Present
(Param_Entity
(Lhs
))
1542 or else (Ada_Version
< Ada_2005
1543 and then not Is_Constrained
(T_Typ
)
1544 and then Is_Aliased_View
(Lhs
)
1545 and then not Is_Aliased_Unconstrained_Component
)
1546 or else (Ada_Version
>= Ada_2005
1547 and then not Is_Constrained
(T_Typ
)
1548 and then Denotes_Explicit_Dereference
(Lhs
)
1549 and then Nkind
(Original_Node
(Lhs
)) /=
1552 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1555 -- Nothing to do if the type is unconstrained (this is the case where
1556 -- the actual subtype in the RM sense of N is unconstrained and no check
1559 if not Is_Constrained
(T_Typ
) then
1562 -- Ada 2005: nothing to do if the type is one for which there is a
1563 -- partial view that is constrained.
1565 elsif Ada_Version
>= Ada_2005
1566 and then Object_Type_Has_Constrained_Partial_View
1567 (Typ
=> Base_Type
(T_Typ
),
1568 Scop
=> Current_Scope
)
1573 -- Nothing to do if the type is an Unchecked_Union
1575 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
1579 -- Suppress checks if the subtypes are the same. The check must be
1580 -- preserved in an assignment to a formal, because the constraint is
1581 -- given by the actual.
1583 if Nkind
(Original_Node
(N
)) /= N_Allocator
1585 or else not Is_Entity_Name
(Lhs
)
1586 or else No
(Param_Entity
(Lhs
)))
1589 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1590 and then not Is_Aliased_View
(Lhs
)
1595 -- We can also eliminate checks on allocators with a subtype mark that
1596 -- coincides with the context type. The context type may be a subtype
1597 -- without a constraint (common case, a generic actual).
1599 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1600 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1603 Alloc_Typ
: constant Entity_Id
:=
1604 Entity
(Expression
(Original_Node
(N
)));
1607 if Alloc_Typ
= T_Typ
1608 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1609 and then Is_Entity_Name
(
1610 Subtype_Indication
(Parent
(T_Typ
)))
1611 and then Alloc_Typ
= Base_Type
(T_Typ
))
1619 -- See if we have a case where the types are both constrained, and all
1620 -- the constraints are constants. In this case, we can do the check
1621 -- successfully at compile time.
1623 -- We skip this check for the case where the node is rewritten as
1624 -- an allocator, because it already carries the context subtype,
1625 -- and extracting the discriminants from the aggregate is messy.
1627 if Is_Constrained
(S_Typ
)
1628 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1638 -- S_Typ may not have discriminants in the case where it is a
1639 -- private type completed by a default discriminated type. In that
1640 -- case, we need to get the constraints from the underlying type.
1641 -- If the underlying type is unconstrained (i.e. has no default
1642 -- discriminants) no check is needed.
1644 if Has_Discriminants
(S_Typ
) then
1645 Discr
:= First_Discriminant
(S_Typ
);
1646 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1649 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1652 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1658 -- A further optimization: if T_Typ is derived from S_Typ
1659 -- without imposing a constraint, no check is needed.
1661 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1662 N_Full_Type_Declaration
1665 Type_Def
: constant Node_Id
:=
1666 Type_Definition
(Original_Node
(Parent
(T_Typ
)));
1668 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1669 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1670 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1678 -- Constraint may appear in full view of type
1680 if Ekind
(T_Typ
) = E_Private_Subtype
1681 and then Present
(Full_View
(T_Typ
))
1684 First_Elmt
(Discriminant_Constraint
(Full_View
(T_Typ
)));
1687 First_Elmt
(Discriminant_Constraint
(T_Typ
));
1690 while Present
(Discr
) loop
1691 ItemS
:= Node
(DconS
);
1692 ItemT
:= Node
(DconT
);
1694 -- For a discriminated component type constrained by the
1695 -- current instance of an enclosing type, there is no
1696 -- applicable discriminant check.
1698 if Nkind
(ItemT
) = N_Attribute_Reference
1699 and then Is_Access_Type
(Etype
(ItemT
))
1700 and then Is_Entity_Name
(Prefix
(ItemT
))
1701 and then Is_Type
(Entity
(Prefix
(ItemT
)))
1706 -- If the expressions for the discriminants are identical
1707 -- and it is side-effect free (for now just an entity),
1708 -- this may be a shared constraint, e.g. from a subtype
1709 -- without a constraint introduced as a generic actual.
1710 -- Examine other discriminants if any.
1713 and then Is_Entity_Name
(ItemS
)
1717 elsif not Is_OK_Static_Expression
(ItemS
)
1718 or else not Is_OK_Static_Expression
(ItemT
)
1722 elsif Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1723 if Do_Access
then -- needs run-time check.
1726 Apply_Compile_Time_Constraint_Error
1727 (N
, "incorrect value for discriminant&??",
1728 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1735 Next_Discriminant
(Discr
);
1744 -- Here we need a discriminant check. First build the expression
1745 -- for the comparisons of the discriminants:
1747 -- (n.disc1 /= typ.disc1) or else
1748 -- (n.disc2 /= typ.disc2) or else
1750 -- (n.discn /= typ.discn)
1752 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1754 -- If Lhs is set and is a parameter, then the condition is guarded by:
1755 -- lhs'constrained and then (condition built above)
1757 if Present
(Param_Entity
(Lhs
)) then
1761 Make_Attribute_Reference
(Loc
,
1762 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1763 Attribute_Name
=> Name_Constrained
),
1764 Right_Opnd
=> Cond
);
1768 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1772 Make_Raise_Constraint_Error
(Loc
,
1774 Reason
=> CE_Discriminant_Check_Failed
));
1775 end Apply_Discriminant_Check
;
1777 -------------------------
1778 -- Apply_Divide_Checks --
1779 -------------------------
1781 procedure Apply_Divide_Checks
(N
: Node_Id
) is
1782 Loc
: constant Source_Ptr
:= Sloc
(N
);
1783 Typ
: constant Entity_Id
:= Etype
(N
);
1784 Left
: constant Node_Id
:= Left_Opnd
(N
);
1785 Right
: constant Node_Id
:= Right_Opnd
(N
);
1787 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1788 -- Current overflow checking mode
1798 pragma Warnings
(Off
, Lhi
);
1799 -- Don't actually use this value
1802 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1803 -- operating on signed integer types, then the only thing this routine
1804 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1805 -- procedure will (possibly later on during recursive downward calls),
1806 -- ensure that any needed overflow/division checks are properly applied.
1808 if Mode
in Minimized_Or_Eliminated
1809 and then Is_Signed_Integer_Type
(Typ
)
1811 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
1815 -- Proceed here in SUPPRESSED or CHECKED modes
1818 and then not Backend_Divide_Checks_On_Target
1819 and then Check_Needed
(Right
, Division_Check
)
1821 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
1823 -- Deal with division check
1825 if Do_Division_Check
(N
)
1826 and then not Division_Checks_Suppressed
(Typ
)
1828 Apply_Division_Check
(N
, Rlo
, Rhi
, ROK
);
1831 -- Deal with overflow check
1833 if Do_Overflow_Check
(N
)
1834 and then not Overflow_Checks_Suppressed
(Etype
(N
))
1836 Set_Do_Overflow_Check
(N
, False);
1838 -- Test for extremely annoying case of xxx'First divided by -1
1839 -- for division of signed integer types (only overflow case).
1841 if Nkind
(N
) = N_Op_Divide
1842 and then Is_Signed_Integer_Type
(Typ
)
1844 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
1845 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1847 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1849 ((not LOK
) or else (Llo
= LLB
))
1852 Make_Raise_Constraint_Error
(Loc
,
1858 Duplicate_Subexpr_Move_Checks
(Left
),
1859 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1863 Left_Opnd
=> Duplicate_Subexpr
(Right
),
1864 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1))),
1866 Reason
=> CE_Overflow_Check_Failed
));
1871 end Apply_Divide_Checks
;
1873 --------------------------
1874 -- Apply_Division_Check --
1875 --------------------------
1877 procedure Apply_Division_Check
1883 pragma Assert
(Do_Division_Check
(N
));
1885 Loc
: constant Source_Ptr
:= Sloc
(N
);
1886 Right
: constant Node_Id
:= Right_Opnd
(N
);
1890 and then not Backend_Divide_Checks_On_Target
1891 and then Check_Needed
(Right
, Division_Check
)
1893 -- See if division by zero possible, and if so generate test. This
1894 -- part of the test is not controlled by the -gnato switch, since
1895 -- it is a Division_Check and not an Overflow_Check.
1897 if Do_Division_Check
(N
) then
1898 Set_Do_Division_Check
(N
, False);
1900 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1902 Make_Raise_Constraint_Error
(Loc
,
1905 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1906 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1907 Reason
=> CE_Divide_By_Zero
));
1911 end Apply_Division_Check
;
1913 ----------------------------------
1914 -- Apply_Float_Conversion_Check --
1915 ----------------------------------
1917 -- Let F and I be the source and target types of the conversion. The RM
1918 -- specifies that a floating-point value X is rounded to the nearest
1919 -- integer, with halfway cases being rounded away from zero. The rounded
1920 -- value of X is checked against I'Range.
1922 -- The catch in the above paragraph is that there is no good way to know
1923 -- whether the round-to-integer operation resulted in overflow. A remedy is
1924 -- to perform a range check in the floating-point domain instead, however:
1926 -- (1) The bounds may not be known at compile time
1927 -- (2) The check must take into account rounding or truncation.
1928 -- (3) The range of type I may not be exactly representable in F.
1929 -- (4) For the rounding case, The end-points I'First - 0.5 and
1930 -- I'Last + 0.5 may or may not be in range, depending on the
1931 -- sign of I'First and I'Last.
1932 -- (5) X may be a NaN, which will fail any comparison
1934 -- The following steps correctly convert X with rounding:
1936 -- (1) If either I'First or I'Last is not known at compile time, use
1937 -- I'Base instead of I in the next three steps and perform a
1938 -- regular range check against I'Range after conversion.
1939 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1940 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1941 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1942 -- In other words, take one of the closest floating-point numbers
1943 -- (which is an integer value) to I'First, and see if it is in
1945 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1946 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1947 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1948 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1949 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1951 -- For the truncating case, replace steps (2) and (3) as follows:
1952 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1953 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1955 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1956 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1959 procedure Apply_Float_Conversion_Check
1961 Target_Typ
: Entity_Id
)
1963 LB
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1964 HB
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1965 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1966 Expr_Type
: constant Entity_Id
:= Base_Type
(Etype
(Ck_Node
));
1967 Target_Base
: constant Entity_Id
:=
1968 Implementation_Base_Type
(Target_Typ
);
1970 Par
: constant Node_Id
:= Parent
(Ck_Node
);
1971 pragma Assert
(Nkind
(Par
) = N_Type_Conversion
);
1972 -- Parent of check node, must be a type conversion
1974 Truncate
: constant Boolean := Float_Truncate
(Par
);
1975 Max_Bound
: constant Uint
:=
1977 (Machine_Radix_Value
(Expr_Type
),
1978 Machine_Mantissa_Value
(Expr_Type
) - 1) - 1;
1980 -- Largest bound, so bound plus or minus half is a machine number of F
1982 Ifirst
, Ilast
: Uint
;
1983 -- Bounds of integer type
1986 -- Bounds to check in floating-point domain
1988 Lo_OK
, Hi_OK
: Boolean;
1989 -- True iff Lo resp. Hi belongs to I'Range
1991 Lo_Chk
, Hi_Chk
: Node_Id
;
1992 -- Expressions that are False iff check fails
1994 Reason
: RT_Exception_Code
;
1997 -- We do not need checks if we are not generating code (i.e. the full
1998 -- expander is not active). In SPARK mode, we specifically don't want
1999 -- the frontend to expand these checks, which are dealt with directly
2000 -- in the formal verification backend.
2002 if not Expander_Active
then
2006 if not Compile_Time_Known_Value
(LB
)
2007 or not Compile_Time_Known_Value
(HB
)
2010 -- First check that the value falls in the range of the base type,
2011 -- to prevent overflow during conversion and then perform a
2012 -- regular range check against the (dynamic) bounds.
2014 pragma Assert
(Target_Base
/= Target_Typ
);
2016 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Par
);
2019 Apply_Float_Conversion_Check
(Ck_Node
, Target_Base
);
2020 Set_Etype
(Temp
, Target_Base
);
2022 Insert_Action
(Parent
(Par
),
2023 Make_Object_Declaration
(Loc
,
2024 Defining_Identifier
=> Temp
,
2025 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
),
2026 Expression
=> New_Copy_Tree
(Par
)),
2027 Suppress
=> All_Checks
);
2030 Make_Raise_Constraint_Error
(Loc
,
2033 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
2034 Right_Opnd
=> New_Occurrence_Of
(Target_Typ
, Loc
)),
2035 Reason
=> CE_Range_Check_Failed
));
2036 Rewrite
(Par
, New_Occurrence_Of
(Temp
, Loc
));
2042 -- Get the (static) bounds of the target type
2044 Ifirst
:= Expr_Value
(LB
);
2045 Ilast
:= Expr_Value
(HB
);
2047 -- A simple optimization: if the expression is a universal literal,
2048 -- we can do the comparison with the bounds and the conversion to
2049 -- an integer type statically. The range checks are unchanged.
2051 if Nkind
(Ck_Node
) = N_Real_Literal
2052 and then Etype
(Ck_Node
) = Universal_Real
2053 and then Is_Integer_Type
(Target_Typ
)
2054 and then Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
2057 Int_Val
: constant Uint
:= UR_To_Uint
(Realval
(Ck_Node
));
2060 if Int_Val
<= Ilast
and then Int_Val
>= Ifirst
then
2062 -- Conversion is safe
2064 Rewrite
(Parent
(Ck_Node
),
2065 Make_Integer_Literal
(Loc
, UI_To_Int
(Int_Val
)));
2066 Analyze_And_Resolve
(Parent
(Ck_Node
), Target_Typ
);
2072 -- Check against lower bound
2074 if Truncate
and then Ifirst
> 0 then
2075 Lo
:= Pred
(Expr_Type
, UR_From_Uint
(Ifirst
));
2079 Lo
:= Succ
(Expr_Type
, UR_From_Uint
(Ifirst
- 1));
2082 elsif abs (Ifirst
) < Max_Bound
then
2083 Lo
:= UR_From_Uint
(Ifirst
) - Ureal_Half
;
2084 Lo_OK
:= (Ifirst
> 0);
2087 Lo
:= Machine
(Expr_Type
, UR_From_Uint
(Ifirst
), Round_Even
, Ck_Node
);
2088 Lo_OK
:= (Lo
>= UR_From_Uint
(Ifirst
));
2093 -- Lo_Chk := (X >= Lo)
2095 Lo_Chk
:= Make_Op_Ge
(Loc
,
2096 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2097 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2100 -- Lo_Chk := (X > Lo)
2102 Lo_Chk
:= Make_Op_Gt
(Loc
,
2103 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2104 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2107 -- Check against higher bound
2109 if Truncate
and then Ilast
< 0 then
2110 Hi
:= Succ
(Expr_Type
, UR_From_Uint
(Ilast
));
2114 Hi
:= Pred
(Expr_Type
, UR_From_Uint
(Ilast
+ 1));
2117 elsif abs (Ilast
) < Max_Bound
then
2118 Hi
:= UR_From_Uint
(Ilast
) + Ureal_Half
;
2119 Hi_OK
:= (Ilast
< 0);
2121 Hi
:= Machine
(Expr_Type
, UR_From_Uint
(Ilast
), Round_Even
, Ck_Node
);
2122 Hi_OK
:= (Hi
<= UR_From_Uint
(Ilast
));
2127 -- Hi_Chk := (X <= Hi)
2129 Hi_Chk
:= Make_Op_Le
(Loc
,
2130 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2131 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2134 -- Hi_Chk := (X < Hi)
2136 Hi_Chk
:= Make_Op_Lt
(Loc
,
2137 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2138 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2141 -- If the bounds of the target type are the same as those of the base
2142 -- type, the check is an overflow check as a range check is not
2143 -- performed in these cases.
2145 if Expr_Value
(Type_Low_Bound
(Target_Base
)) = Ifirst
2146 and then Expr_Value
(Type_High_Bound
(Target_Base
)) = Ilast
2148 Reason
:= CE_Overflow_Check_Failed
;
2150 Reason
:= CE_Range_Check_Failed
;
2153 -- Raise CE if either conditions does not hold
2155 Insert_Action
(Ck_Node
,
2156 Make_Raise_Constraint_Error
(Loc
,
2157 Condition
=> Make_Op_Not
(Loc
, Make_And_Then
(Loc
, Lo_Chk
, Hi_Chk
)),
2159 end Apply_Float_Conversion_Check
;
2161 ------------------------
2162 -- Apply_Length_Check --
2163 ------------------------
2165 procedure Apply_Length_Check
2167 Target_Typ
: Entity_Id
;
2168 Source_Typ
: Entity_Id
:= Empty
)
2171 Apply_Selected_Length_Checks
2172 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2173 end Apply_Length_Check
;
2175 -------------------------------------
2176 -- Apply_Parameter_Aliasing_Checks --
2177 -------------------------------------
2179 procedure Apply_Parameter_Aliasing_Checks
2183 Loc
: constant Source_Ptr
:= Sloc
(Call
);
2185 function May_Cause_Aliasing
2186 (Formal_1
: Entity_Id
;
2187 Formal_2
: Entity_Id
) return Boolean;
2188 -- Determine whether two formal parameters can alias each other
2189 -- depending on their modes.
2191 function Original_Actual
(N
: Node_Id
) return Node_Id
;
2192 -- The expander may replace an actual with a temporary for the sake of
2193 -- side effect removal. The temporary may hide a potential aliasing as
2194 -- it does not share the address of the actual. This routine attempts
2195 -- to retrieve the original actual.
2197 procedure Overlap_Check
2198 (Actual_1
: Node_Id
;
2200 Formal_1
: Entity_Id
;
2201 Formal_2
: Entity_Id
;
2202 Check
: in out Node_Id
);
2203 -- Create a check to determine whether Actual_1 overlaps with Actual_2.
2204 -- If detailed exception messages are enabled, the check is augmented to
2205 -- provide information about the names of the corresponding formals. See
2206 -- the body for details. Actual_1 and Actual_2 denote the two actuals to
2207 -- be tested. Formal_1 and Formal_2 denote the corresponding formals.
2208 -- Check contains all and-ed simple tests generated so far or remains
2209 -- unchanged in the case of detailed exception messaged.
2211 ------------------------
2212 -- May_Cause_Aliasing --
2213 ------------------------
2215 function May_Cause_Aliasing
2216 (Formal_1
: Entity_Id
;
2217 Formal_2
: Entity_Id
) return Boolean
2220 -- The following combination cannot lead to aliasing
2222 -- Formal 1 Formal 2
2225 if Ekind
(Formal_1
) = E_In_Parameter
2227 Ekind
(Formal_2
) = E_In_Parameter
2231 -- The following combinations may lead to aliasing
2233 -- Formal 1 Formal 2
2243 end May_Cause_Aliasing
;
2245 ---------------------
2246 -- Original_Actual --
2247 ---------------------
2249 function Original_Actual
(N
: Node_Id
) return Node_Id
is
2251 if Nkind
(N
) = N_Type_Conversion
then
2252 return Expression
(N
);
2254 -- The expander created a temporary to capture the result of a type
2255 -- conversion where the expression is the real actual.
2257 elsif Nkind
(N
) = N_Identifier
2258 and then Present
(Original_Node
(N
))
2259 and then Nkind
(Original_Node
(N
)) = N_Type_Conversion
2261 return Expression
(Original_Node
(N
));
2265 end Original_Actual
;
2271 procedure Overlap_Check
2272 (Actual_1
: Node_Id
;
2274 Formal_1
: Entity_Id
;
2275 Formal_2
: Entity_Id
;
2276 Check
: in out Node_Id
)
2279 ID_Casing
: constant Casing_Type
:=
2280 Identifier_Casing
(Source_Index
(Current_Sem_Unit
));
2284 -- Actual_1'Overlaps_Storage (Actual_2)
2287 Make_Attribute_Reference
(Loc
,
2288 Prefix
=> New_Copy_Tree
(Original_Actual
(Actual_1
)),
2289 Attribute_Name
=> Name_Overlaps_Storage
,
2291 New_List
(New_Copy_Tree
(Original_Actual
(Actual_2
))));
2293 -- Generate the following check when detailed exception messages are
2296 -- if Actual_1'Overlaps_Storage (Actual_2) then
2297 -- raise Program_Error with <detailed message>;
2300 if Exception_Extra_Info
then
2303 -- Do not generate location information for internal calls
2305 if Comes_From_Source
(Call
) then
2306 Store_String_Chars
(Build_Location_String
(Loc
));
2307 Store_String_Char
(' ');
2310 Store_String_Chars
("aliased parameters, actuals for """);
2312 Get_Name_String
(Chars
(Formal_1
));
2313 Set_Casing
(ID_Casing
);
2314 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2316 Store_String_Chars
(""" and """);
2318 Get_Name_String
(Chars
(Formal_2
));
2319 Set_Casing
(ID_Casing
);
2320 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2322 Store_String_Chars
(""" overlap");
2324 Insert_Action
(Call
,
2325 Make_If_Statement
(Loc
,
2327 Then_Statements
=> New_List
(
2328 Make_Raise_Statement
(Loc
,
2330 New_Occurrence_Of
(Standard_Program_Error
, Loc
),
2331 Expression
=> Make_String_Literal
(Loc
, End_String
)))));
2333 -- Create a sequence of overlapping checks by and-ing them all
2343 Right_Opnd
=> Cond
);
2353 Formal_1
: Entity_Id
;
2354 Formal_2
: Entity_Id
;
2356 -- Start of processing for Apply_Parameter_Aliasing_Checks
2361 Actual_1
:= First_Actual
(Call
);
2362 Formal_1
:= First_Formal
(Subp
);
2363 while Present
(Actual_1
) and then Present
(Formal_1
) loop
2365 -- Ensure that the actual is an object that is not passed by value.
2366 -- Elementary types are always passed by value, therefore actuals of
2367 -- such types cannot lead to aliasing.
2369 if Is_Object_Reference
(Original_Actual
(Actual_1
))
2370 and then not Is_Elementary_Type
(Etype
(Original_Actual
(Actual_1
)))
2372 Actual_2
:= Next_Actual
(Actual_1
);
2373 Formal_2
:= Next_Formal
(Formal_1
);
2374 while Present
(Actual_2
) and then Present
(Formal_2
) loop
2376 -- The other actual we are testing against must also denote
2377 -- a non pass-by-value object. Generate the check only when
2378 -- the mode of the two formals may lead to aliasing.
2380 if Is_Object_Reference
(Original_Actual
(Actual_2
))
2382 Is_Elementary_Type
(Etype
(Original_Actual
(Actual_2
)))
2383 and then May_Cause_Aliasing
(Formal_1
, Formal_2
)
2386 (Actual_1
=> Actual_1
,
2387 Actual_2
=> Actual_2
,
2388 Formal_1
=> Formal_1
,
2389 Formal_2
=> Formal_2
,
2393 Next_Actual
(Actual_2
);
2394 Next_Formal
(Formal_2
);
2398 Next_Actual
(Actual_1
);
2399 Next_Formal
(Formal_1
);
2402 -- Place a simple check right before the call
2404 if Present
(Check
) and then not Exception_Extra_Info
then
2405 Insert_Action
(Call
,
2406 Make_Raise_Program_Error
(Loc
,
2408 Reason
=> PE_Aliased_Parameters
));
2410 end Apply_Parameter_Aliasing_Checks
;
2412 -------------------------------------
2413 -- Apply_Parameter_Validity_Checks --
2414 -------------------------------------
2416 procedure Apply_Parameter_Validity_Checks
(Subp
: Entity_Id
) is
2417 Subp_Decl
: Node_Id
;
2419 procedure Add_Validity_Check
2420 (Context
: Entity_Id
;
2422 For_Result
: Boolean := False);
2423 -- Add a single 'Valid[_Scalar] check which verifies the initialization
2424 -- of Context. PPC_Nam denotes the pre or post condition pragma name.
2425 -- Set flag For_Result when to verify the result of a function.
2427 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
);
2428 -- Create a pre or post condition pragma with name PPC_Nam which
2429 -- tests expression Check.
2431 ------------------------
2432 -- Add_Validity_Check --
2433 ------------------------
2435 procedure Add_Validity_Check
2436 (Context
: Entity_Id
;
2438 For_Result
: Boolean := False)
2440 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2441 Typ
: constant Entity_Id
:= Etype
(Context
);
2446 -- For scalars, generate 'Valid test
2448 if Is_Scalar_Type
(Typ
) then
2451 -- For any non-scalar with scalar parts, generate 'Valid_Scalars test
2453 elsif Scalar_Part_Present
(Typ
) then
2454 Nam
:= Name_Valid_Scalars
;
2456 -- No test needed for other cases (no scalars to test)
2462 -- Step 1: Create the expression to verify the validity of the
2465 Check
:= New_Occurrence_Of
(Context
, Loc
);
2467 -- When processing a function result, use 'Result. Generate
2472 Make_Attribute_Reference
(Loc
,
2474 Attribute_Name
=> Name_Result
);
2478 -- Context['Result]'Valid[_Scalars]
2481 Make_Attribute_Reference
(Loc
,
2483 Attribute_Name
=> Nam
);
2485 -- Step 2: Create a pre or post condition pragma
2487 Build_PPC_Pragma
(PPC_Nam
, Check
);
2488 end Add_Validity_Check
;
2490 ----------------------
2491 -- Build_PPC_Pragma --
2492 ----------------------
2494 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
) is
2495 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2502 Pragma_Identifier
=> Make_Identifier
(Loc
, PPC_Nam
),
2503 Pragma_Argument_Associations
=> New_List
(
2504 Make_Pragma_Argument_Association
(Loc
,
2505 Chars
=> Name_Check
,
2506 Expression
=> Check
)));
2508 -- Add a message unless exception messages are suppressed
2510 if not Exception_Locations_Suppressed
then
2511 Append_To
(Pragma_Argument_Associations
(Prag
),
2512 Make_Pragma_Argument_Association
(Loc
,
2513 Chars
=> Name_Message
,
2515 Make_String_Literal
(Loc
,
2516 Strval
=> "failed " & Get_Name_String
(PPC_Nam
) &
2517 " from " & Build_Location_String
(Loc
))));
2520 -- Insert the pragma in the tree
2522 if Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
then
2523 Add_Global_Declaration
(Prag
);
2526 -- PPC pragmas associated with subprogram bodies must be inserted in
2527 -- the declarative part of the body.
2529 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
then
2530 Decls
:= Declarations
(Subp_Decl
);
2534 Set_Declarations
(Subp_Decl
, Decls
);
2537 Prepend_To
(Decls
, Prag
);
2539 -- Ensure the proper visibility of the subprogram body and its
2546 -- For subprogram declarations insert the PPC pragma right after the
2547 -- declarative node.
2550 Insert_After_And_Analyze
(Subp_Decl
, Prag
);
2552 end Build_PPC_Pragma
;
2557 Subp_Spec
: Node_Id
;
2559 -- Start of processing for Apply_Parameter_Validity_Checks
2562 -- Extract the subprogram specification and declaration nodes
2564 Subp_Spec
:= Parent
(Subp
);
2566 if Nkind
(Subp_Spec
) = N_Defining_Program_Unit_Name
then
2567 Subp_Spec
:= Parent
(Subp_Spec
);
2570 Subp_Decl
:= Parent
(Subp_Spec
);
2572 if not Comes_From_Source
(Subp
)
2574 -- Do not process formal subprograms because the corresponding actual
2575 -- will receive the proper checks when the instance is analyzed.
2577 or else Is_Formal_Subprogram
(Subp
)
2579 -- Do not process imported subprograms since pre and post conditions
2580 -- are never verified on routines coming from a different language.
2582 or else Is_Imported
(Subp
)
2583 or else Is_Intrinsic_Subprogram
(Subp
)
2585 -- The PPC pragmas generated by this routine do not correspond to
2586 -- source aspects, therefore they cannot be applied to abstract
2589 or else Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
2591 -- Do not consider subprogram renaminds because the renamed entity
2592 -- already has the proper PPC pragmas.
2594 or else Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
2596 -- Do not process null procedures because there is no benefit of
2597 -- adding the checks to a no action routine.
2599 or else (Nkind
(Subp_Spec
) = N_Procedure_Specification
2600 and then Null_Present
(Subp_Spec
))
2605 -- Inspect all the formals applying aliasing and scalar initialization
2606 -- checks where applicable.
2608 Formal
:= First_Formal
(Subp
);
2609 while Present
(Formal
) loop
2611 -- Generate the following scalar initialization checks for each
2612 -- formal parameter:
2614 -- mode IN - Pre => Formal'Valid[_Scalars]
2615 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2616 -- mode OUT - Post => Formal'Valid[_Scalars]
2618 if Check_Validity_Of_Parameters
then
2619 if Ekind_In
(Formal
, E_In_Parameter
, E_In_Out_Parameter
) then
2620 Add_Validity_Check
(Formal
, Name_Precondition
, False);
2623 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
2624 Add_Validity_Check
(Formal
, Name_Postcondition
, False);
2628 Next_Formal
(Formal
);
2631 -- Generate following scalar initialization check for function result:
2633 -- Post => Subp'Result'Valid[_Scalars]
2635 if Check_Validity_Of_Parameters
and then Ekind
(Subp
) = E_Function
then
2636 Add_Validity_Check
(Subp
, Name_Postcondition
, True);
2638 end Apply_Parameter_Validity_Checks
;
2640 ---------------------------
2641 -- Apply_Predicate_Check --
2642 ---------------------------
2644 procedure Apply_Predicate_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
2648 if Present
(Predicate_Function
(Typ
)) then
2651 while Present
(S
) and then not Is_Subprogram
(S
) loop
2655 -- A predicate check does not apply within internally generated
2656 -- subprograms, such as TSS functions.
2658 if Within_Internal_Subprogram
then
2661 -- If the check appears within the predicate function itself, it
2662 -- means that the user specified a check whose formal is the
2663 -- predicated subtype itself, rather than some covering type. This
2664 -- is likely to be a common error, and thus deserves a warning.
2666 elsif Present
(S
) and then S
= Predicate_Function
(Typ
) then
2668 ("predicate check includes a function call that "
2669 & "requires a predicate check??", Parent
(N
));
2671 ("\this will result in infinite recursion??", Parent
(N
));
2673 Make_Raise_Storage_Error
(Sloc
(N
),
2674 Reason
=> SE_Infinite_Recursion
));
2676 -- Here for normal case of predicate active
2679 -- If the type has a static predicate and the expression is known
2680 -- at compile time, see if the expression satisfies the predicate.
2682 Check_Expression_Against_Static_Predicate
(N
, Typ
);
2685 Make_Predicate_Check
(Typ
, Duplicate_Subexpr
(N
)));
2688 end Apply_Predicate_Check
;
2690 -----------------------
2691 -- Apply_Range_Check --
2692 -----------------------
2694 procedure Apply_Range_Check
2696 Target_Typ
: Entity_Id
;
2697 Source_Typ
: Entity_Id
:= Empty
)
2700 Apply_Selected_Range_Checks
2701 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2702 end Apply_Range_Check
;
2704 ------------------------------
2705 -- Apply_Scalar_Range_Check --
2706 ------------------------------
2708 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
2709 -- off if it is already set on.
2711 procedure Apply_Scalar_Range_Check
2713 Target_Typ
: Entity_Id
;
2714 Source_Typ
: Entity_Id
:= Empty
;
2715 Fixed_Int
: Boolean := False)
2717 Parnt
: constant Node_Id
:= Parent
(Expr
);
2719 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
2720 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
2723 Is_Subscr_Ref
: Boolean;
2724 -- Set true if Expr is a subscript
2726 Is_Unconstrained_Subscr_Ref
: Boolean;
2727 -- Set true if Expr is a subscript of an unconstrained array. In this
2728 -- case we do not attempt to do an analysis of the value against the
2729 -- range of the subscript, since we don't know the actual subtype.
2732 -- Set to True if Expr should be regarded as a real value even though
2733 -- the type of Expr might be discrete.
2735 procedure Bad_Value
;
2736 -- Procedure called if value is determined to be out of range
2742 procedure Bad_Value
is
2744 Apply_Compile_Time_Constraint_Error
2745 (Expr
, "value not in range of}??", CE_Range_Check_Failed
,
2750 -- Start of processing for Apply_Scalar_Range_Check
2753 -- Return if check obviously not needed
2756 -- Not needed inside generic
2760 -- Not needed if previous error
2762 or else Target_Typ
= Any_Type
2763 or else Nkind
(Expr
) = N_Error
2765 -- Not needed for non-scalar type
2767 or else not Is_Scalar_Type
(Target_Typ
)
2769 -- Not needed if we know node raises CE already
2771 or else Raises_Constraint_Error
(Expr
)
2776 -- Now, see if checks are suppressed
2779 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
2781 if Is_Subscr_Ref
then
2782 Arr
:= Prefix
(Parnt
);
2783 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
2785 if Is_Access_Type
(Arr_Typ
) then
2786 Arr_Typ
:= Designated_Type
(Arr_Typ
);
2790 if not Do_Range_Check
(Expr
) then
2792 -- Subscript reference. Check for Index_Checks suppressed
2794 if Is_Subscr_Ref
then
2796 -- Check array type and its base type
2798 if Index_Checks_Suppressed
(Arr_Typ
)
2799 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
2803 -- Check array itself if it is an entity name
2805 elsif Is_Entity_Name
(Arr
)
2806 and then Index_Checks_Suppressed
(Entity
(Arr
))
2810 -- Check expression itself if it is an entity name
2812 elsif Is_Entity_Name
(Expr
)
2813 and then Index_Checks_Suppressed
(Entity
(Expr
))
2818 -- All other cases, check for Range_Checks suppressed
2821 -- Check target type and its base type
2823 if Range_Checks_Suppressed
(Target_Typ
)
2824 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
2828 -- Check expression itself if it is an entity name
2830 elsif Is_Entity_Name
(Expr
)
2831 and then Range_Checks_Suppressed
(Entity
(Expr
))
2835 -- If Expr is part of an assignment statement, then check left
2836 -- side of assignment if it is an entity name.
2838 elsif Nkind
(Parnt
) = N_Assignment_Statement
2839 and then Is_Entity_Name
(Name
(Parnt
))
2840 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
2847 -- Do not set range checks if they are killed
2849 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
2850 and then Kill_Range_Check
(Expr
)
2855 -- Do not set range checks for any values from System.Scalar_Values
2856 -- since the whole idea of such values is to avoid checking them.
2858 if Is_Entity_Name
(Expr
)
2859 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
2864 -- Now see if we need a check
2866 if No
(Source_Typ
) then
2867 S_Typ
:= Etype
(Expr
);
2869 S_Typ
:= Source_Typ
;
2872 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
2876 Is_Unconstrained_Subscr_Ref
:=
2877 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
2879 -- Special checks for floating-point type
2881 if Is_Floating_Point_Type
(S_Typ
) then
2883 -- Always do a range check if the source type includes infinities and
2884 -- the target type does not include infinities. We do not do this if
2885 -- range checks are killed.
2887 if Has_Infinities
(S_Typ
)
2888 and then not Has_Infinities
(Target_Typ
)
2890 Enable_Range_Check
(Expr
);
2894 -- Return if we know expression is definitely in the range of the target
2895 -- type as determined by Determine_Range. Right now we only do this for
2896 -- discrete types, and not fixed-point or floating-point types.
2898 -- The additional less-precise tests below catch these cases
2900 -- Note: skip this if we are given a source_typ, since the point of
2901 -- supplying a Source_Typ is to stop us looking at the expression.
2902 -- We could sharpen this test to be out parameters only ???
2904 if Is_Discrete_Type
(Target_Typ
)
2905 and then Is_Discrete_Type
(Etype
(Expr
))
2906 and then not Is_Unconstrained_Subscr_Ref
2907 and then No
(Source_Typ
)
2910 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
2911 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
2916 if Compile_Time_Known_Value
(Tlo
)
2917 and then Compile_Time_Known_Value
(Thi
)
2920 Lov
: constant Uint
:= Expr_Value
(Tlo
);
2921 Hiv
: constant Uint
:= Expr_Value
(Thi
);
2924 -- If range is null, we for sure have a constraint error
2925 -- (we don't even need to look at the value involved,
2926 -- since all possible values will raise CE).
2930 -- In GNATprove mode, do not issue a message in that case
2931 -- (which would be an error stopping analysis), as this
2932 -- likely corresponds to deactivated code based on a
2933 -- given configuration (say, dead code inside a loop over
2934 -- the empty range). Instead, we enable the range check
2935 -- so that GNATprove will issue a message if it cannot be
2938 if GNATprove_Mode
then
2939 Enable_Range_Check
(Expr
);
2947 -- Otherwise determine range of value
2949 Determine_Range
(Expr
, OK
, Lo
, Hi
, Assume_Valid
=> True);
2953 -- If definitely in range, all OK
2955 if Lo
>= Lov
and then Hi
<= Hiv
then
2958 -- If definitely not in range, warn
2960 elsif Lov
> Hi
or else Hiv
< Lo
then
2964 -- Otherwise we don't know
2976 Is_Floating_Point_Type
(S_Typ
)
2977 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
2979 -- Check if we can determine at compile time whether Expr is in the
2980 -- range of the target type. Note that if S_Typ is within the bounds
2981 -- of Target_Typ then this must be the case. This check is meaningful
2982 -- only if this is not a conversion between integer and real types.
2984 if not Is_Unconstrained_Subscr_Ref
2985 and then Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
2987 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
2989 -- Also check if the expression itself is in the range of the
2990 -- target type if it is a known at compile time value. We skip
2991 -- this test if S_Typ is set since for OUT and IN OUT parameters
2992 -- the Expr itself is not relevant to the checking.
2996 and then Is_In_Range
(Expr
, Target_Typ
,
2997 Assume_Valid
=> True,
2998 Fixed_Int
=> Fixed_Int
,
2999 Int_Real
=> Int_Real
)))
3003 elsif Is_Out_Of_Range
(Expr
, Target_Typ
,
3004 Assume_Valid
=> True,
3005 Fixed_Int
=> Fixed_Int
,
3006 Int_Real
=> Int_Real
)
3011 -- Floating-point case
3012 -- In the floating-point case, we only do range checks if the type is
3013 -- constrained. We definitely do NOT want range checks for unconstrained
3014 -- types, since we want to have infinities
3016 elsif Is_Floating_Point_Type
(S_Typ
) then
3018 -- Normally, we only do range checks if the type is constrained. We do
3019 -- NOT want range checks for unconstrained types, since we want to have
3022 if Is_Constrained
(S_Typ
) then
3023 Enable_Range_Check
(Expr
);
3026 -- For all other cases we enable a range check unconditionally
3029 Enable_Range_Check
(Expr
);
3032 end Apply_Scalar_Range_Check
;
3034 ----------------------------------
3035 -- Apply_Selected_Length_Checks --
3036 ----------------------------------
3038 procedure Apply_Selected_Length_Checks
3040 Target_Typ
: Entity_Id
;
3041 Source_Typ
: Entity_Id
;
3042 Do_Static
: Boolean)
3045 R_Result
: Check_Result
;
3048 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
3049 Checks_On
: constant Boolean :=
3050 (not Index_Checks_Suppressed
(Target_Typ
))
3051 or else (not Length_Checks_Suppressed
(Target_Typ
));
3054 -- Note: this means that we lose some useful warnings if the expander
3055 -- is not active, and we also lose these warnings in SPARK mode ???
3057 if not Expander_Active
then
3062 Selected_Length_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
3064 for J
in 1 .. 2 loop
3065 R_Cno
:= R_Result
(J
);
3066 exit when No
(R_Cno
);
3068 -- A length check may mention an Itype which is attached to a
3069 -- subsequent node. At the top level in a package this can cause
3070 -- an order-of-elaboration problem, so we make sure that the itype
3071 -- is referenced now.
3073 if Ekind
(Current_Scope
) = E_Package
3074 and then Is_Compilation_Unit
(Current_Scope
)
3076 Ensure_Defined
(Target_Typ
, Ck_Node
);
3078 if Present
(Source_Typ
) then
3079 Ensure_Defined
(Source_Typ
, Ck_Node
);
3081 elsif Is_Itype
(Etype
(Ck_Node
)) then
3082 Ensure_Defined
(Etype
(Ck_Node
), Ck_Node
);
3086 -- If the item is a conditional raise of constraint error, then have
3087 -- a look at what check is being performed and ???
3089 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
3090 and then Present
(Condition
(R_Cno
))
3092 Cond
:= Condition
(R_Cno
);
3094 -- Case where node does not now have a dynamic check
3096 if not Has_Dynamic_Length_Check
(Ck_Node
) then
3098 -- If checks are on, just insert the check
3101 Insert_Action
(Ck_Node
, R_Cno
);
3103 if not Do_Static
then
3104 Set_Has_Dynamic_Length_Check
(Ck_Node
);
3107 -- If checks are off, then analyze the length check after
3108 -- temporarily attaching it to the tree in case the relevant
3109 -- condition can be evaluated at compile time. We still want a
3110 -- compile time warning in this case.
3113 Set_Parent
(R_Cno
, Ck_Node
);
3118 -- Output a warning if the condition is known to be True
3120 if Is_Entity_Name
(Cond
)
3121 and then Entity
(Cond
) = Standard_True
3123 Apply_Compile_Time_Constraint_Error
3124 (Ck_Node
, "wrong length for array of}??",
3125 CE_Length_Check_Failed
,
3129 -- If we were only doing a static check, or if checks are not
3130 -- on, then we want to delete the check, since it is not needed.
3131 -- We do this by replacing the if statement by a null statement
3133 elsif Do_Static
or else not Checks_On
then
3134 Remove_Warning_Messages
(R_Cno
);
3135 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3139 Install_Static_Check
(R_Cno
, Loc
);
3142 end Apply_Selected_Length_Checks
;
3144 ---------------------------------
3145 -- Apply_Selected_Range_Checks --
3146 ---------------------------------
3148 procedure Apply_Selected_Range_Checks
3150 Target_Typ
: Entity_Id
;
3151 Source_Typ
: Entity_Id
;
3152 Do_Static
: Boolean)
3154 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
3155 Checks_On
: constant Boolean :=
3156 not Index_Checks_Suppressed
(Target_Typ
)
3158 not Range_Checks_Suppressed
(Target_Typ
);
3162 R_Result
: Check_Result
;
3165 if not Expander_Active
or not Checks_On
then
3170 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
3172 for J
in 1 .. 2 loop
3173 R_Cno
:= R_Result
(J
);
3174 exit when No
(R_Cno
);
3176 -- The range check requires runtime evaluation. Depending on what its
3177 -- triggering condition is, the check may be converted into a compile
3178 -- time constraint check.
3180 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
3181 and then Present
(Condition
(R_Cno
))
3183 Cond
:= Condition
(R_Cno
);
3185 -- Insert the range check before the related context. Note that
3186 -- this action analyses the triggering condition.
3188 Insert_Action
(Ck_Node
, R_Cno
);
3190 -- This old code doesn't make sense, why is the context flagged as
3191 -- requiring dynamic range checks now in the middle of generating
3194 if not Do_Static
then
3195 Set_Has_Dynamic_Range_Check
(Ck_Node
);
3198 -- The triggering condition evaluates to True, the range check
3199 -- can be converted into a compile time constraint check.
3201 if Is_Entity_Name
(Cond
)
3202 and then Entity
(Cond
) = Standard_True
3204 -- Since an N_Range is technically not an expression, we have
3205 -- to set one of the bounds to C_E and then just flag the
3206 -- N_Range. The warning message will point to the lower bound
3207 -- and complain about a range, which seems OK.
3209 if Nkind
(Ck_Node
) = N_Range
then
3210 Apply_Compile_Time_Constraint_Error
3211 (Low_Bound
(Ck_Node
),
3212 "static range out of bounds of}??",
3213 CE_Range_Check_Failed
,
3217 Set_Raises_Constraint_Error
(Ck_Node
);
3220 Apply_Compile_Time_Constraint_Error
3222 "static value out of range of}??",
3223 CE_Range_Check_Failed
,
3228 -- If we were only doing a static check, or if checks are not
3229 -- on, then we want to delete the check, since it is not needed.
3230 -- We do this by replacing the if statement by a null statement
3232 -- Why are we even generating checks if checks are turned off ???
3234 elsif Do_Static
or else not Checks_On
then
3235 Remove_Warning_Messages
(R_Cno
);
3236 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3239 -- The range check raises Constrant_Error explicitly
3242 Install_Static_Check
(R_Cno
, Loc
);
3245 end Apply_Selected_Range_Checks
;
3247 -------------------------------
3248 -- Apply_Static_Length_Check --
3249 -------------------------------
3251 procedure Apply_Static_Length_Check
3253 Target_Typ
: Entity_Id
;
3254 Source_Typ
: Entity_Id
:= Empty
)
3257 Apply_Selected_Length_Checks
3258 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
3259 end Apply_Static_Length_Check
;
3261 -------------------------------------
3262 -- Apply_Subscript_Validity_Checks --
3263 -------------------------------------
3265 procedure Apply_Subscript_Validity_Checks
(Expr
: Node_Id
) is
3269 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
3271 -- Loop through subscripts
3273 Sub
:= First
(Expressions
(Expr
));
3274 while Present
(Sub
) loop
3276 -- Check one subscript. Note that we do not worry about enumeration
3277 -- type with holes, since we will convert the value to a Pos value
3278 -- for the subscript, and that convert will do the necessary validity
3281 Ensure_Valid
(Sub
, Holes_OK
=> True);
3283 -- Move to next subscript
3287 end Apply_Subscript_Validity_Checks
;
3289 ----------------------------------
3290 -- Apply_Type_Conversion_Checks --
3291 ----------------------------------
3293 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
3294 Target_Type
: constant Entity_Id
:= Etype
(N
);
3295 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
3296 Expr
: constant Node_Id
:= Expression
(N
);
3298 Expr_Type
: constant Entity_Id
:= Underlying_Type
(Etype
(Expr
));
3299 -- Note: if Etype (Expr) is a private type without discriminants, its
3300 -- full view might have discriminants with defaults, so we need the
3301 -- full view here to retrieve the constraints.
3304 if Inside_A_Generic
then
3307 -- Skip these checks if serious errors detected, there are some nasty
3308 -- situations of incomplete trees that blow things up.
3310 elsif Serious_Errors_Detected
> 0 then
3313 -- Never generate discriminant checks for Unchecked_Union types
3315 elsif Present
(Expr_Type
)
3316 and then Is_Unchecked_Union
(Expr_Type
)
3320 -- Scalar type conversions of the form Target_Type (Expr) require a
3321 -- range check if we cannot be sure that Expr is in the base type of
3322 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3323 -- are not quite the same condition from an implementation point of
3324 -- view, but clearly the second includes the first.
3326 elsif Is_Scalar_Type
(Target_Type
) then
3328 Conv_OK
: constant Boolean := Conversion_OK
(N
);
3329 -- If the Conversion_OK flag on the type conversion is set and no
3330 -- floating-point type is involved in the type conversion then
3331 -- fixed-point values must be read as integral values.
3333 Float_To_Int
: constant Boolean :=
3334 Is_Floating_Point_Type
(Expr_Type
)
3335 and then Is_Integer_Type
(Target_Type
);
3338 if not Overflow_Checks_Suppressed
(Target_Base
)
3339 and then not Overflow_Checks_Suppressed
(Target_Type
)
3341 In_Subrange_Of
(Expr_Type
, Target_Base
, Fixed_Int
=> Conv_OK
)
3342 and then not Float_To_Int
3344 Activate_Overflow_Check
(N
);
3347 if not Range_Checks_Suppressed
(Target_Type
)
3348 and then not Range_Checks_Suppressed
(Expr_Type
)
3350 if Float_To_Int
then
3351 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
3353 Apply_Scalar_Range_Check
3354 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
3356 -- If the target type has predicates, we need to indicate
3357 -- the need for a check, even if Determine_Range finds that
3358 -- the value is within bounds. This may be the case e.g for
3359 -- a division with a constant denominator.
3361 if Has_Predicates
(Target_Type
) then
3362 Enable_Range_Check
(Expr
);
3368 elsif Comes_From_Source
(N
)
3369 and then not Discriminant_Checks_Suppressed
(Target_Type
)
3370 and then Is_Record_Type
(Target_Type
)
3371 and then Is_Derived_Type
(Target_Type
)
3372 and then not Is_Tagged_Type
(Target_Type
)
3373 and then not Is_Constrained
(Target_Type
)
3374 and then Present
(Stored_Constraint
(Target_Type
))
3376 -- An unconstrained derived type may have inherited discriminant.
3377 -- Build an actual discriminant constraint list using the stored
3378 -- constraint, to verify that the expression of the parent type
3379 -- satisfies the constraints imposed by the (unconstrained) derived
3380 -- type. This applies to value conversions, not to view conversions
3384 Loc
: constant Source_Ptr
:= Sloc
(N
);
3386 Constraint
: Elmt_Id
;
3387 Discr_Value
: Node_Id
;
3390 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
3391 Old_Constraints
: constant Elist_Id
:=
3392 Discriminant_Constraint
(Expr_Type
);
3395 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
3396 while Present
(Constraint
) loop
3397 Discr_Value
:= Node
(Constraint
);
3399 if Is_Entity_Name
(Discr_Value
)
3400 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
3402 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
3405 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
3407 -- Parent is constrained by new discriminant. Obtain
3408 -- Value of original discriminant in expression. If the
3409 -- new discriminant has been used to constrain more than
3410 -- one of the stored discriminants, this will provide the
3411 -- required consistency check.
3414 (Make_Selected_Component
(Loc
,
3416 Duplicate_Subexpr_No_Checks
3417 (Expr
, Name_Req
=> True),
3419 Make_Identifier
(Loc
, Chars
(Discr
))),
3423 -- Discriminant of more remote ancestor ???
3428 -- Derived type definition has an explicit value for this
3429 -- stored discriminant.
3433 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
3437 Next_Elmt
(Constraint
);
3440 -- Use the unconstrained expression type to retrieve the
3441 -- discriminants of the parent, and apply momentarily the
3442 -- discriminant constraint synthesized above.
3444 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
3445 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
3446 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
3449 Make_Raise_Constraint_Error
(Loc
,
3451 Reason
=> CE_Discriminant_Check_Failed
));
3454 -- For arrays, checks are set now, but conversions are applied during
3455 -- expansion, to take into accounts changes of representation. The
3456 -- checks become range checks on the base type or length checks on the
3457 -- subtype, depending on whether the target type is unconstrained or
3458 -- constrained. Note that the range check is put on the expression of a
3459 -- type conversion, while the length check is put on the type conversion
3462 elsif Is_Array_Type
(Target_Type
) then
3463 if Is_Constrained
(Target_Type
) then
3464 Set_Do_Length_Check
(N
);
3466 Set_Do_Range_Check
(Expr
);
3469 end Apply_Type_Conversion_Checks
;
3471 ----------------------------------------------
3472 -- Apply_Universal_Integer_Attribute_Checks --
3473 ----------------------------------------------
3475 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
3476 Loc
: constant Source_Ptr
:= Sloc
(N
);
3477 Typ
: constant Entity_Id
:= Etype
(N
);
3480 if Inside_A_Generic
then
3483 -- Nothing to do if checks are suppressed
3485 elsif Range_Checks_Suppressed
(Typ
)
3486 and then Overflow_Checks_Suppressed
(Typ
)
3490 -- Nothing to do if the attribute does not come from source. The
3491 -- internal attributes we generate of this type do not need checks,
3492 -- and furthermore the attempt to check them causes some circular
3493 -- elaboration orders when dealing with packed types.
3495 elsif not Comes_From_Source
(N
) then
3498 -- If the prefix is a selected component that depends on a discriminant
3499 -- the check may improperly expose a discriminant instead of using
3500 -- the bounds of the object itself. Set the type of the attribute to
3501 -- the base type of the context, so that a check will be imposed when
3502 -- needed (e.g. if the node appears as an index).
3504 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
3505 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
3506 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
3508 Set_Etype
(N
, Base_Type
(Typ
));
3510 -- Otherwise, replace the attribute node with a type conversion node
3511 -- whose expression is the attribute, retyped to universal integer, and
3512 -- whose subtype mark is the target type. The call to analyze this
3513 -- conversion will set range and overflow checks as required for proper
3514 -- detection of an out of range value.
3517 Set_Etype
(N
, Universal_Integer
);
3518 Set_Analyzed
(N
, True);
3521 Make_Type_Conversion
(Loc
,
3522 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
3523 Expression
=> Relocate_Node
(N
)));
3525 Analyze_And_Resolve
(N
, Typ
);
3528 end Apply_Universal_Integer_Attribute_Checks
;
3530 -------------------------------------
3531 -- Atomic_Synchronization_Disabled --
3532 -------------------------------------
3534 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3535 -- using a bogus check called Atomic_Synchronization. This is to make it
3536 -- more convenient to get exactly the same semantics as [Un]Suppress.
3538 function Atomic_Synchronization_Disabled
(E
: Entity_Id
) return Boolean is
3540 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3541 -- looks enabled, since it is never disabled.
3543 if Debug_Flag_Dot_E
then
3546 -- If debug flag d.d is set then always return True, i.e. all atomic
3547 -- sync looks disabled, since it always tests True.
3549 elsif Debug_Flag_Dot_D
then
3552 -- If entity present, then check result for that entity
3554 elsif Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3555 return Is_Check_Suppressed
(E
, Atomic_Synchronization
);
3557 -- Otherwise result depends on current scope setting
3560 return Scope_Suppress
.Suppress
(Atomic_Synchronization
);
3562 end Atomic_Synchronization_Disabled
;
3564 -------------------------------
3565 -- Build_Discriminant_Checks --
3566 -------------------------------
3568 function Build_Discriminant_Checks
3570 T_Typ
: Entity_Id
) return Node_Id
3572 Loc
: constant Source_Ptr
:= Sloc
(N
);
3575 Disc_Ent
: Entity_Id
;
3579 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
;
3581 ----------------------------------
3582 -- Aggregate_Discriminant_Value --
3583 ----------------------------------
3585 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
is
3589 -- The aggregate has been normalized with named associations. We use
3590 -- the Chars field to locate the discriminant to take into account
3591 -- discriminants in derived types, which carry the same name as those
3594 Assoc
:= First
(Component_Associations
(N
));
3595 while Present
(Assoc
) loop
3596 if Chars
(First
(Choices
(Assoc
))) = Chars
(Disc
) then
3597 return Expression
(Assoc
);
3603 -- Discriminant must have been found in the loop above
3605 raise Program_Error
;
3606 end Aggregate_Discriminant_Val
;
3608 -- Start of processing for Build_Discriminant_Checks
3611 -- Loop through discriminants evolving the condition
3614 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
3616 -- For a fully private type, use the discriminants of the parent type
3618 if Is_Private_Type
(T_Typ
)
3619 and then No
(Full_View
(T_Typ
))
3621 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
3623 Disc_Ent
:= First_Discriminant
(T_Typ
);
3626 while Present
(Disc
) loop
3627 Dval
:= Node
(Disc
);
3629 if Nkind
(Dval
) = N_Identifier
3630 and then Ekind
(Entity
(Dval
)) = E_Discriminant
3632 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
3634 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
3637 -- If we have an Unchecked_Union node, we can infer the discriminants
3640 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
3642 Get_Discriminant_Value
(
3643 First_Discriminant
(T_Typ
),
3645 Stored_Constraint
(T_Typ
)));
3647 elsif Nkind
(N
) = N_Aggregate
then
3649 Duplicate_Subexpr_No_Checks
3650 (Aggregate_Discriminant_Val
(Disc_Ent
));
3654 Make_Selected_Component
(Loc
,
3656 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
3657 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
3659 Set_Is_In_Discriminant_Check
(Dref
);
3662 Evolve_Or_Else
(Cond
,
3665 Right_Opnd
=> Dval
));
3668 Next_Discriminant
(Disc_Ent
);
3672 end Build_Discriminant_Checks
;
3678 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
3685 function Left_Expression
(Op
: Node_Id
) return Node_Id
;
3686 -- Return the relevant expression from the left operand of the given
3687 -- short circuit form: this is LO itself, except if LO is a qualified
3688 -- expression, a type conversion, or an expression with actions, in
3689 -- which case this is Left_Expression (Expression (LO)).
3691 ---------------------
3692 -- Left_Expression --
3693 ---------------------
3695 function Left_Expression
(Op
: Node_Id
) return Node_Id
is
3696 LE
: Node_Id
:= Left_Opnd
(Op
);
3698 while Nkind_In
(LE
, N_Qualified_Expression
,
3700 N_Expression_With_Actions
)
3702 LE
:= Expression
(LE
);
3706 end Left_Expression
;
3708 -- Start of processing for Check_Needed
3711 -- Always check if not simple entity
3713 if Nkind
(Nod
) not in N_Has_Entity
3714 or else not Comes_From_Source
(Nod
)
3719 -- Look up tree for short circuit
3726 -- Done if out of subexpression (note that we allow generated stuff
3727 -- such as itype declarations in this context, to keep the loop going
3728 -- since we may well have generated such stuff in complex situations.
3729 -- Also done if no parent (probably an error condition, but no point
3730 -- in behaving nasty if we find it).
3733 or else (K
not in N_Subexpr
and then Comes_From_Source
(P
))
3737 -- Or/Or Else case, where test is part of the right operand, or is
3738 -- part of one of the actions associated with the right operand, and
3739 -- the left operand is an equality test.
3741 elsif K
= N_Op_Or
then
3742 exit when N
= Right_Opnd
(P
)
3743 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
3745 elsif K
= N_Or_Else
then
3746 exit when (N
= Right_Opnd
(P
)
3749 and then List_Containing
(N
) = Actions
(P
)))
3750 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
3752 -- Similar test for the And/And then case, where the left operand
3753 -- is an inequality test.
3755 elsif K
= N_Op_And
then
3756 exit when N
= Right_Opnd
(P
)
3757 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
3759 elsif K
= N_And_Then
then
3760 exit when (N
= Right_Opnd
(P
)
3763 and then List_Containing
(N
) = Actions
(P
)))
3764 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
3770 -- If we fall through the loop, then we have a conditional with an
3771 -- appropriate test as its left operand, so look further.
3773 L
:= Left_Expression
(P
);
3775 -- L is an "=" or "/=" operator: extract its operands
3777 R
:= Right_Opnd
(L
);
3780 -- Left operand of test must match original variable
3782 if Nkind
(L
) not in N_Has_Entity
or else Entity
(L
) /= Entity
(Nod
) then
3786 -- Right operand of test must be key value (zero or null)
3789 when Access_Check
=>
3790 if not Known_Null
(R
) then
3794 when Division_Check
=>
3795 if not Compile_Time_Known_Value
(R
)
3796 or else Expr_Value
(R
) /= Uint_0
3802 raise Program_Error
;
3805 -- Here we have the optimizable case, warn if not short-circuited
3807 if K
= N_Op_And
or else K
= N_Op_Or
then
3808 Error_Msg_Warn
:= SPARK_Mode
/= On
;
3811 when Access_Check
=>
3812 if GNATprove_Mode
then
3814 ("Constraint_Error might have been raised (access check)",
3818 ("Constraint_Error may be raised (access check)??",
3822 when Division_Check
=>
3823 if GNATprove_Mode
then
3825 ("Constraint_Error might have been raised (zero divide)",
3829 ("Constraint_Error may be raised (zero divide)??",
3834 raise Program_Error
;
3837 if K
= N_Op_And
then
3838 Error_Msg_N
-- CODEFIX
3839 ("use `AND THEN` instead of AND??", P
);
3841 Error_Msg_N
-- CODEFIX
3842 ("use `OR ELSE` instead of OR??", P
);
3845 -- If not short-circuited, we need the check
3849 -- If short-circuited, we can omit the check
3856 -----------------------------------
3857 -- Check_Valid_Lvalue_Subscripts --
3858 -----------------------------------
3860 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
3862 -- Skip this if range checks are suppressed
3864 if Range_Checks_Suppressed
(Etype
(Expr
)) then
3867 -- Only do this check for expressions that come from source. We assume
3868 -- that expander generated assignments explicitly include any necessary
3869 -- checks. Note that this is not just an optimization, it avoids
3870 -- infinite recursions.
3872 elsif not Comes_From_Source
(Expr
) then
3875 -- For a selected component, check the prefix
3877 elsif Nkind
(Expr
) = N_Selected_Component
then
3878 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3881 -- Case of indexed component
3883 elsif Nkind
(Expr
) = N_Indexed_Component
then
3884 Apply_Subscript_Validity_Checks
(Expr
);
3886 -- Prefix may itself be or contain an indexed component, and these
3887 -- subscripts need checking as well.
3889 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3891 end Check_Valid_Lvalue_Subscripts
;
3893 ----------------------------------
3894 -- Null_Exclusion_Static_Checks --
3895 ----------------------------------
3897 procedure Null_Exclusion_Static_Checks
(N
: Node_Id
) is
3898 Error_Node
: Node_Id
;
3900 Has_Null
: constant Boolean := Has_Null_Exclusion
(N
);
3901 K
: constant Node_Kind
:= Nkind
(N
);
3906 (Nkind_In
(K
, N_Component_Declaration
,
3907 N_Discriminant_Specification
,
3908 N_Function_Specification
,
3909 N_Object_Declaration
,
3910 N_Parameter_Specification
));
3912 if K
= N_Function_Specification
then
3913 Typ
:= Etype
(Defining_Entity
(N
));
3915 Typ
:= Etype
(Defining_Identifier
(N
));
3919 when N_Component_Declaration
=>
3920 if Present
(Access_Definition
(Component_Definition
(N
))) then
3921 Error_Node
:= Component_Definition
(N
);
3923 Error_Node
:= Subtype_Indication
(Component_Definition
(N
));
3926 when N_Discriminant_Specification
=>
3927 Error_Node
:= Discriminant_Type
(N
);
3929 when N_Function_Specification
=>
3930 Error_Node
:= Result_Definition
(N
);
3932 when N_Object_Declaration
=>
3933 Error_Node
:= Object_Definition
(N
);
3935 when N_Parameter_Specification
=>
3936 Error_Node
:= Parameter_Type
(N
);
3939 raise Program_Error
;
3944 -- Enforce legality rule 3.10 (13): A null exclusion can only be
3945 -- applied to an access [sub]type.
3947 if not Is_Access_Type
(Typ
) then
3949 ("`NOT NULL` allowed only for an access type", Error_Node
);
3951 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
3952 -- be applied to a [sub]type that does not exclude null already.
3954 elsif Can_Never_Be_Null
(Typ
)
3955 and then Comes_From_Source
(Typ
)
3958 ("`NOT NULL` not allowed (& already excludes null)",
3963 -- Check that null-excluding objects are always initialized, except for
3964 -- deferred constants, for which the expression will appear in the full
3967 if K
= N_Object_Declaration
3968 and then No
(Expression
(N
))
3969 and then not Constant_Present
(N
)
3970 and then not No_Initialization
(N
)
3972 -- Add an expression that assigns null. This node is needed by
3973 -- Apply_Compile_Time_Constraint_Error, which will replace this with
3974 -- a Constraint_Error node.
3976 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
3977 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
3979 Apply_Compile_Time_Constraint_Error
3980 (N
=> Expression
(N
),
3982 "(Ada 2005) null-excluding objects must be initialized??",
3983 Reason
=> CE_Null_Not_Allowed
);
3986 -- Check that a null-excluding component, formal or object is not being
3987 -- assigned a null value. Otherwise generate a warning message and
3988 -- replace Expression (N) by an N_Constraint_Error node.
3990 if K
/= N_Function_Specification
then
3991 Expr
:= Expression
(N
);
3993 if Present
(Expr
) and then Known_Null
(Expr
) then
3995 when N_Component_Declaration |
3996 N_Discriminant_Specification
=>
3997 Apply_Compile_Time_Constraint_Error
3999 Msg
=> "(Ada 2005) null not allowed "
4000 & "in null-excluding components??",
4001 Reason
=> CE_Null_Not_Allowed
);
4003 when N_Object_Declaration
=>
4004 Apply_Compile_Time_Constraint_Error
4006 Msg
=> "(Ada 2005) null not allowed "
4007 & "in null-excluding objects??",
4008 Reason
=> CE_Null_Not_Allowed
);
4010 when N_Parameter_Specification
=>
4011 Apply_Compile_Time_Constraint_Error
4013 Msg
=> "(Ada 2005) null not allowed "
4014 & "in null-excluding formals??",
4015 Reason
=> CE_Null_Not_Allowed
);
4022 end Null_Exclusion_Static_Checks
;
4024 ----------------------------------
4025 -- Conditional_Statements_Begin --
4026 ----------------------------------
4028 procedure Conditional_Statements_Begin
is
4030 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
4032 -- If stack overflows, kill all checks, that way we know to simply reset
4033 -- the number of saved checks to zero on return. This should never occur
4036 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
4039 -- In the normal case, we just make a new stack entry saving the current
4040 -- number of saved checks for a later restore.
4043 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
4045 if Debug_Flag_CC
then
4046 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
4050 end Conditional_Statements_Begin
;
4052 --------------------------------
4053 -- Conditional_Statements_End --
4054 --------------------------------
4056 procedure Conditional_Statements_End
is
4058 pragma Assert
(Saved_Checks_TOS
> 0);
4060 -- If the saved checks stack overflowed, then we killed all checks, so
4061 -- setting the number of saved checks back to zero is correct. This
4062 -- should never occur in practice.
4064 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
4065 Num_Saved_Checks
:= 0;
4067 -- In the normal case, restore the number of saved checks from the top
4071 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
4073 if Debug_Flag_CC
then
4074 w
("Conditional_Statements_End: Num_Saved_Checks = ",
4079 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
4080 end Conditional_Statements_End
;
4082 -------------------------
4083 -- Convert_From_Bignum --
4084 -------------------------
4086 function Convert_From_Bignum
(N
: Node_Id
) return Node_Id
is
4087 Loc
: constant Source_Ptr
:= Sloc
(N
);
4090 pragma Assert
(Is_RTE
(Etype
(N
), RE_Bignum
));
4092 -- Construct call From Bignum
4095 Make_Function_Call
(Loc
,
4097 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
4098 Parameter_Associations
=> New_List
(Relocate_Node
(N
)));
4099 end Convert_From_Bignum
;
4101 -----------------------
4102 -- Convert_To_Bignum --
4103 -----------------------
4105 function Convert_To_Bignum
(N
: Node_Id
) return Node_Id
is
4106 Loc
: constant Source_Ptr
:= Sloc
(N
);
4109 -- Nothing to do if Bignum already except call Relocate_Node
4111 if Is_RTE
(Etype
(N
), RE_Bignum
) then
4112 return Relocate_Node
(N
);
4114 -- Otherwise construct call to To_Bignum, converting the operand to the
4115 -- required Long_Long_Integer form.
4118 pragma Assert
(Is_Signed_Integer_Type
(Etype
(N
)));
4120 Make_Function_Call
(Loc
,
4122 New_Occurrence_Of
(RTE
(RE_To_Bignum
), Loc
),
4123 Parameter_Associations
=> New_List
(
4124 Convert_To
(Standard_Long_Long_Integer
, Relocate_Node
(N
))));
4126 end Convert_To_Bignum
;
4128 ---------------------
4129 -- Determine_Range --
4130 ---------------------
4132 Cache_Size
: constant := 2 ** 10;
4133 type Cache_Index
is range 0 .. Cache_Size
- 1;
4134 -- Determine size of below cache (power of 2 is more efficient)
4136 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
4137 Determine_Range_Cache_V
: array (Cache_Index
) of Boolean;
4138 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
4139 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
4140 Determine_Range_Cache_Lo_R
: array (Cache_Index
) of Ureal
;
4141 Determine_Range_Cache_Hi_R
: array (Cache_Index
) of Ureal
;
4142 -- The above arrays are used to implement a small direct cache for
4143 -- Determine_Range and Determine_Range_R calls. Because of the way these
4144 -- subprograms recursively traces subexpressions, and because overflow
4145 -- checking calls the routine on the way up the tree, a quadratic behavior
4146 -- can otherwise be encountered in large expressions. The cache entry for
4147 -- node N is stored in the (N mod Cache_Size) entry, and can be validated
4148 -- by checking the actual node value stored there. The Range_Cache_V array
4149 -- records the setting of Assume_Valid for the cache entry.
4151 procedure Determine_Range
4156 Assume_Valid
: Boolean := False)
4158 Typ
: Entity_Id
:= Etype
(N
);
4159 -- Type to use, may get reset to base type for possibly invalid entity
4163 -- Lo and Hi bounds of left operand
4167 -- Lo and Hi bounds of right (or only) operand
4170 -- Temp variable used to hold a bound node
4173 -- High bound of base type of expression
4177 -- Refined values for low and high bounds, after tightening
4180 -- Used in lower level calls to indicate if call succeeded
4182 Cindex
: Cache_Index
;
4183 -- Used to search cache
4188 function OK_Operands
return Boolean;
4189 -- Used for binary operators. Determines the ranges of the left and
4190 -- right operands, and if they are both OK, returns True, and puts
4191 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4197 function OK_Operands
return Boolean is
4200 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
4207 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4211 -- Start of processing for Determine_Range
4214 -- Prevent junk warnings by initializing range variables
4221 -- For temporary constants internally generated to remove side effects
4222 -- we must use the corresponding expression to determine the range of
4223 -- the expression. But note that the expander can also generate
4224 -- constants in other cases, including deferred constants.
4226 if Is_Entity_Name
(N
)
4227 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
4228 and then Ekind
(Entity
(N
)) = E_Constant
4229 and then Is_Internal_Name
(Chars
(Entity
(N
)))
4231 if Present
(Expression
(Parent
(Entity
(N
)))) then
4233 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
4235 elsif Present
(Full_View
(Entity
(N
))) then
4237 (Expression
(Parent
(Full_View
(Entity
(N
)))),
4238 OK
, Lo
, Hi
, Assume_Valid
);
4246 -- If type is not defined, we can't determine its range
4250 -- We don't deal with anything except discrete types
4252 or else not Is_Discrete_Type
(Typ
)
4254 -- Ignore type for which an error has been posted, since range in
4255 -- this case may well be a bogosity deriving from the error. Also
4256 -- ignore if error posted on the reference node.
4258 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
4264 -- For all other cases, we can determine the range
4268 -- If value is compile time known, then the possible range is the one
4269 -- value that we know this expression definitely has.
4271 if Compile_Time_Known_Value
(N
) then
4272 Lo
:= Expr_Value
(N
);
4277 -- Return if already in the cache
4279 Cindex
:= Cache_Index
(N
mod Cache_Size
);
4281 if Determine_Range_Cache_N
(Cindex
) = N
4283 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
4285 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
4286 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
4290 -- Otherwise, start by finding the bounds of the type of the expression,
4291 -- the value cannot be outside this range (if it is, then we have an
4292 -- overflow situation, which is a separate check, we are talking here
4293 -- only about the expression value).
4295 -- First a check, never try to find the bounds of a generic type, since
4296 -- these bounds are always junk values, and it is only valid to look at
4297 -- the bounds in an instance.
4299 if Is_Generic_Type
(Typ
) then
4304 -- First step, change to use base type unless we know the value is valid
4306 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
4307 or else Assume_No_Invalid_Values
4308 or else Assume_Valid
4312 Typ
:= Underlying_Type
(Base_Type
(Typ
));
4315 -- Retrieve the base type. Handle the case where the base type is a
4316 -- private enumeration type.
4318 Btyp
:= Base_Type
(Typ
);
4320 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
4321 Btyp
:= Full_View
(Btyp
);
4324 -- We use the actual bound unless it is dynamic, in which case use the
4325 -- corresponding base type bound if possible. If we can't get a bound
4326 -- then we figure we can't determine the range (a peculiar case, that
4327 -- perhaps cannot happen, but there is no point in bombing in this
4328 -- optimization circuit.
4330 -- First the low bound
4332 Bound
:= Type_Low_Bound
(Typ
);
4334 if Compile_Time_Known_Value
(Bound
) then
4335 Lo
:= Expr_Value
(Bound
);
4337 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
4338 Lo
:= Expr_Value
(Type_Low_Bound
(Btyp
));
4345 -- Now the high bound
4347 Bound
:= Type_High_Bound
(Typ
);
4349 -- We need the high bound of the base type later on, and this should
4350 -- always be compile time known. Again, it is not clear that this
4351 -- can ever be false, but no point in bombing.
4353 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
4354 Hbound
:= Expr_Value
(Type_High_Bound
(Btyp
));
4362 -- If we have a static subtype, then that may have a tighter bound so
4363 -- use the upper bound of the subtype instead in this case.
4365 if Compile_Time_Known_Value
(Bound
) then
4366 Hi
:= Expr_Value
(Bound
);
4369 -- We may be able to refine this value in certain situations. If any
4370 -- refinement is possible, then Lor and Hir are set to possibly tighter
4371 -- bounds, and OK1 is set to True.
4375 -- For unary plus, result is limited by range of operand
4379 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4381 -- For unary minus, determine range of operand, and negate it
4385 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4392 -- For binary addition, get range of each operand and do the
4393 -- addition to get the result range.
4397 Lor
:= Lo_Left
+ Lo_Right
;
4398 Hir
:= Hi_Left
+ Hi_Right
;
4401 -- Division is tricky. The only case we consider is where the right
4402 -- operand is a positive constant, and in this case we simply divide
4403 -- the bounds of the left operand
4407 if Lo_Right
= Hi_Right
4408 and then Lo_Right
> 0
4410 Lor
:= Lo_Left
/ Lo_Right
;
4411 Hir
:= Hi_Left
/ Lo_Right
;
4417 -- For binary subtraction, get range of each operand and do the worst
4418 -- case subtraction to get the result range.
4420 when N_Op_Subtract
=>
4422 Lor
:= Lo_Left
- Hi_Right
;
4423 Hir
:= Hi_Left
- Lo_Right
;
4426 -- For MOD, if right operand is a positive constant, then result must
4427 -- be in the allowable range of mod results.
4431 if Lo_Right
= Hi_Right
4432 and then Lo_Right
/= 0
4434 if Lo_Right
> 0 then
4436 Hir
:= Lo_Right
- 1;
4438 else -- Lo_Right < 0
4439 Lor
:= Lo_Right
+ 1;
4448 -- For REM, if right operand is a positive constant, then result must
4449 -- be in the allowable range of mod results.
4453 if Lo_Right
= Hi_Right
4454 and then Lo_Right
/= 0
4457 Dval
: constant Uint
:= (abs Lo_Right
) - 1;
4460 -- The sign of the result depends on the sign of the
4461 -- dividend (but not on the sign of the divisor, hence
4462 -- the abs operation above).
4482 -- Attribute reference cases
4484 when N_Attribute_Reference
=>
4485 case Attribute_Name
(N
) is
4487 -- For Pos/Val attributes, we can refine the range using the
4488 -- possible range of values of the attribute expression.
4490 when Name_Pos | Name_Val
=>
4492 (First
(Expressions
(N
)), OK1
, Lor
, Hir
, Assume_Valid
);
4494 -- For Length attribute, use the bounds of the corresponding
4495 -- index type to refine the range.
4499 Atyp
: Entity_Id
:= Etype
(Prefix
(N
));
4507 if Is_Access_Type
(Atyp
) then
4508 Atyp
:= Designated_Type
(Atyp
);
4511 -- For string literal, we know exact value
4513 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
4515 Lo
:= String_Literal_Length
(Atyp
);
4516 Hi
:= String_Literal_Length
(Atyp
);
4520 -- Otherwise check for expression given
4522 if No
(Expressions
(N
)) then
4526 UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
4529 Indx
:= First_Index
(Atyp
);
4530 for J
in 2 .. Inum
loop
4531 Indx
:= Next_Index
(Indx
);
4534 -- If the index type is a formal type or derived from
4535 -- one, the bounds are not static.
4537 if Is_Generic_Type
(Root_Type
(Etype
(Indx
))) then
4543 (Type_Low_Bound
(Etype
(Indx
)), OK1
, LL
, LU
,
4548 (Type_High_Bound
(Etype
(Indx
)), OK1
, UL
, UU
,
4553 -- The maximum value for Length is the biggest
4554 -- possible gap between the values of the bounds.
4555 -- But of course, this value cannot be negative.
4557 Hir
:= UI_Max
(Uint_0
, UU
- LL
+ 1);
4559 -- For constrained arrays, the minimum value for
4560 -- Length is taken from the actual value of the
4561 -- bounds, since the index will be exactly of this
4564 if Is_Constrained
(Atyp
) then
4565 Lor
:= UI_Max
(Uint_0
, UL
- LU
+ 1);
4567 -- For an unconstrained array, the minimum value
4568 -- for length is always zero.
4577 -- No special handling for other attributes
4578 -- Probably more opportunities exist here???
4585 -- For type conversion from one discrete type to another, we can
4586 -- refine the range using the converted value.
4588 when N_Type_Conversion
=>
4589 Determine_Range
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4591 -- Nothing special to do for all other expression kinds
4599 -- At this stage, if OK1 is true, then we know that the actual result of
4600 -- the computed expression is in the range Lor .. Hir. We can use this
4601 -- to restrict the possible range of results.
4605 -- If the refined value of the low bound is greater than the type
4606 -- low bound, then reset it to the more restrictive value. However,
4607 -- we do NOT do this for the case of a modular type where the
4608 -- possible upper bound on the value is above the base type high
4609 -- bound, because that means the result could wrap.
4612 and then not (Is_Modular_Integer_Type
(Typ
) and then Hir
> Hbound
)
4617 -- Similarly, if the refined value of the high bound is less than the
4618 -- value so far, then reset it to the more restrictive value. Again,
4619 -- we do not do this if the refined low bound is negative for a
4620 -- modular type, since this would wrap.
4623 and then not (Is_Modular_Integer_Type
(Typ
) and then Lor
< Uint_0
)
4629 -- Set cache entry for future call and we are all done
4631 Determine_Range_Cache_N
(Cindex
) := N
;
4632 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
4633 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
4634 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
4637 -- If any exception occurs, it means that we have some bug in the compiler,
4638 -- possibly triggered by a previous error, or by some unforeseen peculiar
4639 -- occurrence. However, this is only an optimization attempt, so there is
4640 -- really no point in crashing the compiler. Instead we just decide, too
4641 -- bad, we can't figure out a range in this case after all.
4646 -- Debug flag K disables this behavior (useful for debugging)
4648 if Debug_Flag_K
then
4656 end Determine_Range
;
4658 -----------------------
4659 -- Determine_Range_R --
4660 -----------------------
4662 procedure Determine_Range_R
4667 Assume_Valid
: Boolean := False)
4669 Typ
: Entity_Id
:= Etype
(N
);
4670 -- Type to use, may get reset to base type for possibly invalid entity
4674 -- Lo and Hi bounds of left operand
4678 -- Lo and Hi bounds of right (or only) operand
4681 -- Temp variable used to hold a bound node
4684 -- High bound of base type of expression
4688 -- Refined values for low and high bounds, after tightening
4691 -- Used in lower level calls to indicate if call succeeded
4693 Cindex
: Cache_Index
;
4694 -- Used to search cache
4699 function OK_Operands
return Boolean;
4700 -- Used for binary operators. Determines the ranges of the left and
4701 -- right operands, and if they are both OK, returns True, and puts
4702 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4704 function Round_Machine
(B
: Ureal
) return Ureal
;
4705 -- B is a real bound. Round it using mode Round_Even.
4711 function OK_Operands
return Boolean is
4714 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
4721 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4729 function Round_Machine
(B
: Ureal
) return Ureal
is
4731 return Machine
(Typ
, B
, Round_Even
, N
);
4734 -- Start of processing for Determine_Range_R
4737 -- Prevent junk warnings by initializing range variables
4744 -- For temporary constants internally generated to remove side effects
4745 -- we must use the corresponding expression to determine the range of
4746 -- the expression. But note that the expander can also generate
4747 -- constants in other cases, including deferred constants.
4749 if Is_Entity_Name
(N
)
4750 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
4751 and then Ekind
(Entity
(N
)) = E_Constant
4752 and then Is_Internal_Name
(Chars
(Entity
(N
)))
4754 if Present
(Expression
(Parent
(Entity
(N
)))) then
4756 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
4758 elsif Present
(Full_View
(Entity
(N
))) then
4760 (Expression
(Parent
(Full_View
(Entity
(N
)))),
4761 OK
, Lo
, Hi
, Assume_Valid
);
4770 -- If type is not defined, we can't determine its range
4774 -- We don't deal with anything except IEEE floating-point types
4776 or else not Is_Floating_Point_Type
(Typ
)
4777 or else Float_Rep
(Typ
) /= IEEE_Binary
4779 -- Ignore type for which an error has been posted, since range in
4780 -- this case may well be a bogosity deriving from the error. Also
4781 -- ignore if error posted on the reference node.
4783 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
4789 -- For all other cases, we can determine the range
4793 -- If value is compile time known, then the possible range is the one
4794 -- value that we know this expression definitely has.
4796 if Compile_Time_Known_Value
(N
) then
4797 Lo
:= Expr_Value_R
(N
);
4802 -- Return if already in the cache
4804 Cindex
:= Cache_Index
(N
mod Cache_Size
);
4806 if Determine_Range_Cache_N
(Cindex
) = N
4808 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
4810 Lo
:= Determine_Range_Cache_Lo_R
(Cindex
);
4811 Hi
:= Determine_Range_Cache_Hi_R
(Cindex
);
4815 -- Otherwise, start by finding the bounds of the type of the expression,
4816 -- the value cannot be outside this range (if it is, then we have an
4817 -- overflow situation, which is a separate check, we are talking here
4818 -- only about the expression value).
4820 -- First a check, never try to find the bounds of a generic type, since
4821 -- these bounds are always junk values, and it is only valid to look at
4822 -- the bounds in an instance.
4824 if Is_Generic_Type
(Typ
) then
4829 -- First step, change to use base type unless we know the value is valid
4831 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
4832 or else Assume_No_Invalid_Values
4833 or else Assume_Valid
4837 Typ
:= Underlying_Type
(Base_Type
(Typ
));
4840 -- Retrieve the base type. Handle the case where the base type is a
4843 Btyp
:= Base_Type
(Typ
);
4845 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
4846 Btyp
:= Full_View
(Btyp
);
4849 -- We use the actual bound unless it is dynamic, in which case use the
4850 -- corresponding base type bound if possible. If we can't get a bound
4851 -- then we figure we can't determine the range (a peculiar case, that
4852 -- perhaps cannot happen, but there is no point in bombing in this
4853 -- optimization circuit).
4855 -- First the low bound
4857 Bound
:= Type_Low_Bound
(Typ
);
4859 if Compile_Time_Known_Value
(Bound
) then
4860 Lo
:= Expr_Value_R
(Bound
);
4862 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
4863 Lo
:= Expr_Value_R
(Type_Low_Bound
(Btyp
));
4870 -- Now the high bound
4872 Bound
:= Type_High_Bound
(Typ
);
4874 -- We need the high bound of the base type later on, and this should
4875 -- always be compile time known. Again, it is not clear that this
4876 -- can ever be false, but no point in bombing.
4878 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
4879 Hbound
:= Expr_Value_R
(Type_High_Bound
(Btyp
));
4887 -- If we have a static subtype, then that may have a tighter bound so
4888 -- use the upper bound of the subtype instead in this case.
4890 if Compile_Time_Known_Value
(Bound
) then
4891 Hi
:= Expr_Value_R
(Bound
);
4894 -- We may be able to refine this value in certain situations. If any
4895 -- refinement is possible, then Lor and Hir are set to possibly tighter
4896 -- bounds, and OK1 is set to True.
4900 -- For unary plus, result is limited by range of operand
4904 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4906 -- For unary minus, determine range of operand, and negate it
4910 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4917 -- For binary addition, get range of each operand and do the
4918 -- addition to get the result range.
4922 Lor
:= Round_Machine
(Lo_Left
+ Lo_Right
);
4923 Hir
:= Round_Machine
(Hi_Left
+ Hi_Right
);
4926 -- For binary subtraction, get range of each operand and do the worst
4927 -- case subtraction to get the result range.
4929 when N_Op_Subtract
=>
4931 Lor
:= Round_Machine
(Lo_Left
- Hi_Right
);
4932 Hir
:= Round_Machine
(Hi_Left
- Lo_Right
);
4935 -- For multiplication, get range of each operand and do the
4936 -- four multiplications to get the result range.
4938 when N_Op_Multiply
=>
4941 M1
: constant Ureal
:= Round_Machine
(Lo_Left
* Lo_Right
);
4942 M2
: constant Ureal
:= Round_Machine
(Lo_Left
* Hi_Right
);
4943 M3
: constant Ureal
:= Round_Machine
(Hi_Left
* Lo_Right
);
4944 M4
: constant Ureal
:= Round_Machine
(Hi_Left
* Hi_Right
);
4946 Lor
:= UR_Min
(UR_Min
(M1
, M2
), UR_Min
(M3
, M4
));
4947 Hir
:= UR_Max
(UR_Max
(M1
, M2
), UR_Max
(M3
, M4
));
4951 -- For division, consider separately the cases where the right
4952 -- operand is positive or negative. Otherwise, the right operand
4953 -- can be arbitrarily close to zero, so the result is likely to
4954 -- be unbounded in one direction, do not attempt to compute it.
4959 -- Right operand is positive
4961 if Lo_Right
> Ureal_0
then
4963 -- If the low bound of the left operand is negative, obtain
4964 -- the overall low bound by dividing it by the smallest
4965 -- value of the right operand, and otherwise by the largest
4966 -- value of the right operand.
4968 if Lo_Left
< Ureal_0
then
4969 Lor
:= Round_Machine
(Lo_Left
/ Lo_Right
);
4971 Lor
:= Round_Machine
(Lo_Left
/ Hi_Right
);
4974 -- If the high bound of the left operand is negative, obtain
4975 -- the overall high bound by dividing it by the largest
4976 -- value of the right operand, and otherwise by the
4977 -- smallest value of the right operand.
4979 if Hi_Left
< Ureal_0
then
4980 Hir
:= Round_Machine
(Hi_Left
/ Hi_Right
);
4982 Hir
:= Round_Machine
(Hi_Left
/ Lo_Right
);
4985 -- Right operand is negative
4987 elsif Hi_Right
< Ureal_0
then
4989 -- If the low bound of the left operand is negative, obtain
4990 -- the overall low bound by dividing it by the largest
4991 -- value of the right operand, and otherwise by the smallest
4992 -- value of the right operand.
4994 if Lo_Left
< Ureal_0
then
4995 Lor
:= Round_Machine
(Lo_Left
/ Hi_Right
);
4997 Lor
:= Round_Machine
(Lo_Left
/ Lo_Right
);
5000 -- If the high bound of the left operand is negative, obtain
5001 -- the overall high bound by dividing it by the smallest
5002 -- value of the right operand, and otherwise by the
5003 -- largest value of the right operand.
5005 if Hi_Left
< Ureal_0
then
5006 Hir
:= Round_Machine
(Hi_Left
/ Lo_Right
);
5008 Hir
:= Round_Machine
(Hi_Left
/ Hi_Right
);
5016 -- For type conversion from one floating-point type to another, we
5017 -- can refine the range using the converted value.
5019 when N_Type_Conversion
=>
5020 Determine_Range_R
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
5022 -- Nothing special to do for all other expression kinds
5030 -- At this stage, if OK1 is true, then we know that the actual result of
5031 -- the computed expression is in the range Lor .. Hir. We can use this
5032 -- to restrict the possible range of results.
5036 -- If the refined value of the low bound is greater than the type
5037 -- low bound, then reset it to the more restrictive value.
5043 -- Similarly, if the refined value of the high bound is less than the
5044 -- value so far, then reset it to the more restrictive value.
5051 -- Set cache entry for future call and we are all done
5053 Determine_Range_Cache_N
(Cindex
) := N
;
5054 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
5055 Determine_Range_Cache_Lo_R
(Cindex
) := Lo
;
5056 Determine_Range_Cache_Hi_R
(Cindex
) := Hi
;
5059 -- If any exception occurs, it means that we have some bug in the compiler,
5060 -- possibly triggered by a previous error, or by some unforeseen peculiar
5061 -- occurrence. However, this is only an optimization attempt, so there is
5062 -- really no point in crashing the compiler. Instead we just decide, too
5063 -- bad, we can't figure out a range in this case after all.
5068 -- Debug flag K disables this behavior (useful for debugging)
5070 if Debug_Flag_K
then
5078 end Determine_Range_R
;
5080 ------------------------------------
5081 -- Discriminant_Checks_Suppressed --
5082 ------------------------------------
5084 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5087 if Is_Unchecked_Union
(E
) then
5089 elsif Checks_May_Be_Suppressed
(E
) then
5090 return Is_Check_Suppressed
(E
, Discriminant_Check
);
5094 return Scope_Suppress
.Suppress
(Discriminant_Check
);
5095 end Discriminant_Checks_Suppressed
;
5097 --------------------------------
5098 -- Division_Checks_Suppressed --
5099 --------------------------------
5101 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5103 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
5104 return Is_Check_Suppressed
(E
, Division_Check
);
5106 return Scope_Suppress
.Suppress
(Division_Check
);
5108 end Division_Checks_Suppressed
;
5110 --------------------------------------
5111 -- Duplicated_Tag_Checks_Suppressed --
5112 --------------------------------------
5114 function Duplicated_Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5116 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
5117 return Is_Check_Suppressed
(E
, Duplicated_Tag_Check
);
5119 return Scope_Suppress
.Suppress
(Duplicated_Tag_Check
);
5121 end Duplicated_Tag_Checks_Suppressed
;
5123 -----------------------------------
5124 -- Elaboration_Checks_Suppressed --
5125 -----------------------------------
5127 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5129 -- The complication in this routine is that if we are in the dynamic
5130 -- model of elaboration, we also check All_Checks, since All_Checks
5131 -- does not set Elaboration_Check explicitly.
5134 if Kill_Elaboration_Checks
(E
) then
5137 elsif Checks_May_Be_Suppressed
(E
) then
5138 if Is_Check_Suppressed
(E
, Elaboration_Check
) then
5140 elsif Dynamic_Elaboration_Checks
then
5141 return Is_Check_Suppressed
(E
, All_Checks
);
5148 if Scope_Suppress
.Suppress
(Elaboration_Check
) then
5150 elsif Dynamic_Elaboration_Checks
then
5151 return Scope_Suppress
.Suppress
(All_Checks
);
5155 end Elaboration_Checks_Suppressed
;
5157 ---------------------------
5158 -- Enable_Overflow_Check --
5159 ---------------------------
5161 procedure Enable_Overflow_Check
(N
: Node_Id
) is
5162 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
5163 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
5171 Do_Ovflow_Check
: Boolean;
5174 if Debug_Flag_CC
then
5175 w
("Enable_Overflow_Check for node ", Int
(N
));
5176 Write_Str
(" Source location = ");
5181 -- No check if overflow checks suppressed for type of node
5183 if Overflow_Checks_Suppressed
(Etype
(N
)) then
5186 -- Nothing to do for unsigned integer types, which do not overflow
5188 elsif Is_Modular_Integer_Type
(Typ
) then
5192 -- This is the point at which processing for STRICT mode diverges
5193 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
5194 -- probably more extreme that it needs to be, but what is going on here
5195 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
5196 -- to leave the processing for STRICT mode untouched. There were
5197 -- two reasons for this. First it avoided any incompatible change of
5198 -- behavior. Second, it guaranteed that STRICT mode continued to be
5201 -- The big difference is that in STRICT mode there is a fair amount of
5202 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
5203 -- know that no check is needed. We skip all that in the two new modes,
5204 -- since really overflow checking happens over a whole subtree, and we
5205 -- do the corresponding optimizations later on when applying the checks.
5207 if Mode
in Minimized_Or_Eliminated
then
5208 if not (Overflow_Checks_Suppressed
(Etype
(N
)))
5209 and then not (Is_Entity_Name
(N
)
5210 and then Overflow_Checks_Suppressed
(Entity
(N
)))
5212 Activate_Overflow_Check
(N
);
5215 if Debug_Flag_CC
then
5216 w
("Minimized/Eliminated mode");
5222 -- Remainder of processing is for STRICT case, and is unchanged from
5223 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
5225 -- Nothing to do if the range of the result is known OK. We skip this
5226 -- for conversions, since the caller already did the check, and in any
5227 -- case the condition for deleting the check for a type conversion is
5230 if Nkind
(N
) /= N_Type_Conversion
then
5231 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
5233 -- Note in the test below that we assume that the range is not OK
5234 -- if a bound of the range is equal to that of the type. That's not
5235 -- quite accurate but we do this for the following reasons:
5237 -- a) The way that Determine_Range works, it will typically report
5238 -- the bounds of the value as being equal to the bounds of the
5239 -- type, because it either can't tell anything more precise, or
5240 -- does not think it is worth the effort to be more precise.
5242 -- b) It is very unusual to have a situation in which this would
5243 -- generate an unnecessary overflow check (an example would be
5244 -- a subtype with a range 0 .. Integer'Last - 1 to which the
5245 -- literal value one is added).
5247 -- c) The alternative is a lot of special casing in this routine
5248 -- which would partially duplicate Determine_Range processing.
5251 Do_Ovflow_Check
:= True;
5253 -- Note that the following checks are quite deliberately > and <
5254 -- rather than >= and <= as explained above.
5256 if Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
5258 Hi
< Expr_Value
(Type_High_Bound
(Typ
))
5260 Do_Ovflow_Check
:= False;
5262 -- Despite the comments above, it is worth dealing specially with
5263 -- division specially. The only case where integer division can
5264 -- overflow is (largest negative number) / (-1). So we will do
5265 -- an extra range analysis to see if this is possible.
5267 elsif Nkind
(N
) = N_Op_Divide
then
5269 (Left_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
5271 if OK
and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
)) then
5272 Do_Ovflow_Check
:= False;
5276 (Right_Opnd
(N
), OK
, Lo
, Hi
, Assume_Valid
=> True);
5278 if OK
and then (Lo
> Uint_Minus_1
5282 Do_Ovflow_Check
:= False;
5287 -- If no overflow check required, we are done
5289 if not Do_Ovflow_Check
then
5290 if Debug_Flag_CC
then
5291 w
("No overflow check required");
5299 -- If not in optimizing mode, set flag and we are done. We are also done
5300 -- (and just set the flag) if the type is not a discrete type, since it
5301 -- is not worth the effort to eliminate checks for other than discrete
5302 -- types. In addition, we take this same path if we have stored the
5303 -- maximum number of checks possible already (a very unlikely situation,
5304 -- but we do not want to blow up).
5306 if Optimization_Level
= 0
5307 or else not Is_Discrete_Type
(Etype
(N
))
5308 or else Num_Saved_Checks
= Saved_Checks
'Last
5310 Activate_Overflow_Check
(N
);
5312 if Debug_Flag_CC
then
5313 w
("Optimization off");
5319 -- Otherwise evaluate and check the expression
5324 Target_Type
=> Empty
,
5330 if Debug_Flag_CC
then
5331 w
("Called Find_Check");
5335 w
(" Check_Num = ", Chk
);
5336 w
(" Ent = ", Int
(Ent
));
5337 Write_Str
(" Ofs = ");
5342 -- If check is not of form to optimize, then set flag and we are done
5345 Activate_Overflow_Check
(N
);
5349 -- If check is already performed, then return without setting flag
5352 if Debug_Flag_CC
then
5353 w
("Check suppressed!");
5359 -- Here we will make a new entry for the new check
5361 Activate_Overflow_Check
(N
);
5362 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
5363 Saved_Checks
(Num_Saved_Checks
) :=
5368 Target_Type
=> Empty
);
5370 if Debug_Flag_CC
then
5371 w
("Make new entry, check number = ", Num_Saved_Checks
);
5372 w
(" Entity = ", Int
(Ent
));
5373 Write_Str
(" Offset = ");
5375 w
(" Check_Type = O");
5376 w
(" Target_Type = Empty");
5379 -- If we get an exception, then something went wrong, probably because of
5380 -- an error in the structure of the tree due to an incorrect program. Or
5381 -- it may be a bug in the optimization circuit. In either case the safest
5382 -- thing is simply to set the check flag unconditionally.
5386 Activate_Overflow_Check
(N
);
5388 if Debug_Flag_CC
then
5389 w
(" exception occurred, overflow flag set");
5393 end Enable_Overflow_Check
;
5395 ------------------------
5396 -- Enable_Range_Check --
5397 ------------------------
5399 procedure Enable_Range_Check
(N
: Node_Id
) is
5408 -- Return if unchecked type conversion with range check killed. In this
5409 -- case we never set the flag (that's what Kill_Range_Check is about).
5411 if Nkind
(N
) = N_Unchecked_Type_Conversion
5412 and then Kill_Range_Check
(N
)
5417 -- Do not set range check flag if parent is assignment statement or
5418 -- object declaration with Suppress_Assignment_Checks flag set
5420 if Nkind_In
(Parent
(N
), N_Assignment_Statement
, N_Object_Declaration
)
5421 and then Suppress_Assignment_Checks
(Parent
(N
))
5426 -- Check for various cases where we should suppress the range check
5428 -- No check if range checks suppressed for type of node
5430 if Present
(Etype
(N
)) and then Range_Checks_Suppressed
(Etype
(N
)) then
5433 -- No check if node is an entity name, and range checks are suppressed
5434 -- for this entity, or for the type of this entity.
5436 elsif Is_Entity_Name
(N
)
5437 and then (Range_Checks_Suppressed
(Entity
(N
))
5438 or else Range_Checks_Suppressed
(Etype
(Entity
(N
))))
5442 -- No checks if index of array, and index checks are suppressed for
5443 -- the array object or the type of the array.
5445 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
then
5447 Pref
: constant Node_Id
:= Prefix
(Parent
(N
));
5449 if Is_Entity_Name
(Pref
)
5450 and then Index_Checks_Suppressed
(Entity
(Pref
))
5453 elsif Index_Checks_Suppressed
(Etype
(Pref
)) then
5459 -- Debug trace output
5461 if Debug_Flag_CC
then
5462 w
("Enable_Range_Check for node ", Int
(N
));
5463 Write_Str
(" Source location = ");
5468 -- If not in optimizing mode, set flag and we are done. We are also done
5469 -- (and just set the flag) if the type is not a discrete type, since it
5470 -- is not worth the effort to eliminate checks for other than discrete
5471 -- types. In addition, we take this same path if we have stored the
5472 -- maximum number of checks possible already (a very unlikely situation,
5473 -- but we do not want to blow up).
5475 if Optimization_Level
= 0
5476 or else No
(Etype
(N
))
5477 or else not Is_Discrete_Type
(Etype
(N
))
5478 or else Num_Saved_Checks
= Saved_Checks
'Last
5480 Activate_Range_Check
(N
);
5482 if Debug_Flag_CC
then
5483 w
("Optimization off");
5489 -- Otherwise find out the target type
5493 -- For assignment, use left side subtype
5495 if Nkind
(P
) = N_Assignment_Statement
5496 and then Expression
(P
) = N
5498 Ttyp
:= Etype
(Name
(P
));
5500 -- For indexed component, use subscript subtype
5502 elsif Nkind
(P
) = N_Indexed_Component
then
5509 Atyp
:= Etype
(Prefix
(P
));
5511 if Is_Access_Type
(Atyp
) then
5512 Atyp
:= Designated_Type
(Atyp
);
5514 -- If the prefix is an access to an unconstrained array,
5515 -- perform check unconditionally: it depends on the bounds of
5516 -- an object and we cannot currently recognize whether the test
5517 -- may be redundant.
5519 if not Is_Constrained
(Atyp
) then
5520 Activate_Range_Check
(N
);
5524 -- Ditto if the prefix is an explicit dereference whose designated
5525 -- type is unconstrained.
5527 elsif Nkind
(Prefix
(P
)) = N_Explicit_Dereference
5528 and then not Is_Constrained
(Atyp
)
5530 Activate_Range_Check
(N
);
5534 Indx
:= First_Index
(Atyp
);
5535 Subs
:= First
(Expressions
(P
));
5538 Ttyp
:= Etype
(Indx
);
5547 -- For now, ignore all other cases, they are not so interesting
5550 if Debug_Flag_CC
then
5551 w
(" target type not found, flag set");
5554 Activate_Range_Check
(N
);
5558 -- Evaluate and check the expression
5563 Target_Type
=> Ttyp
,
5569 if Debug_Flag_CC
then
5570 w
("Called Find_Check");
5571 w
("Target_Typ = ", Int
(Ttyp
));
5575 w
(" Check_Num = ", Chk
);
5576 w
(" Ent = ", Int
(Ent
));
5577 Write_Str
(" Ofs = ");
5582 -- If check is not of form to optimize, then set flag and we are done
5585 if Debug_Flag_CC
then
5586 w
(" expression not of optimizable type, flag set");
5589 Activate_Range_Check
(N
);
5593 -- If check is already performed, then return without setting flag
5596 if Debug_Flag_CC
then
5597 w
("Check suppressed!");
5603 -- Here we will make a new entry for the new check
5605 Activate_Range_Check
(N
);
5606 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
5607 Saved_Checks
(Num_Saved_Checks
) :=
5612 Target_Type
=> Ttyp
);
5614 if Debug_Flag_CC
then
5615 w
("Make new entry, check number = ", Num_Saved_Checks
);
5616 w
(" Entity = ", Int
(Ent
));
5617 Write_Str
(" Offset = ");
5619 w
(" Check_Type = R");
5620 w
(" Target_Type = ", Int
(Ttyp
));
5621 pg
(Union_Id
(Ttyp
));
5624 -- If we get an exception, then something went wrong, probably because of
5625 -- an error in the structure of the tree due to an incorrect program. Or
5626 -- it may be a bug in the optimization circuit. In either case the safest
5627 -- thing is simply to set the check flag unconditionally.
5631 Activate_Range_Check
(N
);
5633 if Debug_Flag_CC
then
5634 w
(" exception occurred, range flag set");
5638 end Enable_Range_Check
;
5644 procedure Ensure_Valid
5646 Holes_OK
: Boolean := False;
5647 Related_Id
: Entity_Id
:= Empty
;
5648 Is_Low_Bound
: Boolean := False;
5649 Is_High_Bound
: Boolean := False)
5651 Typ
: constant Entity_Id
:= Etype
(Expr
);
5654 -- Ignore call if we are not doing any validity checking
5656 if not Validity_Checks_On
then
5659 -- Ignore call if range or validity checks suppressed on entity or type
5661 elsif Range_Or_Validity_Checks_Suppressed
(Expr
) then
5664 -- No check required if expression is from the expander, we assume the
5665 -- expander will generate whatever checks are needed. Note that this is
5666 -- not just an optimization, it avoids infinite recursions.
5668 -- Unchecked conversions must be checked, unless they are initialized
5669 -- scalar values, as in a component assignment in an init proc.
5671 -- In addition, we force a check if Force_Validity_Checks is set
5673 elsif not Comes_From_Source
(Expr
)
5674 and then not Force_Validity_Checks
5675 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
5676 or else Kill_Range_Check
(Expr
))
5680 -- No check required if expression is known to have valid value
5682 elsif Expr_Known_Valid
(Expr
) then
5685 -- Ignore case of enumeration with holes where the flag is set not to
5686 -- worry about holes, since no special validity check is needed
5688 elsif Is_Enumeration_Type
(Typ
)
5689 and then Has_Non_Standard_Rep
(Typ
)
5694 -- No check required on the left-hand side of an assignment
5696 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
5697 and then Expr
= Name
(Parent
(Expr
))
5701 -- No check on a universal real constant. The context will eventually
5702 -- convert it to a machine number for some target type, or report an
5705 elsif Nkind
(Expr
) = N_Real_Literal
5706 and then Etype
(Expr
) = Universal_Real
5710 -- If the expression denotes a component of a packed boolean array,
5711 -- no possible check applies. We ignore the old ACATS chestnuts that
5712 -- involve Boolean range True..True.
5714 -- Note: validity checks are generated for expressions that yield a
5715 -- scalar type, when it is possible to create a value that is outside of
5716 -- the type. If this is a one-bit boolean no such value exists. This is
5717 -- an optimization, and it also prevents compiler blowing up during the
5718 -- elaboration of improperly expanded packed array references.
5720 elsif Nkind
(Expr
) = N_Indexed_Component
5721 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Expr
)))
5722 and then Root_Type
(Etype
(Expr
)) = Standard_Boolean
5726 -- For an expression with actions, we want to insert the validity check
5727 -- on the final Expression.
5729 elsif Nkind
(Expr
) = N_Expression_With_Actions
then
5730 Ensure_Valid
(Expression
(Expr
));
5733 -- An annoying special case. If this is an out parameter of a scalar
5734 -- type, then the value is not going to be accessed, therefore it is
5735 -- inappropriate to do any validity check at the call site.
5738 -- Only need to worry about scalar types
5740 if Is_Scalar_Type
(Typ
) then
5750 -- Find actual argument (which may be a parameter association)
5751 -- and the parent of the actual argument (the call statement)
5756 if Nkind
(P
) = N_Parameter_Association
then
5761 -- Only need to worry if we are argument of a procedure call
5762 -- since functions don't have out parameters. If this is an
5763 -- indirect or dispatching call, get signature from the
5766 if Nkind
(P
) = N_Procedure_Call_Statement
then
5767 L
:= Parameter_Associations
(P
);
5769 if Is_Entity_Name
(Name
(P
)) then
5770 E
:= Entity
(Name
(P
));
5772 pragma Assert
(Nkind
(Name
(P
)) = N_Explicit_Dereference
);
5773 E
:= Etype
(Name
(P
));
5776 -- Only need to worry if there are indeed actuals, and if
5777 -- this could be a procedure call, otherwise we cannot get a
5778 -- match (either we are not an argument, or the mode of the
5779 -- formal is not OUT). This test also filters out the
5782 if Is_Non_Empty_List
(L
) and then Is_Subprogram
(E
) then
5784 -- This is the loop through parameters, looking for an
5785 -- OUT parameter for which we are the argument.
5787 F
:= First_Formal
(E
);
5789 while Present
(F
) loop
5790 if Ekind
(F
) = E_Out_Parameter
and then A
= N
then
5803 -- If this is a boolean expression, only its elementary operands need
5804 -- checking: if they are valid, a boolean or short-circuit operation
5805 -- with them will be valid as well.
5807 if Base_Type
(Typ
) = Standard_Boolean
5809 (Nkind
(Expr
) in N_Op
or else Nkind
(Expr
) in N_Short_Circuit
)
5814 -- If we fall through, a validity check is required
5816 Insert_Valid_Check
(Expr
, Related_Id
, Is_Low_Bound
, Is_High_Bound
);
5818 if Is_Entity_Name
(Expr
)
5819 and then Safe_To_Capture_Value
(Expr
, Entity
(Expr
))
5821 Set_Is_Known_Valid
(Entity
(Expr
));
5825 ----------------------
5826 -- Expr_Known_Valid --
5827 ----------------------
5829 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
5830 Typ
: constant Entity_Id
:= Etype
(Expr
);
5833 -- Non-scalar types are always considered valid, since they never give
5834 -- rise to the issues of erroneous or bounded error behavior that are
5835 -- the concern. In formal reference manual terms the notion of validity
5836 -- only applies to scalar types. Note that even when packed arrays are
5837 -- represented using modular types, they are still arrays semantically,
5838 -- so they are also always valid (in particular, the unused bits can be
5839 -- random rubbish without affecting the validity of the array value).
5841 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Impl_Type
(Typ
) then
5844 -- If no validity checking, then everything is considered valid
5846 elsif not Validity_Checks_On
then
5849 -- Floating-point types are considered valid unless floating-point
5850 -- validity checks have been specifically turned on.
5852 elsif Is_Floating_Point_Type
(Typ
)
5853 and then not Validity_Check_Floating_Point
5857 -- If the expression is the value of an object that is known to be
5858 -- valid, then clearly the expression value itself is valid.
5860 elsif Is_Entity_Name
(Expr
)
5861 and then Is_Known_Valid
(Entity
(Expr
))
5863 -- Exclude volatile variables
5865 and then not Treat_As_Volatile
(Entity
(Expr
))
5869 -- References to discriminants are always considered valid. The value
5870 -- of a discriminant gets checked when the object is built. Within the
5871 -- record, we consider it valid, and it is important to do so, since
5872 -- otherwise we can try to generate bogus validity checks which
5873 -- reference discriminants out of scope. Discriminants of concurrent
5874 -- types are excluded for the same reason.
5876 elsif Is_Entity_Name
(Expr
)
5877 and then Denotes_Discriminant
(Expr
, Check_Concurrent
=> True)
5881 -- If the type is one for which all values are known valid, then we are
5882 -- sure that the value is valid except in the slightly odd case where
5883 -- the expression is a reference to a variable whose size has been
5884 -- explicitly set to a value greater than the object size.
5886 elsif Is_Known_Valid
(Typ
) then
5887 if Is_Entity_Name
(Expr
)
5888 and then Ekind
(Entity
(Expr
)) = E_Variable
5889 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
5896 -- Integer and character literals always have valid values, where
5897 -- appropriate these will be range checked in any case.
5899 elsif Nkind_In
(Expr
, N_Integer_Literal
, N_Character_Literal
) then
5902 -- Real literals are assumed to be valid in VM targets
5904 elsif VM_Target
/= No_VM
and then Nkind
(Expr
) = N_Real_Literal
then
5907 -- If we have a type conversion or a qualification of a known valid
5908 -- value, then the result will always be valid.
5910 elsif Nkind_In
(Expr
, N_Type_Conversion
, N_Qualified_Expression
) then
5911 return Expr_Known_Valid
(Expression
(Expr
));
5913 -- Case of expression is a non-floating-point operator. In this case we
5914 -- can assume the result is valid the generated code for the operator
5915 -- will include whatever checks are needed (e.g. range checks) to ensure
5916 -- validity. This assumption does not hold for the floating-point case,
5917 -- since floating-point operators can generate Infinite or NaN results
5918 -- which are considered invalid.
5920 -- Historical note: in older versions, the exemption of floating-point
5921 -- types from this assumption was done only in cases where the parent
5922 -- was an assignment, function call or parameter association. Presumably
5923 -- the idea was that in other contexts, the result would be checked
5924 -- elsewhere, but this list of cases was missing tests (at least the
5925 -- N_Object_Declaration case, as shown by a reported missing validity
5926 -- check), and it is not clear why function calls but not procedure
5927 -- calls were tested for. It really seems more accurate and much
5928 -- safer to recognize that expressions which are the result of a
5929 -- floating-point operator can never be assumed to be valid.
5931 elsif Nkind
(Expr
) in N_Op
and then not Is_Floating_Point_Type
(Typ
) then
5934 -- The result of a membership test is always valid, since it is true or
5935 -- false, there are no other possibilities.
5937 elsif Nkind
(Expr
) in N_Membership_Test
then
5940 -- For all other cases, we do not know the expression is valid
5945 end Expr_Known_Valid
;
5951 procedure Find_Check
5953 Check_Type
: Character;
5954 Target_Type
: Entity_Id
;
5955 Entry_OK
: out Boolean;
5956 Check_Num
: out Nat
;
5957 Ent
: out Entity_Id
;
5960 function Within_Range_Of
5961 (Target_Type
: Entity_Id
;
5962 Check_Type
: Entity_Id
) return Boolean;
5963 -- Given a requirement for checking a range against Target_Type, and
5964 -- and a range Check_Type against which a check has already been made,
5965 -- determines if the check against check type is sufficient to ensure
5966 -- that no check against Target_Type is required.
5968 ---------------------
5969 -- Within_Range_Of --
5970 ---------------------
5972 function Within_Range_Of
5973 (Target_Type
: Entity_Id
;
5974 Check_Type
: Entity_Id
) return Boolean
5977 if Target_Type
= Check_Type
then
5982 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
5983 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
5984 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
5985 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
5989 or else (Compile_Time_Known_Value
(Tlo
)
5991 Compile_Time_Known_Value
(Clo
)
5993 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
5996 or else (Compile_Time_Known_Value
(Thi
)
5998 Compile_Time_Known_Value
(Chi
)
6000 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
6008 end Within_Range_Of
;
6010 -- Start of processing for Find_Check
6013 -- Establish default, in case no entry is found
6017 -- Case of expression is simple entity reference
6019 if Is_Entity_Name
(Expr
) then
6020 Ent
:= Entity
(Expr
);
6023 -- Case of expression is entity + known constant
6025 elsif Nkind
(Expr
) = N_Op_Add
6026 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
6027 and then Is_Entity_Name
(Left_Opnd
(Expr
))
6029 Ent
:= Entity
(Left_Opnd
(Expr
));
6030 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
6032 -- Case of expression is entity - known constant
6034 elsif Nkind
(Expr
) = N_Op_Subtract
6035 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
6036 and then Is_Entity_Name
(Left_Opnd
(Expr
))
6038 Ent
:= Entity
(Left_Opnd
(Expr
));
6039 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
6041 -- Any other expression is not of the right form
6050 -- Come here with expression of appropriate form, check if entity is an
6051 -- appropriate one for our purposes.
6053 if (Ekind
(Ent
) = E_Variable
6054 or else Is_Constant_Object
(Ent
))
6055 and then not Is_Library_Level_Entity
(Ent
)
6063 -- See if there is matching check already
6065 for J
in reverse 1 .. Num_Saved_Checks
loop
6067 SC
: Saved_Check
renames Saved_Checks
(J
);
6069 if SC
.Killed
= False
6070 and then SC
.Entity
= Ent
6071 and then SC
.Offset
= Ofs
6072 and then SC
.Check_Type
= Check_Type
6073 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
6081 -- If we fall through entry was not found
6086 ---------------------------------
6087 -- Generate_Discriminant_Check --
6088 ---------------------------------
6090 -- Note: the code for this procedure is derived from the
6091 -- Emit_Discriminant_Check Routine in trans.c.
6093 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
6094 Loc
: constant Source_Ptr
:= Sloc
(N
);
6095 Pref
: constant Node_Id
:= Prefix
(N
);
6096 Sel
: constant Node_Id
:= Selector_Name
(N
);
6098 Orig_Comp
: constant Entity_Id
:=
6099 Original_Record_Component
(Entity
(Sel
));
6100 -- The original component to be checked
6102 Discr_Fct
: constant Entity_Id
:=
6103 Discriminant_Checking_Func
(Orig_Comp
);
6104 -- The discriminant checking function
6107 -- One discriminant to be checked in the type
6109 Real_Discr
: Entity_Id
;
6110 -- Actual discriminant in the call
6112 Pref_Type
: Entity_Id
;
6113 -- Type of relevant prefix (ignoring private/access stuff)
6116 -- List of arguments for function call
6119 -- Keep track of the formal corresponding to the actual we build for
6120 -- each discriminant, in order to be able to perform the necessary type
6124 -- Selected component reference for checking function argument
6127 Pref_Type
:= Etype
(Pref
);
6129 -- Force evaluation of the prefix, so that it does not get evaluated
6130 -- twice (once for the check, once for the actual reference). Such a
6131 -- double evaluation is always a potential source of inefficiency, and
6132 -- is functionally incorrect in the volatile case, or when the prefix
6133 -- may have side-effects. A non-volatile entity or a component of a
6134 -- non-volatile entity requires no evaluation.
6136 if Is_Entity_Name
(Pref
) then
6137 if Treat_As_Volatile
(Entity
(Pref
)) then
6138 Force_Evaluation
(Pref
, Name_Req
=> True);
6141 elsif Treat_As_Volatile
(Etype
(Pref
)) then
6142 Force_Evaluation
(Pref
, Name_Req
=> True);
6144 elsif Nkind
(Pref
) = N_Selected_Component
6145 and then Is_Entity_Name
(Prefix
(Pref
))
6150 Force_Evaluation
(Pref
, Name_Req
=> True);
6153 -- For a tagged type, use the scope of the original component to
6154 -- obtain the type, because ???
6156 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
6157 Pref_Type
:= Scope
(Orig_Comp
);
6159 -- For an untagged derived type, use the discriminants of the parent
6160 -- which have been renamed in the derivation, possibly by a one-to-many
6161 -- discriminant constraint. For untagged type, initially get the Etype
6165 if Is_Derived_Type
(Pref_Type
)
6166 and then Number_Discriminants
(Pref_Type
) /=
6167 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
6169 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
6173 -- We definitely should have a checking function, This routine should
6174 -- not be called if no discriminant checking function is present.
6176 pragma Assert
(Present
(Discr_Fct
));
6178 -- Create the list of the actual parameters for the call. This list
6179 -- is the list of the discriminant fields of the record expression to
6180 -- be discriminant checked.
6183 Formal
:= First_Formal
(Discr_Fct
);
6184 Discr
:= First_Discriminant
(Pref_Type
);
6185 while Present
(Discr
) loop
6187 -- If we have a corresponding discriminant field, and a parent
6188 -- subtype is present, then we want to use the corresponding
6189 -- discriminant since this is the one with the useful value.
6191 if Present
(Corresponding_Discriminant
(Discr
))
6192 and then Ekind
(Pref_Type
) = E_Record_Type
6193 and then Present
(Parent_Subtype
(Pref_Type
))
6195 Real_Discr
:= Corresponding_Discriminant
(Discr
);
6197 Real_Discr
:= Discr
;
6200 -- Construct the reference to the discriminant
6203 Make_Selected_Component
(Loc
,
6205 Unchecked_Convert_To
(Pref_Type
,
6206 Duplicate_Subexpr
(Pref
)),
6207 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
6209 -- Manually analyze and resolve this selected component. We really
6210 -- want it just as it appears above, and do not want the expander
6211 -- playing discriminal games etc with this reference. Then we append
6212 -- the argument to the list we are gathering.
6214 Set_Etype
(Scomp
, Etype
(Real_Discr
));
6215 Set_Analyzed
(Scomp
, True);
6216 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
6218 Next_Formal_With_Extras
(Formal
);
6219 Next_Discriminant
(Discr
);
6222 -- Now build and insert the call
6225 Make_Raise_Constraint_Error
(Loc
,
6227 Make_Function_Call
(Loc
,
6228 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
6229 Parameter_Associations
=> Args
),
6230 Reason
=> CE_Discriminant_Check_Failed
));
6231 end Generate_Discriminant_Check
;
6233 ---------------------------
6234 -- Generate_Index_Checks --
6235 ---------------------------
6237 procedure Generate_Index_Checks
(N
: Node_Id
) is
6239 function Entity_Of_Prefix
return Entity_Id
;
6240 -- Returns the entity of the prefix of N (or Empty if not found)
6242 ----------------------
6243 -- Entity_Of_Prefix --
6244 ----------------------
6246 function Entity_Of_Prefix
return Entity_Id
is
6251 while not Is_Entity_Name
(P
) loop
6252 if not Nkind_In
(P
, N_Selected_Component
,
6253 N_Indexed_Component
)
6262 end Entity_Of_Prefix
;
6266 Loc
: constant Source_Ptr
:= Sloc
(N
);
6267 A
: constant Node_Id
:= Prefix
(N
);
6268 A_Ent
: constant Entity_Id
:= Entity_Of_Prefix
;
6271 -- Start of processing for Generate_Index_Checks
6274 -- Ignore call if the prefix is not an array since we have a serious
6275 -- error in the sources. Ignore it also if index checks are suppressed
6276 -- for array object or type.
6278 if not Is_Array_Type
(Etype
(A
))
6279 or else (Present
(A_Ent
) and then Index_Checks_Suppressed
(A_Ent
))
6280 or else Index_Checks_Suppressed
(Etype
(A
))
6284 -- The indexed component we are dealing with contains 'Loop_Entry in its
6285 -- prefix. This case arises when analysis has determined that constructs
6288 -- Prefix'Loop_Entry (Expr)
6289 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
6291 -- require rewriting for error detection purposes. A side effect of this
6292 -- action is the generation of index checks that mention 'Loop_Entry.
6293 -- Delay the generation of the check until 'Loop_Entry has been properly
6294 -- expanded. This is done in Expand_Loop_Entry_Attributes.
6296 elsif Nkind
(Prefix
(N
)) = N_Attribute_Reference
6297 and then Attribute_Name
(Prefix
(N
)) = Name_Loop_Entry
6302 -- Generate a raise of constraint error with the appropriate reason and
6303 -- a condition of the form:
6305 -- Base_Type (Sub) not in Array'Range (Subscript)
6307 -- Note that the reason we generate the conversion to the base type here
6308 -- is that we definitely want the range check to take place, even if it
6309 -- looks like the subtype is OK. Optimization considerations that allow
6310 -- us to omit the check have already been taken into account in the
6311 -- setting of the Do_Range_Check flag earlier on.
6313 Sub
:= First
(Expressions
(N
));
6315 -- Handle string literals
6317 if Ekind
(Etype
(A
)) = E_String_Literal_Subtype
then
6318 if Do_Range_Check
(Sub
) then
6319 Set_Do_Range_Check
(Sub
, False);
6321 -- For string literals we obtain the bounds of the string from the
6322 -- associated subtype.
6325 Make_Raise_Constraint_Error
(Loc
,
6329 Convert_To
(Base_Type
(Etype
(Sub
)),
6330 Duplicate_Subexpr_Move_Checks
(Sub
)),
6332 Make_Attribute_Reference
(Loc
,
6333 Prefix
=> New_Occurrence_Of
(Etype
(A
), Loc
),
6334 Attribute_Name
=> Name_Range
)),
6335 Reason
=> CE_Index_Check_Failed
));
6342 A_Idx
: Node_Id
:= Empty
;
6349 A_Idx
:= First_Index
(Etype
(A
));
6351 while Present
(Sub
) loop
6352 if Do_Range_Check
(Sub
) then
6353 Set_Do_Range_Check
(Sub
, False);
6355 -- Force evaluation except for the case of a simple name of
6356 -- a non-volatile entity.
6358 if not Is_Entity_Name
(Sub
)
6359 or else Treat_As_Volatile
(Entity
(Sub
))
6361 Force_Evaluation
(Sub
);
6364 if Nkind
(A_Idx
) = N_Range
then
6367 elsif Nkind
(A_Idx
) = N_Identifier
6368 or else Nkind
(A_Idx
) = N_Expanded_Name
6370 A_Range
:= Scalar_Range
(Entity
(A_Idx
));
6372 else pragma Assert
(Nkind
(A_Idx
) = N_Subtype_Indication
);
6373 A_Range
:= Range_Expression
(Constraint
(A_Idx
));
6376 -- For array objects with constant bounds we can generate
6377 -- the index check using the bounds of the type of the index
6380 and then Ekind
(A_Ent
) = E_Variable
6381 and then Is_Constant_Bound
(Low_Bound
(A_Range
))
6382 and then Is_Constant_Bound
(High_Bound
(A_Range
))
6385 Make_Attribute_Reference
(Loc
,
6387 New_Occurrence_Of
(Etype
(A_Idx
), Loc
),
6388 Attribute_Name
=> Name_Range
);
6390 -- For arrays with non-constant bounds we cannot generate
6391 -- the index check using the bounds of the type of the index
6392 -- since it may reference discriminants of some enclosing
6393 -- type. We obtain the bounds directly from the prefix
6400 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
6404 Make_Attribute_Reference
(Loc
,
6406 Duplicate_Subexpr_Move_Checks
(A
, Name_Req
=> True),
6407 Attribute_Name
=> Name_Range
,
6408 Expressions
=> Num
);
6412 Make_Raise_Constraint_Error
(Loc
,
6416 Convert_To
(Base_Type
(Etype
(Sub
)),
6417 Duplicate_Subexpr_Move_Checks
(Sub
)),
6418 Right_Opnd
=> Range_N
),
6419 Reason
=> CE_Index_Check_Failed
));
6422 A_Idx
:= Next_Index
(A_Idx
);
6428 end Generate_Index_Checks
;
6430 --------------------------
6431 -- Generate_Range_Check --
6432 --------------------------
6434 procedure Generate_Range_Check
6436 Target_Type
: Entity_Id
;
6437 Reason
: RT_Exception_Code
)
6439 Loc
: constant Source_Ptr
:= Sloc
(N
);
6440 Source_Type
: constant Entity_Id
:= Etype
(N
);
6441 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
6442 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
6444 procedure Convert_And_Check_Range
;
6445 -- Convert the conversion operand to the target base type and save in
6446 -- a temporary. Then check the converted value against the range of the
6449 -----------------------------
6450 -- Convert_And_Check_Range --
6451 -----------------------------
6453 procedure Convert_And_Check_Range
is
6454 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
6457 -- We make a temporary to hold the value of the converted value
6458 -- (converted to the base type), and then do the test against this
6459 -- temporary. The conversion itself is replaced by an occurrence of
6460 -- Tnn and followed by the explicit range check. Note that checks
6461 -- are suppressed for this code, since we don't want a recursive
6462 -- range check popping up.
6464 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
6465 -- [constraint_error when Tnn not in Target_Type]
6467 Insert_Actions
(N
, New_List
(
6468 Make_Object_Declaration
(Loc
,
6469 Defining_Identifier
=> Tnn
,
6470 Object_Definition
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
6471 Constant_Present
=> True,
6473 Make_Type_Conversion
(Loc
,
6474 Subtype_Mark
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
6475 Expression
=> Duplicate_Subexpr
(N
))),
6477 Make_Raise_Constraint_Error
(Loc
,
6480 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
6481 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
6483 Suppress
=> All_Checks
);
6485 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
6487 -- Set the type of N, because the declaration for Tnn might not
6488 -- be analyzed yet, as is the case if N appears within a record
6489 -- declaration, as a discriminant constraint or expression.
6491 Set_Etype
(N
, Target_Base_Type
);
6492 end Convert_And_Check_Range
;
6494 -- Start of processing for Generate_Range_Check
6497 -- First special case, if the source type is already within the range
6498 -- of the target type, then no check is needed (probably we should have
6499 -- stopped Do_Range_Check from being set in the first place, but better
6500 -- late than never in preventing junk code and junk flag settings.
6502 if In_Subrange_Of
(Source_Type
, Target_Type
)
6504 -- We do NOT apply this if the source node is a literal, since in this
6505 -- case the literal has already been labeled as having the subtype of
6509 (Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
, N_Character_Literal
)
6512 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
6514 Set_Do_Range_Check
(N
, False);
6518 -- Here a check is needed. If the expander is not active, or if we are
6519 -- in GNATProve mode, then simply set the Do_Range_Check flag and we
6520 -- are done. In both these cases, we just want to see the range check
6521 -- flag set, we do not want to generate the explicit range check code.
6523 if GNATprove_Mode
or else not Expander_Active
then
6524 Set_Do_Range_Check
(N
, True);
6528 -- Here we will generate an explicit range check, so we don't want to
6529 -- set the Do_Range check flag, since the range check is taken care of
6530 -- by the code we will generate.
6532 Set_Do_Range_Check
(N
, False);
6534 -- Force evaluation of the node, so that it does not get evaluated twice
6535 -- (once for the check, once for the actual reference). Such a double
6536 -- evaluation is always a potential source of inefficiency, and is
6537 -- functionally incorrect in the volatile case.
6539 if not Is_Entity_Name
(N
) or else Treat_As_Volatile
(Entity
(N
)) then
6540 Force_Evaluation
(N
);
6543 -- The easiest case is when Source_Base_Type and Target_Base_Type are
6544 -- the same since in this case we can simply do a direct check of the
6545 -- value of N against the bounds of Target_Type.
6547 -- [constraint_error when N not in Target_Type]
6549 -- Note: this is by far the most common case, for example all cases of
6550 -- checks on the RHS of assignments are in this category, but not all
6551 -- cases are like this. Notably conversions can involve two types.
6553 if Source_Base_Type
= Target_Base_Type
then
6555 -- Insert the explicit range check. Note that we suppress checks for
6556 -- this code, since we don't want a recursive range check popping up.
6559 Make_Raise_Constraint_Error
(Loc
,
6562 Left_Opnd
=> Duplicate_Subexpr
(N
),
6563 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
6565 Suppress
=> All_Checks
);
6567 -- Next test for the case where the target type is within the bounds
6568 -- of the base type of the source type, since in this case we can
6569 -- simply convert these bounds to the base type of T to do the test.
6571 -- [constraint_error when N not in
6572 -- Source_Base_Type (Target_Type'First)
6574 -- Source_Base_Type(Target_Type'Last))]
6576 -- The conversions will always work and need no check
6578 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
6579 -- of converting from an enumeration value to an integer type, such as
6580 -- occurs for the case of generating a range check on Enum'Val(Exp)
6581 -- (which used to be handled by gigi). This is OK, since the conversion
6582 -- itself does not require a check.
6584 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
6586 -- Insert the explicit range check. Note that we suppress checks for
6587 -- this code, since we don't want a recursive range check popping up.
6589 if Is_Discrete_Type
(Source_Base_Type
)
6591 Is_Discrete_Type
(Target_Base_Type
)
6594 Make_Raise_Constraint_Error
(Loc
,
6597 Left_Opnd
=> Duplicate_Subexpr
(N
),
6602 Unchecked_Convert_To
(Source_Base_Type
,
6603 Make_Attribute_Reference
(Loc
,
6605 New_Occurrence_Of
(Target_Type
, Loc
),
6606 Attribute_Name
=> Name_First
)),
6609 Unchecked_Convert_To
(Source_Base_Type
,
6610 Make_Attribute_Reference
(Loc
,
6612 New_Occurrence_Of
(Target_Type
, Loc
),
6613 Attribute_Name
=> Name_Last
)))),
6615 Suppress
=> All_Checks
);
6617 -- For conversions involving at least one type that is not discrete,
6618 -- first convert to target type and then generate the range check.
6619 -- This avoids problems with values that are close to a bound of the
6620 -- target type that would fail a range check when done in a larger
6621 -- source type before converting but would pass if converted with
6622 -- rounding and then checked (such as in float-to-float conversions).
6625 Convert_And_Check_Range
;
6628 -- Note that at this stage we now that the Target_Base_Type is not in
6629 -- the range of the Source_Base_Type (since even the Target_Type itself
6630 -- is not in this range). It could still be the case that Source_Type is
6631 -- in range of the target base type since we have not checked that case.
6633 -- If that is the case, we can freely convert the source to the target,
6634 -- and then test the target result against the bounds.
6636 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
6637 Convert_And_Check_Range
;
6639 -- At this stage, we know that we have two scalar types, which are
6640 -- directly convertible, and where neither scalar type has a base
6641 -- range that is in the range of the other scalar type.
6643 -- The only way this can happen is with a signed and unsigned type.
6644 -- So test for these two cases:
6647 -- Case of the source is unsigned and the target is signed
6649 if Is_Unsigned_Type
(Source_Base_Type
)
6650 and then not Is_Unsigned_Type
(Target_Base_Type
)
6652 -- If the source is unsigned and the target is signed, then we
6653 -- know that the source is not shorter than the target (otherwise
6654 -- the source base type would be in the target base type range).
6656 -- In other words, the unsigned type is either the same size as
6657 -- the target, or it is larger. It cannot be smaller.
6660 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
6662 -- We only need to check the low bound if the low bound of the
6663 -- target type is non-negative. If the low bound of the target
6664 -- type is negative, then we know that we will fit fine.
6666 -- If the high bound of the target type is negative, then we
6667 -- know we have a constraint error, since we can't possibly
6668 -- have a negative source.
6670 -- With these two checks out of the way, we can do the check
6671 -- using the source type safely
6673 -- This is definitely the most annoying case.
6675 -- [constraint_error
6676 -- when (Target_Type'First >= 0
6678 -- N < Source_Base_Type (Target_Type'First))
6679 -- or else Target_Type'Last < 0
6680 -- or else N > Source_Base_Type (Target_Type'Last)];
6682 -- We turn off all checks since we know that the conversions
6683 -- will work fine, given the guards for negative values.
6686 Make_Raise_Constraint_Error
(Loc
,
6692 Left_Opnd
=> Make_Op_Ge
(Loc
,
6694 Make_Attribute_Reference
(Loc
,
6696 New_Occurrence_Of
(Target_Type
, Loc
),
6697 Attribute_Name
=> Name_First
),
6698 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
6702 Left_Opnd
=> Duplicate_Subexpr
(N
),
6704 Convert_To
(Source_Base_Type
,
6705 Make_Attribute_Reference
(Loc
,
6707 New_Occurrence_Of
(Target_Type
, Loc
),
6708 Attribute_Name
=> Name_First
)))),
6713 Make_Attribute_Reference
(Loc
,
6714 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
6715 Attribute_Name
=> Name_Last
),
6716 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
6720 Left_Opnd
=> Duplicate_Subexpr
(N
),
6722 Convert_To
(Source_Base_Type
,
6723 Make_Attribute_Reference
(Loc
,
6724 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
6725 Attribute_Name
=> Name_Last
)))),
6728 Suppress
=> All_Checks
);
6730 -- Only remaining possibility is that the source is signed and
6731 -- the target is unsigned.
6734 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
6735 and then Is_Unsigned_Type
(Target_Base_Type
));
6737 -- If the source is signed and the target is unsigned, then we
6738 -- know that the target is not shorter than the source (otherwise
6739 -- the target base type would be in the source base type range).
6741 -- In other words, the unsigned type is either the same size as
6742 -- the target, or it is larger. It cannot be smaller.
6744 -- Clearly we have an error if the source value is negative since
6745 -- no unsigned type can have negative values. If the source type
6746 -- is non-negative, then the check can be done using the target
6749 -- Tnn : constant Target_Base_Type (N) := Target_Type;
6751 -- [constraint_error
6752 -- when N < 0 or else Tnn not in Target_Type];
6754 -- We turn off all checks for the conversion of N to the target
6755 -- base type, since we generate the explicit check to ensure that
6756 -- the value is non-negative
6759 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
6762 Insert_Actions
(N
, New_List
(
6763 Make_Object_Declaration
(Loc
,
6764 Defining_Identifier
=> Tnn
,
6765 Object_Definition
=>
6766 New_Occurrence_Of
(Target_Base_Type
, Loc
),
6767 Constant_Present
=> True,
6769 Make_Unchecked_Type_Conversion
(Loc
,
6771 New_Occurrence_Of
(Target_Base_Type
, Loc
),
6772 Expression
=> Duplicate_Subexpr
(N
))),
6774 Make_Raise_Constraint_Error
(Loc
,
6779 Left_Opnd
=> Duplicate_Subexpr
(N
),
6780 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
6784 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
6786 New_Occurrence_Of
(Target_Type
, Loc
))),
6789 Suppress
=> All_Checks
);
6791 -- Set the Etype explicitly, because Insert_Actions may have
6792 -- placed the declaration in the freeze list for an enclosing
6793 -- construct, and thus it is not analyzed yet.
6795 Set_Etype
(Tnn
, Target_Base_Type
);
6796 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
6800 end Generate_Range_Check
;
6806 function Get_Check_Id
(N
: Name_Id
) return Check_Id
is
6808 -- For standard check name, we can do a direct computation
6810 if N
in First_Check_Name
.. Last_Check_Name
then
6811 return Check_Id
(N
- (First_Check_Name
- 1));
6813 -- For non-standard names added by pragma Check_Name, search table
6816 for J
in All_Checks
+ 1 .. Check_Names
.Last
loop
6817 if Check_Names
.Table
(J
) = N
then
6823 -- No matching name found
6828 ---------------------
6829 -- Get_Discriminal --
6830 ---------------------
6832 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
6833 Loc
: constant Source_Ptr
:= Sloc
(E
);
6838 -- The bound can be a bona fide parameter of a protected operation,
6839 -- rather than a prival encoded as an in-parameter.
6841 if No
(Discriminal_Link
(Entity
(Bound
))) then
6845 -- Climb the scope stack looking for an enclosing protected type. If
6846 -- we run out of scopes, return the bound itself.
6849 while Present
(Sc
) loop
6850 if Sc
= Standard_Standard
then
6852 elsif Ekind
(Sc
) = E_Protected_Type
then
6859 D
:= First_Discriminant
(Sc
);
6860 while Present
(D
) loop
6861 if Chars
(D
) = Chars
(Bound
) then
6862 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
6865 Next_Discriminant
(D
);
6869 end Get_Discriminal
;
6871 ----------------------
6872 -- Get_Range_Checks --
6873 ----------------------
6875 function Get_Range_Checks
6877 Target_Typ
: Entity_Id
;
6878 Source_Typ
: Entity_Id
:= Empty
;
6879 Warn_Node
: Node_Id
:= Empty
) return Check_Result
6883 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Warn_Node
);
6884 end Get_Range_Checks
;
6890 function Guard_Access
6893 Ck_Node
: Node_Id
) return Node_Id
6896 if Nkind
(Cond
) = N_Or_Else
then
6897 Set_Paren_Count
(Cond
, 1);
6900 if Nkind
(Ck_Node
) = N_Allocator
then
6908 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
6909 Right_Opnd
=> Make_Null
(Loc
)),
6910 Right_Opnd
=> Cond
);
6914 -----------------------------
6915 -- Index_Checks_Suppressed --
6916 -----------------------------
6918 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6920 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6921 return Is_Check_Suppressed
(E
, Index_Check
);
6923 return Scope_Suppress
.Suppress
(Index_Check
);
6925 end Index_Checks_Suppressed
;
6931 procedure Initialize
is
6933 for J
in Determine_Range_Cache_N
'Range loop
6934 Determine_Range_Cache_N
(J
) := Empty
;
6939 for J
in Int
range 1 .. All_Checks
loop
6940 Check_Names
.Append
(Name_Id
(Int
(First_Check_Name
) + J
- 1));
6944 -------------------------
6945 -- Insert_Range_Checks --
6946 -------------------------
6948 procedure Insert_Range_Checks
6949 (Checks
: Check_Result
;
6951 Suppress_Typ
: Entity_Id
;
6952 Static_Sloc
: Source_Ptr
:= No_Location
;
6953 Flag_Node
: Node_Id
:= Empty
;
6954 Do_Before
: Boolean := False)
6956 Internal_Flag_Node
: Node_Id
:= Flag_Node
;
6957 Internal_Static_Sloc
: Source_Ptr
:= Static_Sloc
;
6959 Check_Node
: Node_Id
;
6960 Checks_On
: constant Boolean :=
6961 (not Index_Checks_Suppressed
(Suppress_Typ
))
6962 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
6965 -- For now we just return if Checks_On is false, however this should be
6966 -- enhanced to check for an always True value in the condition and to
6967 -- generate a compilation warning???
6969 if not Expander_Active
or not Checks_On
then
6973 if Static_Sloc
= No_Location
then
6974 Internal_Static_Sloc
:= Sloc
(Node
);
6977 if No
(Flag_Node
) then
6978 Internal_Flag_Node
:= Node
;
6981 for J
in 1 .. 2 loop
6982 exit when No
(Checks
(J
));
6984 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
6985 and then Present
(Condition
(Checks
(J
)))
6987 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
6988 Check_Node
:= Checks
(J
);
6989 Mark_Rewrite_Insertion
(Check_Node
);
6992 Insert_Before_And_Analyze
(Node
, Check_Node
);
6994 Insert_After_And_Analyze
(Node
, Check_Node
);
6997 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
7002 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
7003 Reason
=> CE_Range_Check_Failed
);
7004 Mark_Rewrite_Insertion
(Check_Node
);
7007 Insert_Before_And_Analyze
(Node
, Check_Node
);
7009 Insert_After_And_Analyze
(Node
, Check_Node
);
7013 end Insert_Range_Checks
;
7015 ------------------------
7016 -- Insert_Valid_Check --
7017 ------------------------
7019 procedure Insert_Valid_Check
7021 Related_Id
: Entity_Id
:= Empty
;
7022 Is_Low_Bound
: Boolean := False;
7023 Is_High_Bound
: Boolean := False)
7025 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
7026 Typ
: constant Entity_Id
:= Etype
(Expr
);
7030 -- Do not insert if checks off, or if not checking validity or if
7031 -- expression is known to be valid.
7033 if not Validity_Checks_On
7034 or else Range_Or_Validity_Checks_Suppressed
(Expr
)
7035 or else Expr_Known_Valid
(Expr
)
7040 -- Do not insert checks within a predicate function. This will arise
7041 -- if the current unit and the predicate function are being compiled
7042 -- with validity checks enabled.
7044 if Present
(Predicate_Function
(Typ
))
7045 and then Current_Scope
= Predicate_Function
(Typ
)
7050 -- If the expression is a packed component of a modular type of the
7051 -- right size, the data is always valid.
7053 if Nkind
(Expr
) = N_Selected_Component
7054 and then Present
(Component_Clause
(Entity
(Selector_Name
(Expr
))))
7055 and then Is_Modular_Integer_Type
(Typ
)
7056 and then Modulus
(Typ
) = 2 ** Esize
(Entity
(Selector_Name
(Expr
)))
7061 -- If we have a checked conversion, then validity check applies to
7062 -- the expression inside the conversion, not the result, since if
7063 -- the expression inside is valid, then so is the conversion result.
7066 while Nkind
(Exp
) = N_Type_Conversion
loop
7067 Exp
:= Expression
(Exp
);
7070 -- We are about to insert the validity check for Exp. We save and
7071 -- reset the Do_Range_Check flag over this validity check, and then
7072 -- put it back for the final original reference (Exp may be rewritten).
7075 DRC
: constant Boolean := Do_Range_Check
(Exp
);
7080 Set_Do_Range_Check
(Exp
, False);
7082 -- Force evaluation to avoid multiple reads for atomic/volatile
7084 -- Note: we set Name_Req to False. We used to set it to True, with
7085 -- the thinking that a name is required as the prefix of the 'Valid
7086 -- call, but in fact the check that the prefix of an attribute is
7087 -- a name is in the parser, and we just don't require it here.
7088 -- Moreover, when we set Name_Req to True, that interfered with the
7089 -- checking for Volatile, since we couldn't just capture the value.
7091 if Is_Entity_Name
(Exp
)
7092 and then Is_Volatile
(Entity
(Exp
))
7094 -- Same reasoning as above for setting Name_Req to False
7096 Force_Evaluation
(Exp
, Name_Req
=> False);
7099 -- Build the prefix for the 'Valid call
7102 Duplicate_Subexpr_No_Checks
7105 Related_Id
=> Related_Id
,
7106 Is_Low_Bound
=> Is_Low_Bound
,
7107 Is_High_Bound
=> Is_High_Bound
);
7109 -- A rather specialized test. If PV is an analyzed expression which
7110 -- is an indexed component of a packed array that has not been
7111 -- properly expanded, turn off its Analyzed flag to make sure it
7112 -- gets properly reexpanded. If the prefix is an access value,
7113 -- the dereference will be added later.
7115 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
7116 -- an analyze with the old parent pointer. This may point e.g. to
7117 -- a subprogram call, which deactivates this expansion.
7120 and then Nkind
(PV
) = N_Indexed_Component
7121 and then Is_Array_Type
(Etype
(Prefix
(PV
)))
7122 and then Present
(Packed_Array_Impl_Type
(Etype
(Prefix
(PV
))))
7124 Set_Analyzed
(PV
, False);
7127 -- Build the raise CE node to check for validity. We build a type
7128 -- qualification for the prefix, since it may not be of the form of
7129 -- a name, and we don't care in this context!
7132 Make_Raise_Constraint_Error
(Loc
,
7136 Make_Attribute_Reference
(Loc
,
7138 Attribute_Name
=> Name_Valid
)),
7139 Reason
=> CE_Invalid_Data
);
7141 -- Insert the validity check. Note that we do this with validity
7142 -- checks turned off, to avoid recursion, we do not want validity
7143 -- checks on the validity checking code itself.
7145 Insert_Action
(Expr
, CE
, Suppress
=> Validity_Check
);
7147 -- If the expression is a reference to an element of a bit-packed
7148 -- array, then it is rewritten as a renaming declaration. If the
7149 -- expression is an actual in a call, it has not been expanded,
7150 -- waiting for the proper point at which to do it. The same happens
7151 -- with renamings, so that we have to force the expansion now. This
7152 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
7155 if Is_Entity_Name
(Exp
)
7156 and then Nkind
(Parent
(Entity
(Exp
))) =
7157 N_Object_Renaming_Declaration
7160 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
7162 if Nkind
(Old_Exp
) = N_Indexed_Component
7163 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
7165 Expand_Packed_Element_Reference
(Old_Exp
);
7170 -- Put back the Do_Range_Check flag on the resulting (possibly
7171 -- rewritten) expression.
7173 -- Note: it might be thought that a validity check is not required
7174 -- when a range check is present, but that's not the case, because
7175 -- the back end is allowed to assume for the range check that the
7176 -- operand is within its declared range (an assumption that validity
7177 -- checking is all about NOT assuming).
7179 -- Note: no need to worry about Possible_Local_Raise here, it will
7180 -- already have been called if original node has Do_Range_Check set.
7182 Set_Do_Range_Check
(Exp
, DRC
);
7184 end Insert_Valid_Check
;
7186 -------------------------------------
7187 -- Is_Signed_Integer_Arithmetic_Op --
7188 -------------------------------------
7190 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean is
7193 when N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
7194 N_Op_Minus | N_Op_Mod | N_Op_Multiply | N_Op_Plus |
7195 N_Op_Rem | N_Op_Subtract
=>
7196 return Is_Signed_Integer_Type
(Etype
(N
));
7198 when N_If_Expression | N_Case_Expression
=>
7199 return Is_Signed_Integer_Type
(Etype
(N
));
7204 end Is_Signed_Integer_Arithmetic_Op
;
7206 ----------------------------------
7207 -- Install_Null_Excluding_Check --
7208 ----------------------------------
7210 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
7211 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
7212 Typ
: constant Entity_Id
:= Etype
(N
);
7214 function Safe_To_Capture_In_Parameter_Value
return Boolean;
7215 -- Determines if it is safe to capture Known_Non_Null status for an
7216 -- the entity referenced by node N. The caller ensures that N is indeed
7217 -- an entity name. It is safe to capture the non-null status for an IN
7218 -- parameter when the reference occurs within a declaration that is sure
7219 -- to be executed as part of the declarative region.
7221 procedure Mark_Non_Null
;
7222 -- After installation of check, if the node in question is an entity
7223 -- name, then mark this entity as non-null if possible.
7225 function Safe_To_Capture_In_Parameter_Value
return Boolean is
7226 E
: constant Entity_Id
:= Entity
(N
);
7227 S
: constant Entity_Id
:= Current_Scope
;
7231 if Ekind
(E
) /= E_In_Parameter
then
7235 -- Two initial context checks. We must be inside a subprogram body
7236 -- with declarations and reference must not appear in nested scopes.
7238 if (Ekind
(S
) /= E_Function
and then Ekind
(S
) /= E_Procedure
)
7239 or else Scope
(E
) /= S
7244 S_Par
:= Parent
(Parent
(S
));
7246 if Nkind
(S_Par
) /= N_Subprogram_Body
7247 or else No
(Declarations
(S_Par
))
7257 -- Retrieve the declaration node of N (if any). Note that N
7258 -- may be a part of a complex initialization expression.
7262 while Present
(P
) loop
7264 -- If we have a short circuit form, and we are within the right
7265 -- hand expression, we return false, since the right hand side
7266 -- is not guaranteed to be elaborated.
7268 if Nkind
(P
) in N_Short_Circuit
7269 and then N
= Right_Opnd
(P
)
7274 -- Similarly, if we are in an if expression and not part of the
7275 -- condition, then we return False, since neither the THEN or
7276 -- ELSE dependent expressions will always be elaborated.
7278 if Nkind
(P
) = N_If_Expression
7279 and then N
/= First
(Expressions
(P
))
7284 -- If within a case expression, and not part of the expression,
7285 -- then return False, since a particular dependent expression
7286 -- may not always be elaborated
7288 if Nkind
(P
) = N_Case_Expression
7289 and then N
/= Expression
(P
)
7294 -- While traversing the parent chain, if node N belongs to a
7295 -- statement, then it may never appear in a declarative region.
7297 if Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
7298 or else Nkind
(P
) = N_Procedure_Call_Statement
7303 -- If we are at a declaration, record it and exit
7305 if Nkind
(P
) in N_Declaration
7306 and then Nkind
(P
) not in N_Subprogram_Specification
7319 return List_Containing
(N_Decl
) = Declarations
(S_Par
);
7321 end Safe_To_Capture_In_Parameter_Value
;
7327 procedure Mark_Non_Null
is
7329 -- Only case of interest is if node N is an entity name
7331 if Is_Entity_Name
(N
) then
7333 -- For sure, we want to clear an indication that this is known to
7334 -- be null, since if we get past this check, it definitely is not.
7336 Set_Is_Known_Null
(Entity
(N
), False);
7338 -- We can mark the entity as known to be non-null if either it is
7339 -- safe to capture the value, or in the case of an IN parameter,
7340 -- which is a constant, if the check we just installed is in the
7341 -- declarative region of the subprogram body. In this latter case,
7342 -- a check is decisive for the rest of the body if the expression
7343 -- is sure to be elaborated, since we know we have to elaborate
7344 -- all declarations before executing the body.
7346 -- Couldn't this always be part of Safe_To_Capture_Value ???
7348 if Safe_To_Capture_Value
(N
, Entity
(N
))
7349 or else Safe_To_Capture_In_Parameter_Value
7351 Set_Is_Known_Non_Null
(Entity
(N
));
7356 -- Start of processing for Install_Null_Excluding_Check
7359 pragma Assert
(Is_Access_Type
(Typ
));
7361 -- No check inside a generic, check will be emitted in instance
7363 if Inside_A_Generic
then
7367 -- No check needed if known to be non-null
7369 if Known_Non_Null
(N
) then
7373 -- If known to be null, here is where we generate a compile time check
7375 if Known_Null
(N
) then
7377 -- Avoid generating warning message inside init procs. In SPARK mode
7378 -- we can go ahead and call Apply_Compile_Time_Constraint_Error
7379 -- since it will be turned into an error in any case.
7381 if (not Inside_Init_Proc
or else SPARK_Mode
= On
)
7383 -- Do not emit the warning within a conditional expression,
7384 -- where the expression might not be evaluated, and the warning
7385 -- appear as extraneous noise.
7387 and then not Within_Case_Or_If_Expression
(N
)
7389 Apply_Compile_Time_Constraint_Error
7390 (N
, "null value not allowed here??", CE_Access_Check_Failed
);
7392 -- Remaining cases, where we silently insert the raise
7396 Make_Raise_Constraint_Error
(Loc
,
7397 Reason
=> CE_Access_Check_Failed
));
7404 -- If entity is never assigned, for sure a warning is appropriate
7406 if Is_Entity_Name
(N
) then
7407 Check_Unset_Reference
(N
);
7410 -- No check needed if checks are suppressed on the range. Note that we
7411 -- don't set Is_Known_Non_Null in this case (we could legitimately do
7412 -- so, since the program is erroneous, but we don't like to casually
7413 -- propagate such conclusions from erroneosity).
7415 if Access_Checks_Suppressed
(Typ
) then
7419 -- No check needed for access to concurrent record types generated by
7420 -- the expander. This is not just an optimization (though it does indeed
7421 -- remove junk checks). It also avoids generation of junk warnings.
7423 if Nkind
(N
) in N_Has_Chars
7424 and then Chars
(N
) = Name_uObject
7425 and then Is_Concurrent_Record_Type
7426 (Directly_Designated_Type
(Etype
(N
)))
7431 -- No check needed in interface thunks since the runtime check is
7432 -- already performed at the caller side.
7434 if Is_Thunk
(Current_Scope
) then
7438 -- No check needed for the Get_Current_Excep.all.all idiom generated by
7439 -- the expander within exception handlers, since we know that the value
7440 -- can never be null.
7442 -- Is this really the right way to do this? Normally we generate such
7443 -- code in the expander with checks off, and that's how we suppress this
7444 -- kind of junk check ???
7446 if Nkind
(N
) = N_Function_Call
7447 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
7448 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
7449 and then Is_RTE
(Entity
(Prefix
(Name
(N
))), RE_Get_Current_Excep
)
7454 -- Otherwise install access check
7457 Make_Raise_Constraint_Error
(Loc
,
7460 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
7461 Right_Opnd
=> Make_Null
(Loc
)),
7462 Reason
=> CE_Access_Check_Failed
));
7465 end Install_Null_Excluding_Check
;
7467 --------------------------
7468 -- Install_Static_Check --
7469 --------------------------
7471 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
7472 Stat
: constant Boolean := Is_OK_Static_Expression
(R_Cno
);
7473 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
7477 Make_Raise_Constraint_Error
(Loc
,
7478 Reason
=> CE_Range_Check_Failed
));
7479 Set_Analyzed
(R_Cno
);
7480 Set_Etype
(R_Cno
, Typ
);
7481 Set_Raises_Constraint_Error
(R_Cno
);
7482 Set_Is_Static_Expression
(R_Cno
, Stat
);
7484 -- Now deal with possible local raise handling
7486 Possible_Local_Raise
(R_Cno
, Standard_Constraint_Error
);
7487 end Install_Static_Check
;
7489 -------------------------
7490 -- Is_Check_Suppressed --
7491 -------------------------
7493 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
7494 Ptr
: Suppress_Stack_Entry_Ptr
;
7497 -- First search the local entity suppress stack. We search this from the
7498 -- top of the stack down so that we get the innermost entry that applies
7499 -- to this case if there are nested entries.
7501 Ptr
:= Local_Suppress_Stack_Top
;
7502 while Ptr
/= null loop
7503 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
7504 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
7506 return Ptr
.Suppress
;
7512 -- Now search the global entity suppress table for a matching entry.
7513 -- We also search this from the top down so that if there are multiple
7514 -- pragmas for the same entity, the last one applies (not clear what
7515 -- or whether the RM specifies this handling, but it seems reasonable).
7517 Ptr
:= Global_Suppress_Stack_Top
;
7518 while Ptr
/= null loop
7519 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
7520 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
7522 return Ptr
.Suppress
;
7528 -- If we did not find a matching entry, then use the normal scope
7529 -- suppress value after all (actually this will be the global setting
7530 -- since it clearly was not overridden at any point). For a predefined
7531 -- check, we test the specific flag. For a user defined check, we check
7532 -- the All_Checks flag. The Overflow flag requires special handling to
7533 -- deal with the General vs Assertion case
7535 if C
= Overflow_Check
then
7536 return Overflow_Checks_Suppressed
(Empty
);
7537 elsif C
in Predefined_Check_Id
then
7538 return Scope_Suppress
.Suppress
(C
);
7540 return Scope_Suppress
.Suppress
(All_Checks
);
7542 end Is_Check_Suppressed
;
7544 ---------------------
7545 -- Kill_All_Checks --
7546 ---------------------
7548 procedure Kill_All_Checks
is
7550 if Debug_Flag_CC
then
7551 w
("Kill_All_Checks");
7554 -- We reset the number of saved checks to zero, and also modify all
7555 -- stack entries for statement ranges to indicate that the number of
7556 -- checks at each level is now zero.
7558 Num_Saved_Checks
:= 0;
7560 -- Note: the Int'Min here avoids any possibility of J being out of
7561 -- range when called from e.g. Conditional_Statements_Begin.
7563 for J
in 1 .. Int
'Min (Saved_Checks_TOS
, Saved_Checks_Stack
'Last) loop
7564 Saved_Checks_Stack
(J
) := 0;
7566 end Kill_All_Checks
;
7572 procedure Kill_Checks
(V
: Entity_Id
) is
7574 if Debug_Flag_CC
then
7575 w
("Kill_Checks for entity", Int
(V
));
7578 for J
in 1 .. Num_Saved_Checks
loop
7579 if Saved_Checks
(J
).Entity
= V
then
7580 if Debug_Flag_CC
then
7581 w
(" Checks killed for saved check ", J
);
7584 Saved_Checks
(J
).Killed
:= True;
7589 ------------------------------
7590 -- Length_Checks_Suppressed --
7591 ------------------------------
7593 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7595 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7596 return Is_Check_Suppressed
(E
, Length_Check
);
7598 return Scope_Suppress
.Suppress
(Length_Check
);
7600 end Length_Checks_Suppressed
;
7602 -----------------------
7603 -- Make_Bignum_Block --
7604 -----------------------
7606 function Make_Bignum_Block
(Loc
: Source_Ptr
) return Node_Id
is
7607 M
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uM
);
7610 Make_Block_Statement
(Loc
,
7612 New_List
(Build_SS_Mark_Call
(Loc
, M
)),
7613 Handled_Statement_Sequence
=>
7614 Make_Handled_Sequence_Of_Statements
(Loc
,
7615 Statements
=> New_List
(Build_SS_Release_Call
(Loc
, M
))));
7616 end Make_Bignum_Block
;
7618 ----------------------------------
7619 -- Minimize_Eliminate_Overflows --
7620 ----------------------------------
7622 -- This is a recursive routine that is called at the top of an expression
7623 -- tree to properly process overflow checking for a whole subtree by making
7624 -- recursive calls to process operands. This processing may involve the use
7625 -- of bignum or long long integer arithmetic, which will change the types
7626 -- of operands and results. That's why we can't do this bottom up (since
7627 -- it would interfere with semantic analysis).
7629 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
7630 -- the operator expansion routines, as well as the expansion routines for
7631 -- if/case expression, do nothing (for the moment) except call the routine
7632 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
7633 -- routine does nothing for non top-level nodes, so at the point where the
7634 -- call is made for the top level node, the entire expression subtree has
7635 -- not been expanded, or processed for overflow. All that has to happen as
7636 -- a result of the top level call to this routine.
7638 -- As noted above, the overflow processing works by making recursive calls
7639 -- for the operands, and figuring out what to do, based on the processing
7640 -- of these operands (e.g. if a bignum operand appears, the parent op has
7641 -- to be done in bignum mode), and the determined ranges of the operands.
7643 -- After possible rewriting of a constituent subexpression node, a call is
7644 -- made to either reexpand the node (if nothing has changed) or reanalyze
7645 -- the node (if it has been modified by the overflow check processing). The
7646 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
7647 -- a recursive call into the whole overflow apparatus, an important rule
7648 -- for this call is that the overflow handling mode must be temporarily set
7651 procedure Minimize_Eliminate_Overflows
7655 Top_Level
: Boolean)
7657 Rtyp
: constant Entity_Id
:= Etype
(N
);
7658 pragma Assert
(Is_Signed_Integer_Type
(Rtyp
));
7659 -- Result type, must be a signed integer type
7661 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
7662 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
7664 Loc
: constant Source_Ptr
:= Sloc
(N
);
7667 -- Ranges of values for right operand (operator case)
7670 -- Ranges of values for left operand (operator case)
7672 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
7673 -- Operands and results are of this type when we convert
7675 LLLo
: constant Uint
:= Intval
(Type_Low_Bound
(LLIB
));
7676 LLHi
: constant Uint
:= Intval
(Type_High_Bound
(LLIB
));
7677 -- Bounds of Long_Long_Integer
7679 Binary
: constant Boolean := Nkind
(N
) in N_Binary_Op
;
7680 -- Indicates binary operator case
7683 -- Used in call to Determine_Range
7685 Bignum_Operands
: Boolean;
7686 -- Set True if one or more operands is already of type Bignum, meaning
7687 -- that for sure (regardless of Top_Level setting) we are committed to
7688 -- doing the operation in Bignum mode (or in the case of a case or if
7689 -- expression, converting all the dependent expressions to Bignum).
7691 Long_Long_Integer_Operands
: Boolean;
7692 -- Set True if one or more operands is already of type Long_Long_Integer
7693 -- which means that if the result is known to be in the result type
7694 -- range, then we must convert such operands back to the result type.
7696 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False);
7697 -- This is called when we have modified the node and we therefore need
7698 -- to reanalyze it. It is important that we reset the mode to STRICT for
7699 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
7700 -- we would reenter this routine recursively which would not be good.
7701 -- The argument Suppress is set True if we also want to suppress
7702 -- overflow checking for the reexpansion (this is set when we know
7703 -- overflow is not possible). Typ is the type for the reanalysis.
7705 procedure Reexpand
(Suppress
: Boolean := False);
7706 -- This is like Reanalyze, but does not do the Analyze step, it only
7707 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
7708 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
7709 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
7710 -- Note that skipping reanalysis is not just an optimization, testing
7711 -- has showed up several complex cases in which reanalyzing an already
7712 -- analyzed node causes incorrect behavior.
7714 function In_Result_Range
return Boolean;
7715 -- Returns True iff Lo .. Hi are within range of the result type
7717 procedure Max
(A
: in out Uint
; B
: Uint
);
7718 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
7720 procedure Min
(A
: in out Uint
; B
: Uint
);
7721 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
7723 ---------------------
7724 -- In_Result_Range --
7725 ---------------------
7727 function In_Result_Range
return Boolean is
7729 if Lo
= No_Uint
or else Hi
= No_Uint
then
7732 elsif Is_OK_Static_Subtype
(Etype
(N
)) then
7733 return Lo
>= Expr_Value
(Type_Low_Bound
(Rtyp
))
7735 Hi
<= Expr_Value
(Type_High_Bound
(Rtyp
));
7738 return Lo
>= Expr_Value
(Type_Low_Bound
(Base_Type
(Rtyp
)))
7740 Hi
<= Expr_Value
(Type_High_Bound
(Base_Type
(Rtyp
)));
7742 end In_Result_Range
;
7748 procedure Max
(A
: in out Uint
; B
: Uint
) is
7750 if A
= No_Uint
or else B
> A
then
7759 procedure Min
(A
: in out Uint
; B
: Uint
) is
7761 if A
= No_Uint
or else B
< A
then
7770 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False) is
7771 Svg
: constant Overflow_Mode_Type
:=
7772 Scope_Suppress
.Overflow_Mode_General
;
7773 Sva
: constant Overflow_Mode_Type
:=
7774 Scope_Suppress
.Overflow_Mode_Assertions
;
7775 Svo
: constant Boolean :=
7776 Scope_Suppress
.Suppress
(Overflow_Check
);
7779 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7780 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7783 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
7786 Analyze_And_Resolve
(N
, Typ
);
7788 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
7789 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
7790 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
7797 procedure Reexpand
(Suppress
: Boolean := False) is
7798 Svg
: constant Overflow_Mode_Type
:=
7799 Scope_Suppress
.Overflow_Mode_General
;
7800 Sva
: constant Overflow_Mode_Type
:=
7801 Scope_Suppress
.Overflow_Mode_Assertions
;
7802 Svo
: constant Boolean :=
7803 Scope_Suppress
.Suppress
(Overflow_Check
);
7806 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7807 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7808 Set_Analyzed
(N
, False);
7811 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
7816 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
7817 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
7818 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
7821 -- Start of processing for Minimize_Eliminate_Overflows
7824 -- Case where we do not have a signed integer arithmetic operation
7826 if not Is_Signed_Integer_Arithmetic_Op
(N
) then
7828 -- Use the normal Determine_Range routine to get the range. We
7829 -- don't require operands to be valid, invalid values may result in
7830 -- rubbish results where the result has not been properly checked for
7831 -- overflow, that's fine.
7833 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> False);
7835 -- If Determine_Range did not work (can this in fact happen? Not
7836 -- clear but might as well protect), use type bounds.
7839 Lo
:= Intval
(Type_Low_Bound
(Base_Type
(Etype
(N
))));
7840 Hi
:= Intval
(Type_High_Bound
(Base_Type
(Etype
(N
))));
7843 -- If we don't have a binary operator, all we have to do is to set
7844 -- the Hi/Lo range, so we are done.
7848 -- Processing for if expression
7850 elsif Nkind
(N
) = N_If_Expression
then
7852 Then_DE
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
7853 Else_DE
: constant Node_Id
:= Next
(Then_DE
);
7856 Bignum_Operands
:= False;
7858 Minimize_Eliminate_Overflows
7859 (Then_DE
, Lo
, Hi
, Top_Level
=> False);
7861 if Lo
= No_Uint
then
7862 Bignum_Operands
:= True;
7865 Minimize_Eliminate_Overflows
7866 (Else_DE
, Rlo
, Rhi
, Top_Level
=> False);
7868 if Rlo
= No_Uint
then
7869 Bignum_Operands
:= True;
7871 Long_Long_Integer_Operands
:=
7872 Etype
(Then_DE
) = LLIB
or else Etype
(Else_DE
) = LLIB
;
7878 -- If at least one of our operands is now Bignum, we must rebuild
7879 -- the if expression to use Bignum operands. We will analyze the
7880 -- rebuilt if expression with overflow checks off, since once we
7881 -- are in bignum mode, we are all done with overflow checks.
7883 if Bignum_Operands
then
7885 Make_If_Expression
(Loc
,
7886 Expressions
=> New_List
(
7887 Remove_Head
(Expressions
(N
)),
7888 Convert_To_Bignum
(Then_DE
),
7889 Convert_To_Bignum
(Else_DE
)),
7890 Is_Elsif
=> Is_Elsif
(N
)));
7892 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
7894 -- If we have no Long_Long_Integer operands, then we are in result
7895 -- range, since it means that none of our operands felt the need
7896 -- to worry about overflow (otherwise it would have already been
7897 -- converted to long long integer or bignum). We reexpand to
7898 -- complete the expansion of the if expression (but we do not
7899 -- need to reanalyze).
7901 elsif not Long_Long_Integer_Operands
then
7902 Set_Do_Overflow_Check
(N
, False);
7905 -- Otherwise convert us to long long integer mode. Note that we
7906 -- don't need any further overflow checking at this level.
7909 Convert_To_And_Rewrite
(LLIB
, Then_DE
);
7910 Convert_To_And_Rewrite
(LLIB
, Else_DE
);
7911 Set_Etype
(N
, LLIB
);
7913 -- Now reanalyze with overflow checks off
7915 Set_Do_Overflow_Check
(N
, False);
7916 Reanalyze
(LLIB
, Suppress
=> True);
7922 -- Here for case expression
7924 elsif Nkind
(N
) = N_Case_Expression
then
7925 Bignum_Operands
:= False;
7926 Long_Long_Integer_Operands
:= False;
7932 -- Loop through expressions applying recursive call
7934 Alt
:= First
(Alternatives
(N
));
7935 while Present
(Alt
) loop
7937 Aexp
: constant Node_Id
:= Expression
(Alt
);
7940 Minimize_Eliminate_Overflows
7941 (Aexp
, Lo
, Hi
, Top_Level
=> False);
7943 if Lo
= No_Uint
then
7944 Bignum_Operands
:= True;
7945 elsif Etype
(Aexp
) = LLIB
then
7946 Long_Long_Integer_Operands
:= True;
7953 -- If we have no bignum or long long integer operands, it means
7954 -- that none of our dependent expressions could raise overflow.
7955 -- In this case, we simply return with no changes except for
7956 -- resetting the overflow flag, since we are done with overflow
7957 -- checks for this node. We will reexpand to get the needed
7958 -- expansion for the case expression, but we do not need to
7959 -- reanalyze, since nothing has changed.
7961 if not (Bignum_Operands
or Long_Long_Integer_Operands
) then
7962 Set_Do_Overflow_Check
(N
, False);
7963 Reexpand
(Suppress
=> True);
7965 -- Otherwise we are going to rebuild the case expression using
7966 -- either bignum or long long integer operands throughout.
7975 New_Alts
:= New_List
;
7976 Alt
:= First
(Alternatives
(N
));
7977 while Present
(Alt
) loop
7978 if Bignum_Operands
then
7979 New_Exp
:= Convert_To_Bignum
(Expression
(Alt
));
7980 Rtype
:= RTE
(RE_Bignum
);
7982 New_Exp
:= Convert_To
(LLIB
, Expression
(Alt
));
7986 Append_To
(New_Alts
,
7987 Make_Case_Expression_Alternative
(Sloc
(Alt
),
7989 Discrete_Choices
=> Discrete_Choices
(Alt
),
7990 Expression
=> New_Exp
));
7996 Make_Case_Expression
(Loc
,
7997 Expression
=> Expression
(N
),
7998 Alternatives
=> New_Alts
));
8000 Reanalyze
(Rtype
, Suppress
=> True);
8008 -- If we have an arithmetic operator we make recursive calls on the
8009 -- operands to get the ranges (and to properly process the subtree
8010 -- that lies below us).
8012 Minimize_Eliminate_Overflows
8013 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
8016 Minimize_Eliminate_Overflows
8017 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
8020 -- Record if we have Long_Long_Integer operands
8022 Long_Long_Integer_Operands
:=
8023 Etype
(Right_Opnd
(N
)) = LLIB
8024 or else (Binary
and then Etype
(Left_Opnd
(N
)) = LLIB
);
8026 -- If either operand is a bignum, then result will be a bignum and we
8027 -- don't need to do any range analysis. As previously discussed we could
8028 -- do range analysis in such cases, but it could mean working with giant
8029 -- numbers at compile time for very little gain (the number of cases
8030 -- in which we could slip back from bignum mode is small).
8032 if Rlo
= No_Uint
or else (Binary
and then Llo
= No_Uint
) then
8035 Bignum_Operands
:= True;
8037 -- Otherwise compute result range
8040 Bignum_Operands
:= False;
8048 Hi
:= UI_Max
(abs Rlo
, abs Rhi
);
8060 -- If the right operand can only be zero, set 0..0
8062 if Rlo
= 0 and then Rhi
= 0 then
8066 -- Possible bounds of division must come from dividing end
8067 -- values of the input ranges (four possibilities), provided
8068 -- zero is not included in the possible values of the right
8071 -- Otherwise, we just consider two intervals of values for
8072 -- the right operand: the interval of negative values (up to
8073 -- -1) and the interval of positive values (starting at 1).
8074 -- Since division by 1 is the identity, and division by -1
8075 -- is negation, we get all possible bounds of division in that
8076 -- case by considering:
8077 -- - all values from the division of end values of input
8079 -- - the end values of the left operand;
8080 -- - the negation of the end values of the left operand.
8084 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
8085 -- Mark so we can release the RR and Ev values
8093 -- Discard extreme values of zero for the divisor, since
8094 -- they will simply result in an exception in any case.
8102 -- Compute possible bounds coming from dividing end
8103 -- values of the input ranges.
8110 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
8111 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
8113 -- If the right operand can be both negative or positive,
8114 -- include the end values of the left operand in the
8115 -- extreme values, as well as their negation.
8117 if Rlo
< 0 and then Rhi
> 0 then
8124 UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
)));
8126 UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
)));
8129 -- Release the RR and Ev values
8131 Release_And_Save
(Mrk
, Lo
, Hi
);
8139 -- Discard negative values for the exponent, since they will
8140 -- simply result in an exception in any case.
8148 -- Estimate number of bits in result before we go computing
8149 -- giant useless bounds. Basically the number of bits in the
8150 -- result is the number of bits in the base multiplied by the
8151 -- value of the exponent. If this is big enough that the result
8152 -- definitely won't fit in Long_Long_Integer, switch to bignum
8153 -- mode immediately, and avoid computing giant bounds.
8155 -- The comparison here is approximate, but conservative, it
8156 -- only clicks on cases that are sure to exceed the bounds.
8158 if Num_Bits
(UI_Max
(abs Llo
, abs Lhi
)) * Rhi
+ 1 > 100 then
8162 -- If right operand is zero then result is 1
8169 -- High bound comes either from exponentiation of largest
8170 -- positive value to largest exponent value, or from
8171 -- the exponentiation of most negative value to an
8185 if Rhi
mod 2 = 0 then
8188 Hi2
:= Llo
** (Rhi
- 1);
8194 Hi
:= UI_Max
(Hi1
, Hi2
);
8197 -- Result can only be negative if base can be negative
8200 if Rhi
mod 2 = 0 then
8201 Lo
:= Llo
** (Rhi
- 1);
8206 -- Otherwise low bound is minimum ** minimum
8223 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
8224 -- This is the maximum absolute value of the result
8230 -- The result depends only on the sign and magnitude of
8231 -- the right operand, it does not depend on the sign or
8232 -- magnitude of the left operand.
8245 when N_Op_Multiply
=>
8247 -- Possible bounds of multiplication must come from multiplying
8248 -- end values of the input ranges (four possibilities).
8251 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
8252 -- Mark so we can release the Ev values
8254 Ev1
: constant Uint
:= Llo
* Rlo
;
8255 Ev2
: constant Uint
:= Llo
* Rhi
;
8256 Ev3
: constant Uint
:= Lhi
* Rlo
;
8257 Ev4
: constant Uint
:= Lhi
* Rhi
;
8260 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
8261 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
8263 -- Release the Ev values
8265 Release_And_Save
(Mrk
, Lo
, Hi
);
8268 -- Plus operator (affirmation)
8278 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
8279 -- This is the maximum absolute value of the result. Note
8280 -- that the result range does not depend on the sign of the
8287 -- Case of left operand negative, which results in a range
8288 -- of -Maxabs .. 0 for those negative values. If there are
8289 -- no negative values then Lo value of result is always 0.
8295 -- Case of left operand positive
8304 when N_Op_Subtract
=>
8308 -- Nothing else should be possible
8311 raise Program_Error
;
8315 -- Here for the case where we have not rewritten anything (no bignum
8316 -- operands or long long integer operands), and we know the result.
8317 -- If we know we are in the result range, and we do not have Bignum
8318 -- operands or Long_Long_Integer operands, we can just reexpand with
8319 -- overflow checks turned off (since we know we cannot have overflow).
8320 -- As always the reexpansion is required to complete expansion of the
8321 -- operator, but we do not need to reanalyze, and we prevent recursion
8322 -- by suppressing the check.
8324 if not (Bignum_Operands
or Long_Long_Integer_Operands
)
8325 and then In_Result_Range
8327 Set_Do_Overflow_Check
(N
, False);
8328 Reexpand
(Suppress
=> True);
8331 -- Here we know that we are not in the result range, and in the general
8332 -- case we will move into either the Bignum or Long_Long_Integer domain
8333 -- to compute the result. However, there is one exception. If we are
8334 -- at the top level, and we do not have Bignum or Long_Long_Integer
8335 -- operands, we will have to immediately convert the result back to
8336 -- the result type, so there is no point in Bignum/Long_Long_Integer
8340 and then not (Bignum_Operands
or Long_Long_Integer_Operands
)
8342 -- One further refinement. If we are at the top level, but our parent
8343 -- is a type conversion, then go into bignum or long long integer node
8344 -- since the result will be converted to that type directly without
8345 -- going through the result type, and we may avoid an overflow. This
8346 -- is the case for example of Long_Long_Integer (A ** 4), where A is
8347 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
8348 -- but does not fit in Integer.
8350 and then Nkind
(Parent
(N
)) /= N_Type_Conversion
8352 -- Here keep original types, but we need to complete analysis
8354 -- One subtlety. We can't just go ahead and do an analyze operation
8355 -- here because it will cause recursion into the whole MINIMIZED/
8356 -- ELIMINATED overflow processing which is not what we want. Here
8357 -- we are at the top level, and we need a check against the result
8358 -- mode (i.e. we want to use STRICT mode). So do exactly that.
8359 -- Also, we have not modified the node, so this is a case where
8360 -- we need to reexpand, but not reanalyze.
8365 -- Cases where we do the operation in Bignum mode. This happens either
8366 -- because one of our operands is in Bignum mode already, or because
8367 -- the computed bounds are outside the bounds of Long_Long_Integer,
8368 -- which in some cases can be indicated by Hi and Lo being No_Uint.
8370 -- Note: we could do better here and in some cases switch back from
8371 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
8372 -- 0 .. 1, but the cases are rare and it is not worth the effort.
8373 -- Failing to do this switching back is only an efficiency issue.
8375 elsif Lo
= No_Uint
or else Lo
< LLLo
or else Hi
> LLHi
then
8377 -- OK, we are definitely outside the range of Long_Long_Integer. The
8378 -- question is whether to move to Bignum mode, or stay in the domain
8379 -- of Long_Long_Integer, signalling that an overflow check is needed.
8381 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
8382 -- the Bignum business. In ELIMINATED mode, we will normally move
8383 -- into Bignum mode, but there is an exception if neither of our
8384 -- operands is Bignum now, and we are at the top level (Top_Level
8385 -- set True). In this case, there is no point in moving into Bignum
8386 -- mode to prevent overflow if the caller will immediately convert
8387 -- the Bignum value back to LLI with an overflow check. It's more
8388 -- efficient to stay in LLI mode with an overflow check (if needed)
8390 if Check_Mode
= Minimized
8391 or else (Top_Level
and not Bignum_Operands
)
8393 if Do_Overflow_Check
(N
) then
8394 Enable_Overflow_Check
(N
);
8397 -- The result now has to be in Long_Long_Integer mode, so adjust
8398 -- the possible range to reflect this. Note these calls also
8399 -- change No_Uint values from the top level case to LLI bounds.
8404 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
8407 pragma Assert
(Check_Mode
= Eliminated
);
8416 Fent
:= RTE
(RE_Big_Abs
);
8419 Fent
:= RTE
(RE_Big_Add
);
8422 Fent
:= RTE
(RE_Big_Div
);
8425 Fent
:= RTE
(RE_Big_Exp
);
8428 Fent
:= RTE
(RE_Big_Neg
);
8431 Fent
:= RTE
(RE_Big_Mod
);
8433 when N_Op_Multiply
=>
8434 Fent
:= RTE
(RE_Big_Mul
);
8437 Fent
:= RTE
(RE_Big_Rem
);
8439 when N_Op_Subtract
=>
8440 Fent
:= RTE
(RE_Big_Sub
);
8442 -- Anything else is an internal error, this includes the
8443 -- N_Op_Plus case, since how can plus cause the result
8444 -- to be out of range if the operand is in range?
8447 raise Program_Error
;
8450 -- Construct argument list for Bignum call, converting our
8451 -- operands to Bignum form if they are not already there.
8456 Append_To
(Args
, Convert_To_Bignum
(Left_Opnd
(N
)));
8459 Append_To
(Args
, Convert_To_Bignum
(Right_Opnd
(N
)));
8461 -- Now rewrite the arithmetic operator with a call to the
8462 -- corresponding bignum function.
8465 Make_Function_Call
(Loc
,
8466 Name
=> New_Occurrence_Of
(Fent
, Loc
),
8467 Parameter_Associations
=> Args
));
8468 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
8470 -- Indicate result is Bignum mode
8478 -- Otherwise we are in range of Long_Long_Integer, so no overflow
8479 -- check is required, at least not yet.
8482 Set_Do_Overflow_Check
(N
, False);
8485 -- Here we are not in Bignum territory, but we may have long long
8486 -- integer operands that need special handling. First a special check:
8487 -- If an exponentiation operator exponent is of type Long_Long_Integer,
8488 -- it means we converted it to prevent overflow, but exponentiation
8489 -- requires a Natural right operand, so convert it back to Natural.
8490 -- This conversion may raise an exception which is fine.
8492 if Nkind
(N
) = N_Op_Expon
and then Etype
(Right_Opnd
(N
)) = LLIB
then
8493 Convert_To_And_Rewrite
(Standard_Natural
, Right_Opnd
(N
));
8496 -- Here we will do the operation in Long_Long_Integer. We do this even
8497 -- if we know an overflow check is required, better to do this in long
8498 -- long integer mode, since we are less likely to overflow.
8500 -- Convert right or only operand to Long_Long_Integer, except that
8501 -- we do not touch the exponentiation right operand.
8503 if Nkind
(N
) /= N_Op_Expon
then
8504 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
8507 -- Convert left operand to Long_Long_Integer for binary case
8510 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
8513 -- Reset node to unanalyzed
8515 Set_Analyzed
(N
, False);
8516 Set_Etype
(N
, Empty
);
8517 Set_Entity
(N
, Empty
);
8519 -- Now analyze this new node. This reanalysis will complete processing
8520 -- for the node. In particular we will complete the expansion of an
8521 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
8522 -- we will complete any division checks (since we have not changed the
8523 -- setting of the Do_Division_Check flag).
8525 -- We do this reanalysis in STRICT mode to avoid recursion into the
8526 -- MINIMIZED/ELIMINATED handling, since we are now done with that.
8529 SG
: constant Overflow_Mode_Type
:=
8530 Scope_Suppress
.Overflow_Mode_General
;
8531 SA
: constant Overflow_Mode_Type
:=
8532 Scope_Suppress
.Overflow_Mode_Assertions
;
8535 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
8536 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
8538 if not Do_Overflow_Check
(N
) then
8539 Reanalyze
(LLIB
, Suppress
=> True);
8544 Scope_Suppress
.Overflow_Mode_General
:= SG
;
8545 Scope_Suppress
.Overflow_Mode_Assertions
:= SA
;
8547 end Minimize_Eliminate_Overflows
;
8549 -------------------------
8550 -- Overflow_Check_Mode --
8551 -------------------------
8553 function Overflow_Check_Mode
return Overflow_Mode_Type
is
8555 if In_Assertion_Expr
= 0 then
8556 return Scope_Suppress
.Overflow_Mode_General
;
8558 return Scope_Suppress
.Overflow_Mode_Assertions
;
8560 end Overflow_Check_Mode
;
8562 --------------------------------
8563 -- Overflow_Checks_Suppressed --
8564 --------------------------------
8566 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
8568 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
8569 return Is_Check_Suppressed
(E
, Overflow_Check
);
8571 return Scope_Suppress
.Suppress
(Overflow_Check
);
8573 end Overflow_Checks_Suppressed
;
8575 ---------------------------------
8576 -- Predicate_Checks_Suppressed --
8577 ---------------------------------
8579 function Predicate_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
8581 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
8582 return Is_Check_Suppressed
(E
, Predicate_Check
);
8584 return Scope_Suppress
.Suppress
(Predicate_Check
);
8586 end Predicate_Checks_Suppressed
;
8588 -----------------------------
8589 -- Range_Checks_Suppressed --
8590 -----------------------------
8592 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
8595 if Kill_Range_Checks
(E
) then
8598 elsif Checks_May_Be_Suppressed
(E
) then
8599 return Is_Check_Suppressed
(E
, Range_Check
);
8603 return Scope_Suppress
.Suppress
(Range_Check
);
8604 end Range_Checks_Suppressed
;
8606 -----------------------------------------
8607 -- Range_Or_Validity_Checks_Suppressed --
8608 -----------------------------------------
8610 -- Note: the coding would be simpler here if we simply made appropriate
8611 -- calls to Range/Validity_Checks_Suppressed, but that would result in
8612 -- duplicated checks which we prefer to avoid.
8614 function Range_Or_Validity_Checks_Suppressed
8615 (Expr
: Node_Id
) return Boolean
8618 -- Immediate return if scope checks suppressed for either check
8620 if Scope_Suppress
.Suppress
(Range_Check
)
8622 Scope_Suppress
.Suppress
(Validity_Check
)
8627 -- If no expression, that's odd, decide that checks are suppressed,
8628 -- since we don't want anyone trying to do checks in this case, which
8629 -- is most likely the result of some other error.
8635 -- Expression is present, so perform suppress checks on type
8638 Typ
: constant Entity_Id
:= Etype
(Expr
);
8640 if Checks_May_Be_Suppressed
(Typ
)
8641 and then (Is_Check_Suppressed
(Typ
, Range_Check
)
8643 Is_Check_Suppressed
(Typ
, Validity_Check
))
8649 -- If expression is an entity name, perform checks on this entity
8651 if Is_Entity_Name
(Expr
) then
8653 Ent
: constant Entity_Id
:= Entity
(Expr
);
8655 if Checks_May_Be_Suppressed
(Ent
) then
8656 return Is_Check_Suppressed
(Ent
, Range_Check
)
8657 or else Is_Check_Suppressed
(Ent
, Validity_Check
);
8662 -- If we fall through, no checks suppressed
8665 end Range_Or_Validity_Checks_Suppressed
;
8671 procedure Remove_Checks
(Expr
: Node_Id
) is
8672 function Process
(N
: Node_Id
) return Traverse_Result
;
8673 -- Process a single node during the traversal
8675 procedure Traverse
is new Traverse_Proc
(Process
);
8676 -- The traversal procedure itself
8682 function Process
(N
: Node_Id
) return Traverse_Result
is
8684 if Nkind
(N
) not in N_Subexpr
then
8688 Set_Do_Range_Check
(N
, False);
8692 Traverse
(Left_Opnd
(N
));
8695 when N_Attribute_Reference
=>
8696 Set_Do_Overflow_Check
(N
, False);
8698 when N_Function_Call
=>
8699 Set_Do_Tag_Check
(N
, False);
8702 Set_Do_Overflow_Check
(N
, False);
8706 Set_Do_Division_Check
(N
, False);
8709 Set_Do_Length_Check
(N
, False);
8712 Set_Do_Division_Check
(N
, False);
8715 Set_Do_Length_Check
(N
, False);
8718 Set_Do_Division_Check
(N
, False);
8721 Set_Do_Length_Check
(N
, False);
8728 Traverse
(Left_Opnd
(N
));
8731 when N_Selected_Component
=>
8732 Set_Do_Discriminant_Check
(N
, False);
8734 when N_Type_Conversion
=>
8735 Set_Do_Length_Check
(N
, False);
8736 Set_Do_Tag_Check
(N
, False);
8737 Set_Do_Overflow_Check
(N
, False);
8746 -- Start of processing for Remove_Checks
8752 ----------------------------
8753 -- Selected_Length_Checks --
8754 ----------------------------
8756 function Selected_Length_Checks
8758 Target_Typ
: Entity_Id
;
8759 Source_Typ
: Entity_Id
;
8760 Warn_Node
: Node_Id
) return Check_Result
8762 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
8765 Expr_Actual
: Node_Id
;
8767 Cond
: Node_Id
:= Empty
;
8768 Do_Access
: Boolean := False;
8769 Wnode
: Node_Id
:= Warn_Node
;
8770 Ret_Result
: Check_Result
:= (Empty
, Empty
);
8771 Num_Checks
: Natural := 0;
8773 procedure Add_Check
(N
: Node_Id
);
8774 -- Adds the action given to Ret_Result if N is non-Empty
8776 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
8777 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8778 -- Comments required ???
8780 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
8781 -- True for equal literals and for nodes that denote the same constant
8782 -- entity, even if its value is not a static constant. This includes the
8783 -- case of a discriminal reference within an init proc. Removes some
8784 -- obviously superfluous checks.
8786 function Length_E_Cond
8787 (Exptyp
: Entity_Id
;
8789 Indx
: Nat
) return Node_Id
;
8790 -- Returns expression to compute:
8791 -- Typ'Length /= Exptyp'Length
8793 function Length_N_Cond
8796 Indx
: Nat
) return Node_Id
;
8797 -- Returns expression to compute:
8798 -- Typ'Length /= Expr'Length
8804 procedure Add_Check
(N
: Node_Id
) is
8808 -- For now, ignore attempt to place more than two checks ???
8809 -- This is really worrisome, are we really discarding checks ???
8811 if Num_Checks
= 2 then
8815 pragma Assert
(Num_Checks
<= 1);
8816 Num_Checks
:= Num_Checks
+ 1;
8817 Ret_Result
(Num_Checks
) := N
;
8825 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
8826 SE
: constant Entity_Id
:= Scope
(E
);
8828 E1
: Entity_Id
:= E
;
8831 if Ekind
(Scope
(E
)) = E_Record_Type
8832 and then Has_Discriminants
(Scope
(E
))
8834 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
8837 Insert_Action
(Ck_Node
, N
);
8838 E1
:= Defining_Identifier
(N
);
8842 if Ekind
(E1
) = E_String_Literal_Subtype
then
8844 Make_Integer_Literal
(Loc
,
8845 Intval
=> String_Literal_Length
(E1
));
8847 elsif SE
/= Standard_Standard
8848 and then Ekind
(Scope
(SE
)) = E_Protected_Type
8849 and then Has_Discriminants
(Scope
(SE
))
8850 and then Has_Completion
(Scope
(SE
))
8851 and then not Inside_Init_Proc
8853 -- If the type whose length is needed is a private component
8854 -- constrained by a discriminant, we must expand the 'Length
8855 -- attribute into an explicit computation, using the discriminal
8856 -- of the current protected operation. This is because the actual
8857 -- type of the prival is constructed after the protected opera-
8858 -- tion has been fully expanded.
8861 Indx_Type
: Node_Id
;
8864 Do_Expand
: Boolean := False;
8867 Indx_Type
:= First_Index
(E
);
8869 for J
in 1 .. Indx
- 1 loop
8870 Next_Index
(Indx_Type
);
8873 Get_Index_Bounds
(Indx_Type
, Lo
, Hi
);
8875 if Nkind
(Lo
) = N_Identifier
8876 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
8878 Lo
:= Get_Discriminal
(E
, Lo
);
8882 if Nkind
(Hi
) = N_Identifier
8883 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
8885 Hi
:= Get_Discriminal
(E
, Hi
);
8890 if not Is_Entity_Name
(Lo
) then
8891 Lo
:= Duplicate_Subexpr_No_Checks
(Lo
);
8894 if not Is_Entity_Name
(Hi
) then
8895 Lo
:= Duplicate_Subexpr_No_Checks
(Hi
);
8901 Make_Op_Subtract
(Loc
,
8905 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
8910 Make_Attribute_Reference
(Loc
,
8911 Attribute_Name
=> Name_Length
,
8913 New_Occurrence_Of
(E1
, Loc
));
8916 Set_Expressions
(N
, New_List
(
8917 Make_Integer_Literal
(Loc
, Indx
)));
8926 Make_Attribute_Reference
(Loc
,
8927 Attribute_Name
=> Name_Length
,
8929 New_Occurrence_Of
(E1
, Loc
));
8932 Set_Expressions
(N
, New_List
(
8933 Make_Integer_Literal
(Loc
, Indx
)));
8944 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8947 Make_Attribute_Reference
(Loc
,
8948 Attribute_Name
=> Name_Length
,
8950 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8951 Expressions
=> New_List
(
8952 Make_Integer_Literal
(Loc
, Indx
)));
8959 function Length_E_Cond
8960 (Exptyp
: Entity_Id
;
8962 Indx
: Nat
) return Node_Id
8967 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8968 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
8975 function Length_N_Cond
8978 Indx
: Nat
) return Node_Id
8983 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8984 Right_Opnd
=> Get_N_Length
(Expr
, Indx
));
8991 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
8994 (Nkind
(L
) = N_Integer_Literal
8995 and then Nkind
(R
) = N_Integer_Literal
8996 and then Intval
(L
) = Intval
(R
))
9000 and then Ekind
(Entity
(L
)) = E_Constant
9001 and then ((Is_Entity_Name
(R
)
9002 and then Entity
(L
) = Entity
(R
))
9004 (Nkind
(R
) = N_Type_Conversion
9005 and then Is_Entity_Name
(Expression
(R
))
9006 and then Entity
(L
) = Entity
(Expression
(R
)))))
9010 and then Ekind
(Entity
(R
)) = E_Constant
9011 and then Nkind
(L
) = N_Type_Conversion
9012 and then Is_Entity_Name
(Expression
(L
))
9013 and then Entity
(R
) = Entity
(Expression
(L
)))
9017 and then Is_Entity_Name
(R
)
9018 and then Entity
(L
) = Entity
(R
)
9019 and then Ekind
(Entity
(L
)) = E_In_Parameter
9020 and then Inside_Init_Proc
);
9023 -- Start of processing for Selected_Length_Checks
9026 if not Expander_Active
then
9030 if Target_Typ
= Any_Type
9031 or else Target_Typ
= Any_Composite
9032 or else Raises_Constraint_Error
(Ck_Node
)
9041 T_Typ
:= Target_Typ
;
9043 if No
(Source_Typ
) then
9044 S_Typ
:= Etype
(Ck_Node
);
9046 S_Typ
:= Source_Typ
;
9049 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
9053 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
9054 S_Typ
:= Designated_Type
(S_Typ
);
9055 T_Typ
:= Designated_Type
(T_Typ
);
9058 -- A simple optimization for the null case
9060 if Known_Null
(Ck_Node
) then
9065 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
9066 if Is_Constrained
(T_Typ
) then
9068 -- The checking code to be generated will freeze the corresponding
9069 -- array type. However, we must freeze the type now, so that the
9070 -- freeze node does not appear within the generated if expression,
9073 Freeze_Before
(Ck_Node
, T_Typ
);
9075 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
9076 Exptyp
:= Get_Actual_Subtype
(Ck_Node
);
9078 if Is_Access_Type
(Exptyp
) then
9079 Exptyp
:= Designated_Type
(Exptyp
);
9082 -- String_Literal case. This needs to be handled specially be-
9083 -- cause no index types are available for string literals. The
9084 -- condition is simply:
9086 -- T_Typ'Length = string-literal-length
9088 if Nkind
(Expr_Actual
) = N_String_Literal
9089 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
9093 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
9095 Make_Integer_Literal
(Loc
,
9097 String_Literal_Length
(Etype
(Expr_Actual
))));
9099 -- General array case. Here we have a usable actual subtype for
9100 -- the expression, and the condition is built from the two types
9103 -- T_Typ'Length /= Exptyp'Length or else
9104 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
9105 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
9108 elsif Is_Constrained
(Exptyp
) then
9110 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9123 -- At the library level, we need to ensure that the type of
9124 -- the object is elaborated before the check itself is
9125 -- emitted. This is only done if the object is in the
9126 -- current compilation unit, otherwise the type is frozen
9127 -- and elaborated in its unit.
9129 if Is_Itype
(Exptyp
)
9131 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
9133 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
9134 and then In_Open_Scopes
(Scope
(Exptyp
))
9136 Ref_Node
:= Make_Itype_Reference
(Sloc
(Ck_Node
));
9137 Set_Itype
(Ref_Node
, Exptyp
);
9138 Insert_Action
(Ck_Node
, Ref_Node
);
9141 L_Index
:= First_Index
(T_Typ
);
9142 R_Index
:= First_Index
(Exptyp
);
9144 for Indx
in 1 .. Ndims
loop
9145 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
9147 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
9149 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
9150 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
9152 -- Deal with compile time length check. Note that we
9153 -- skip this in the access case, because the access
9154 -- value may be null, so we cannot know statically.
9157 and then Compile_Time_Known_Value
(L_Low
)
9158 and then Compile_Time_Known_Value
(L_High
)
9159 and then Compile_Time_Known_Value
(R_Low
)
9160 and then Compile_Time_Known_Value
(R_High
)
9162 if Expr_Value
(L_High
) >= Expr_Value
(L_Low
) then
9163 L_Length
:= Expr_Value
(L_High
) -
9164 Expr_Value
(L_Low
) + 1;
9166 L_Length
:= UI_From_Int
(0);
9169 if Expr_Value
(R_High
) >= Expr_Value
(R_Low
) then
9170 R_Length
:= Expr_Value
(R_High
) -
9171 Expr_Value
(R_Low
) + 1;
9173 R_Length
:= UI_From_Int
(0);
9176 if L_Length
> R_Length
then
9178 (Compile_Time_Constraint_Error
9179 (Wnode
, "too few elements for}??", T_Typ
));
9181 elsif L_Length
< R_Length
then
9183 (Compile_Time_Constraint_Error
9184 (Wnode
, "too many elements for}??", T_Typ
));
9187 -- The comparison for an individual index subtype
9188 -- is omitted if the corresponding index subtypes
9189 -- statically match, since the result is known to
9190 -- be true. Note that this test is worth while even
9191 -- though we do static evaluation, because non-static
9192 -- subtypes can statically match.
9195 Subtypes_Statically_Match
9196 (Etype
(L_Index
), Etype
(R_Index
))
9199 (Same_Bounds
(L_Low
, R_Low
)
9200 and then Same_Bounds
(L_High
, R_High
))
9203 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
9212 -- Handle cases where we do not get a usable actual subtype that
9213 -- is constrained. This happens for example in the function call
9214 -- and explicit dereference cases. In these cases, we have to get
9215 -- the length or range from the expression itself, making sure we
9216 -- do not evaluate it more than once.
9218 -- Here Ck_Node is the original expression, or more properly the
9219 -- result of applying Duplicate_Expr to the original tree, forcing
9220 -- the result to be a name.
9224 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9227 -- Build the condition for the explicit dereference case
9229 for Indx
in 1 .. Ndims
loop
9231 (Cond
, Length_N_Cond
(Ck_Node
, T_Typ
, Indx
));
9238 -- Construct the test and insert into the tree
9240 if Present
(Cond
) then
9242 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
9246 (Make_Raise_Constraint_Error
(Loc
,
9248 Reason
=> CE_Length_Check_Failed
));
9252 end Selected_Length_Checks
;
9254 ---------------------------
9255 -- Selected_Range_Checks --
9256 ---------------------------
9258 function Selected_Range_Checks
9260 Target_Typ
: Entity_Id
;
9261 Source_Typ
: Entity_Id
;
9262 Warn_Node
: Node_Id
) return Check_Result
9264 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
9267 Expr_Actual
: Node_Id
;
9269 Cond
: Node_Id
:= Empty
;
9270 Do_Access
: Boolean := False;
9271 Wnode
: Node_Id
:= Warn_Node
;
9272 Ret_Result
: Check_Result
:= (Empty
, Empty
);
9273 Num_Checks
: Integer := 0;
9275 procedure Add_Check
(N
: Node_Id
);
9276 -- Adds the action given to Ret_Result if N is non-Empty
9278 function Discrete_Range_Cond
9280 Typ
: Entity_Id
) return Node_Id
;
9281 -- Returns expression to compute:
9282 -- Low_Bound (Expr) < Typ'First
9284 -- High_Bound (Expr) > Typ'Last
9286 function Discrete_Expr_Cond
9288 Typ
: Entity_Id
) return Node_Id
;
9289 -- Returns expression to compute:
9294 function Get_E_First_Or_Last
9298 Nam
: Name_Id
) return Node_Id
;
9299 -- Returns an attribute reference
9300 -- E'First or E'Last
9301 -- with a source location of Loc.
9303 -- Nam is Name_First or Name_Last, according to which attribute is
9304 -- desired. If Indx is non-zero, it is passed as a literal in the
9305 -- Expressions of the attribute reference (identifying the desired
9306 -- array dimension).
9308 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
9309 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
9310 -- Returns expression to compute:
9311 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
9313 function Range_E_Cond
9314 (Exptyp
: Entity_Id
;
9318 -- Returns expression to compute:
9319 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
9321 function Range_Equal_E_Cond
9322 (Exptyp
: Entity_Id
;
9324 Indx
: Nat
) return Node_Id
;
9325 -- Returns expression to compute:
9326 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
9328 function Range_N_Cond
9331 Indx
: Nat
) return Node_Id
;
9332 -- Return expression to compute:
9333 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
9339 procedure Add_Check
(N
: Node_Id
) is
9343 -- For now, ignore attempt to place more than 2 checks ???
9345 if Num_Checks
= 2 then
9349 pragma Assert
(Num_Checks
<= 1);
9350 Num_Checks
:= Num_Checks
+ 1;
9351 Ret_Result
(Num_Checks
) := N
;
9355 -------------------------
9356 -- Discrete_Expr_Cond --
9357 -------------------------
9359 function Discrete_Expr_Cond
9361 Typ
: Entity_Id
) return Node_Id
9369 Convert_To
(Base_Type
(Typ
),
9370 Duplicate_Subexpr_No_Checks
(Expr
)),
9372 Convert_To
(Base_Type
(Typ
),
9373 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
))),
9378 Convert_To
(Base_Type
(Typ
),
9379 Duplicate_Subexpr_No_Checks
(Expr
)),
9383 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
))));
9384 end Discrete_Expr_Cond
;
9386 -------------------------
9387 -- Discrete_Range_Cond --
9388 -------------------------
9390 function Discrete_Range_Cond
9392 Typ
: Entity_Id
) return Node_Id
9394 LB
: Node_Id
:= Low_Bound
(Expr
);
9395 HB
: Node_Id
:= High_Bound
(Expr
);
9397 Left_Opnd
: Node_Id
;
9398 Right_Opnd
: Node_Id
;
9401 if Nkind
(LB
) = N_Identifier
9402 and then Ekind
(Entity
(LB
)) = E_Discriminant
9404 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
9411 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
9416 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
)));
9418 if Nkind
(HB
) = N_Identifier
9419 and then Ekind
(Entity
(HB
)) = E_Discriminant
9421 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
9428 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
9433 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
)));
9435 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
9436 end Discrete_Range_Cond
;
9438 -------------------------
9439 -- Get_E_First_Or_Last --
9440 -------------------------
9442 function Get_E_First_Or_Last
9446 Nam
: Name_Id
) return Node_Id
9451 Exprs
:= New_List
(Make_Integer_Literal
(Loc
, UI_From_Int
(Indx
)));
9456 return Make_Attribute_Reference
(Loc
,
9457 Prefix
=> New_Occurrence_Of
(E
, Loc
),
9458 Attribute_Name
=> Nam
,
9459 Expressions
=> Exprs
);
9460 end Get_E_First_Or_Last
;
9466 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
9469 Make_Attribute_Reference
(Loc
,
9470 Attribute_Name
=> Name_First
,
9472 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
9473 Expressions
=> New_List
(
9474 Make_Integer_Literal
(Loc
, Indx
)));
9481 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
9484 Make_Attribute_Reference
(Loc
,
9485 Attribute_Name
=> Name_Last
,
9487 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
9488 Expressions
=> New_List
(
9489 Make_Integer_Literal
(Loc
, Indx
)));
9496 function Range_E_Cond
9497 (Exptyp
: Entity_Id
;
9499 Indx
: Nat
) return Node_Id
9507 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
9509 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
9514 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
9516 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
9519 ------------------------
9520 -- Range_Equal_E_Cond --
9521 ------------------------
9523 function Range_Equal_E_Cond
9524 (Exptyp
: Entity_Id
;
9526 Indx
: Nat
) return Node_Id
9534 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
9536 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
9541 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
9543 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
9544 end Range_Equal_E_Cond
;
9550 function Range_N_Cond
9553 Indx
: Nat
) return Node_Id
9561 Get_N_First
(Expr
, Indx
),
9563 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
9568 Get_N_Last
(Expr
, Indx
),
9570 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
9573 -- Start of processing for Selected_Range_Checks
9576 if not Expander_Active
then
9580 if Target_Typ
= Any_Type
9581 or else Target_Typ
= Any_Composite
9582 or else Raises_Constraint_Error
(Ck_Node
)
9591 T_Typ
:= Target_Typ
;
9593 if No
(Source_Typ
) then
9594 S_Typ
:= Etype
(Ck_Node
);
9596 S_Typ
:= Source_Typ
;
9599 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
9603 -- The order of evaluating T_Typ before S_Typ seems to be critical
9604 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
9605 -- in, and since Node can be an N_Range node, it might be invalid.
9606 -- Should there be an assert check somewhere for taking the Etype of
9607 -- an N_Range node ???
9609 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
9610 S_Typ
:= Designated_Type
(S_Typ
);
9611 T_Typ
:= Designated_Type
(T_Typ
);
9614 -- A simple optimization for the null case
9616 if Known_Null
(Ck_Node
) then
9621 -- For an N_Range Node, check for a null range and then if not
9622 -- null generate a range check action.
9624 if Nkind
(Ck_Node
) = N_Range
then
9626 -- There's no point in checking a range against itself
9628 if Ck_Node
= Scalar_Range
(T_Typ
) then
9633 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
9634 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
9635 Known_T_LB
: constant Boolean := Compile_Time_Known_Value
(T_LB
);
9636 Known_T_HB
: constant Boolean := Compile_Time_Known_Value
(T_HB
);
9638 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
9639 HB
: Node_Id
:= High_Bound
(Ck_Node
);
9643 Null_Range
: Boolean;
9644 Out_Of_Range_L
: Boolean;
9645 Out_Of_Range_H
: Boolean;
9648 -- Compute what is known at compile time
9650 if Known_T_LB
and Known_T_HB
then
9651 if Compile_Time_Known_Value
(LB
) then
9654 -- There's no point in checking that a bound is within its
9655 -- own range so pretend that it is known in this case. First
9656 -- deal with low bound.
9658 elsif Ekind
(Etype
(LB
)) = E_Signed_Integer_Subtype
9659 and then Scalar_Range
(Etype
(LB
)) = Scalar_Range
(T_Typ
)
9668 -- Likewise for the high bound
9670 if Compile_Time_Known_Value
(HB
) then
9673 elsif Ekind
(Etype
(HB
)) = E_Signed_Integer_Subtype
9674 and then Scalar_Range
(Etype
(HB
)) = Scalar_Range
(T_Typ
)
9683 -- Check for case where everything is static and we can do the
9684 -- check at compile time. This is skipped if we have an access
9685 -- type, since the access value may be null.
9687 -- ??? This code can be improved since you only need to know that
9688 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
9689 -- compile time to emit pertinent messages.
9691 if Known_T_LB
and Known_T_HB
and Known_LB
and Known_HB
9694 -- Floating-point case
9696 if Is_Floating_Point_Type
(S_Typ
) then
9697 Null_Range
:= Expr_Value_R
(HB
) < Expr_Value_R
(LB
);
9699 (Expr_Value_R
(LB
) < Expr_Value_R
(T_LB
))
9701 (Expr_Value_R
(LB
) > Expr_Value_R
(T_HB
));
9704 (Expr_Value_R
(HB
) > Expr_Value_R
(T_HB
))
9706 (Expr_Value_R
(HB
) < Expr_Value_R
(T_LB
));
9708 -- Fixed or discrete type case
9711 Null_Range
:= Expr_Value
(HB
) < Expr_Value
(LB
);
9713 (Expr_Value
(LB
) < Expr_Value
(T_LB
))
9715 (Expr_Value
(LB
) > Expr_Value
(T_HB
));
9718 (Expr_Value
(HB
) > Expr_Value
(T_HB
))
9720 (Expr_Value
(HB
) < Expr_Value
(T_LB
));
9723 if not Null_Range
then
9724 if Out_Of_Range_L
then
9725 if No
(Warn_Node
) then
9727 (Compile_Time_Constraint_Error
9728 (Low_Bound
(Ck_Node
),
9729 "static value out of range of}??", T_Typ
));
9733 (Compile_Time_Constraint_Error
9735 "static range out of bounds of}??", T_Typ
));
9739 if Out_Of_Range_H
then
9740 if No
(Warn_Node
) then
9742 (Compile_Time_Constraint_Error
9743 (High_Bound
(Ck_Node
),
9744 "static value out of range of}??", T_Typ
));
9748 (Compile_Time_Constraint_Error
9750 "static range out of bounds of}??", T_Typ
));
9757 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
9758 HB
: Node_Id
:= High_Bound
(Ck_Node
);
9761 -- If either bound is a discriminant and we are within the
9762 -- record declaration, it is a use of the discriminant in a
9763 -- constraint of a component, and nothing can be checked
9764 -- here. The check will be emitted within the init proc.
9765 -- Before then, the discriminal has no real meaning.
9766 -- Similarly, if the entity is a discriminal, there is no
9767 -- check to perform yet.
9769 -- The same holds within a discriminated synchronized type,
9770 -- where the discriminant may constrain a component or an
9773 if Nkind
(LB
) = N_Identifier
9774 and then Denotes_Discriminant
(LB
, True)
9776 if Current_Scope
= Scope
(Entity
(LB
))
9777 or else Is_Concurrent_Type
(Current_Scope
)
9778 or else Ekind
(Entity
(LB
)) /= E_Discriminant
9783 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
9787 if Nkind
(HB
) = N_Identifier
9788 and then Denotes_Discriminant
(HB
, True)
9790 if Current_Scope
= Scope
(Entity
(HB
))
9791 or else Is_Concurrent_Type
(Current_Scope
)
9792 or else Ekind
(Entity
(HB
)) /= E_Discriminant
9797 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
9801 Cond
:= Discrete_Range_Cond
(Ck_Node
, T_Typ
);
9802 Set_Paren_Count
(Cond
, 1);
9809 Convert_To
(Base_Type
(Etype
(HB
)),
9810 Duplicate_Subexpr_No_Checks
(HB
)),
9812 Convert_To
(Base_Type
(Etype
(LB
)),
9813 Duplicate_Subexpr_No_Checks
(LB
))),
9814 Right_Opnd
=> Cond
);
9819 elsif Is_Scalar_Type
(S_Typ
) then
9821 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
9822 -- except the above simply sets a flag in the node and lets
9823 -- gigi generate the check base on the Etype of the expression.
9824 -- Sometimes, however we want to do a dynamic check against an
9825 -- arbitrary target type, so we do that here.
9827 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
9828 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9830 -- For literals, we can tell if the constraint error will be
9831 -- raised at compile time, so we never need a dynamic check, but
9832 -- if the exception will be raised, then post the usual warning,
9833 -- and replace the literal with a raise constraint error
9834 -- expression. As usual, skip this for access types
9836 elsif Compile_Time_Known_Value
(Ck_Node
) and then not Do_Access
then
9838 LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
9839 UB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
9841 Out_Of_Range
: Boolean;
9842 Static_Bounds
: constant Boolean :=
9843 Compile_Time_Known_Value
(LB
)
9844 and Compile_Time_Known_Value
(UB
);
9847 -- Following range tests should use Sem_Eval routine ???
9849 if Static_Bounds
then
9850 if Is_Floating_Point_Type
(S_Typ
) then
9852 (Expr_Value_R
(Ck_Node
) < Expr_Value_R
(LB
))
9854 (Expr_Value_R
(Ck_Node
) > Expr_Value_R
(UB
));
9856 -- Fixed or discrete type
9860 Expr_Value
(Ck_Node
) < Expr_Value
(LB
)
9862 Expr_Value
(Ck_Node
) > Expr_Value
(UB
);
9865 -- Bounds of the type are static and the literal is out of
9866 -- range so output a warning message.
9868 if Out_Of_Range
then
9869 if No
(Warn_Node
) then
9871 (Compile_Time_Constraint_Error
9873 "static value out of range of}??", T_Typ
));
9877 (Compile_Time_Constraint_Error
9879 "static value out of range of}??", T_Typ
));
9884 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9888 -- Here for the case of a non-static expression, we need a runtime
9889 -- check unless the source type range is guaranteed to be in the
9890 -- range of the target type.
9893 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
9894 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9899 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
9900 if Is_Constrained
(T_Typ
) then
9902 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
9903 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
9905 if Is_Access_Type
(Exptyp
) then
9906 Exptyp
:= Designated_Type
(Exptyp
);
9909 -- String_Literal case. This needs to be handled specially be-
9910 -- cause no index types are available for string literals. The
9911 -- condition is simply:
9913 -- T_Typ'Length = string-literal-length
9915 if Nkind
(Expr_Actual
) = N_String_Literal
then
9918 -- General array case. Here we have a usable actual subtype for
9919 -- the expression, and the condition is built from the two types
9921 -- T_Typ'First < Exptyp'First or else
9922 -- T_Typ'Last > Exptyp'Last or else
9923 -- T_Typ'First(1) < Exptyp'First(1) or else
9924 -- T_Typ'Last(1) > Exptyp'Last(1) or else
9927 elsif Is_Constrained
(Exptyp
) then
9929 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9935 L_Index
:= First_Index
(T_Typ
);
9936 R_Index
:= First_Index
(Exptyp
);
9938 for Indx
in 1 .. Ndims
loop
9939 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
9941 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
9943 -- Deal with compile time length check. Note that we
9944 -- skip this in the access case, because the access
9945 -- value may be null, so we cannot know statically.
9948 Subtypes_Statically_Match
9949 (Etype
(L_Index
), Etype
(R_Index
))
9951 -- If the target type is constrained then we
9952 -- have to check for exact equality of bounds
9953 -- (required for qualified expressions).
9955 if Is_Constrained
(T_Typ
) then
9958 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
9961 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
9971 -- Handle cases where we do not get a usable actual subtype that
9972 -- is constrained. This happens for example in the function call
9973 -- and explicit dereference cases. In these cases, we have to get
9974 -- the length or range from the expression itself, making sure we
9975 -- do not evaluate it more than once.
9977 -- Here Ck_Node is the original expression, or more properly the
9978 -- result of applying Duplicate_Expr to the original tree,
9979 -- forcing the result to be a name.
9983 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9986 -- Build the condition for the explicit dereference case
9988 for Indx
in 1 .. Ndims
loop
9990 (Cond
, Range_N_Cond
(Ck_Node
, T_Typ
, Indx
));
9996 -- For a conversion to an unconstrained array type, generate an
9997 -- Action to check that the bounds of the source value are within
9998 -- the constraints imposed by the target type (RM 4.6(38)). No
9999 -- check is needed for a conversion to an access to unconstrained
10000 -- array type, as 4.6(24.15/2) requires the designated subtypes
10001 -- of the two access types to statically match.
10003 if Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
10004 and then not Do_Access
10007 Opnd_Index
: Node_Id
;
10008 Targ_Index
: Node_Id
;
10009 Opnd_Range
: Node_Id
;
10012 Opnd_Index
:= First_Index
(Get_Actual_Subtype
(Ck_Node
));
10013 Targ_Index
:= First_Index
(T_Typ
);
10014 while Present
(Opnd_Index
) loop
10016 -- If the index is a range, use its bounds. If it is an
10017 -- entity (as will be the case if it is a named subtype
10018 -- or an itype created for a slice) retrieve its range.
10020 if Is_Entity_Name
(Opnd_Index
)
10021 and then Is_Type
(Entity
(Opnd_Index
))
10023 Opnd_Range
:= Scalar_Range
(Entity
(Opnd_Index
));
10025 Opnd_Range
:= Opnd_Index
;
10028 if Nkind
(Opnd_Range
) = N_Range
then
10030 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
10031 Assume_Valid
=> True)
10034 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
10035 Assume_Valid
=> True)
10039 -- If null range, no check needed
10042 Compile_Time_Known_Value
(High_Bound
(Opnd_Range
))
10044 Compile_Time_Known_Value
(Low_Bound
(Opnd_Range
))
10046 Expr_Value
(High_Bound
(Opnd_Range
)) <
10047 Expr_Value
(Low_Bound
(Opnd_Range
))
10051 elsif Is_Out_Of_Range
10052 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
10053 Assume_Valid
=> True)
10056 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
10057 Assume_Valid
=> True)
10060 (Compile_Time_Constraint_Error
10061 (Wnode
, "value out of range of}??", T_Typ
));
10066 Discrete_Range_Cond
10067 (Opnd_Range
, Etype
(Targ_Index
)));
10071 Next_Index
(Opnd_Index
);
10072 Next_Index
(Targ_Index
);
10079 -- Construct the test and insert into the tree
10081 if Present
(Cond
) then
10083 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
10087 (Make_Raise_Constraint_Error
(Loc
,
10089 Reason
=> CE_Range_Check_Failed
));
10093 end Selected_Range_Checks
;
10095 -------------------------------
10096 -- Storage_Checks_Suppressed --
10097 -------------------------------
10099 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
10101 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
10102 return Is_Check_Suppressed
(E
, Storage_Check
);
10104 return Scope_Suppress
.Suppress
(Storage_Check
);
10106 end Storage_Checks_Suppressed
;
10108 ---------------------------
10109 -- Tag_Checks_Suppressed --
10110 ---------------------------
10112 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
10115 and then Checks_May_Be_Suppressed
(E
)
10117 return Is_Check_Suppressed
(E
, Tag_Check
);
10119 return Scope_Suppress
.Suppress
(Tag_Check
);
10121 end Tag_Checks_Suppressed
;
10123 ---------------------------------------
10124 -- Validate_Alignment_Check_Warnings --
10125 ---------------------------------------
10127 procedure Validate_Alignment_Check_Warnings
is
10129 for J
in Alignment_Warnings
.First
.. Alignment_Warnings
.Last
loop
10131 AWR
: Alignment_Warnings_Record
10132 renames Alignment_Warnings
.Table
(J
);
10134 if Known_Alignment
(AWR
.E
)
10135 and then AWR
.A
mod Alignment
(AWR
.E
) = 0
10137 Delete_Warning_And_Continuations
(AWR
.W
);
10141 end Validate_Alignment_Check_Warnings
;
10143 --------------------------
10144 -- Validity_Check_Range --
10145 --------------------------
10147 procedure Validity_Check_Range
10149 Related_Id
: Entity_Id
:= Empty
)
10152 if Validity_Checks_On
and Validity_Check_Operands
then
10153 if Nkind
(N
) = N_Range
then
10155 (Expr
=> Low_Bound
(N
),
10156 Related_Id
=> Related_Id
,
10157 Is_Low_Bound
=> True);
10160 (Expr
=> High_Bound
(N
),
10161 Related_Id
=> Related_Id
,
10162 Is_High_Bound
=> True);
10165 end Validity_Check_Range
;
10167 --------------------------------
10168 -- Validity_Checks_Suppressed --
10169 --------------------------------
10171 function Validity_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
10173 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
10174 return Is_Check_Suppressed
(E
, Validity_Check
);
10176 return Scope_Suppress
.Suppress
(Validity_Check
);
10178 end Validity_Checks_Suppressed
;