1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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 Errout
; use Errout
;
31 with Exp_Ch2
; use Exp_Ch2
;
32 with Exp_Ch4
; use Exp_Ch4
;
33 with Exp_Ch11
; use Exp_Ch11
;
34 with Exp_Pakd
; use Exp_Pakd
;
35 with Exp_Tss
; use Exp_Tss
;
36 with Exp_Util
; use Exp_Util
;
37 with Elists
; use Elists
;
38 with Expander
; use Expander
;
39 with Eval_Fat
; use Eval_Fat
;
40 with Freeze
; use Freeze
;
42 with Nlists
; use Nlists
;
43 with Nmake
; use Nmake
;
45 with Output
; use Output
;
46 with Restrict
; use Restrict
;
47 with Rident
; use Rident
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Aux
; use Sem_Aux
;
51 with Sem_Eval
; use Sem_Eval
;
52 with Sem_Ch3
; use Sem_Ch3
;
53 with Sem_Ch8
; use Sem_Ch8
;
54 with Sem_Res
; use Sem_Res
;
55 with Sem_Util
; use Sem_Util
;
56 with Sem_Warn
; use Sem_Warn
;
57 with Sinfo
; use Sinfo
;
58 with Sinput
; use Sinput
;
59 with Snames
; use Snames
;
60 with Sprint
; use Sprint
;
61 with Stand
; use Stand
;
62 with Stringt
; use Stringt
;
63 with Targparm
; use Targparm
;
64 with Tbuild
; use Tbuild
;
65 with Ttypes
; use Ttypes
;
66 with Urealp
; use Urealp
;
67 with Validsw
; use Validsw
;
69 package body Checks
is
71 -- General note: many of these routines are concerned with generating
72 -- checking code to make sure that constraint error is raised at runtime.
73 -- Clearly this code is only needed if the expander is active, since
74 -- otherwise we will not be generating code or going into the runtime
77 -- We therefore disconnect most of these checks if the expander is
78 -- inactive. This has the additional benefit that we do not need to
79 -- worry about the tree being messed up by previous errors (since errors
80 -- turn off expansion anyway).
82 -- There are a few exceptions to the above rule. For instance routines
83 -- such as Apply_Scalar_Range_Check that do not insert any code can be
84 -- safely called even when the Expander is inactive (but Errors_Detected
85 -- is 0). The benefit of executing this code when expansion is off, is
86 -- the ability to emit constraint error warning for static expressions
87 -- even when we are not generating code.
89 -- The above is modified in gnatprove mode to ensure that proper check
90 -- flags are always placed, even if expansion is off.
92 -------------------------------------
93 -- Suppression of Redundant Checks --
94 -------------------------------------
96 -- This unit implements a limited circuit for removal of redundant
97 -- checks. The processing is based on a tracing of simple sequential
98 -- flow. For any sequence of statements, we save expressions that are
99 -- marked to be checked, and then if the same expression appears later
100 -- with the same check, then under certain circumstances, the second
101 -- check can be suppressed.
103 -- Basically, we can suppress the check if we know for certain that
104 -- the previous expression has been elaborated (together with its
105 -- check), and we know that the exception frame is the same, and that
106 -- nothing has happened to change the result of the exception.
108 -- Let us examine each of these three conditions in turn to describe
109 -- how we ensure that this condition is met.
111 -- First, we need to know for certain that the previous expression has
112 -- been executed. This is done principally by the mechanism of calling
113 -- Conditional_Statements_Begin at the start of any statement sequence
114 -- and Conditional_Statements_End at the end. The End call causes all
115 -- checks remembered since the Begin call to be discarded. This does
116 -- miss a few cases, notably the case of a nested BEGIN-END block with
117 -- no exception handlers. But the important thing is to be conservative.
118 -- The other protection is that all checks are discarded if a label
119 -- is encountered, since then the assumption of sequential execution
120 -- is violated, and we don't know enough about the flow.
122 -- Second, we need to know that the exception frame is the same. We
123 -- do this by killing all remembered checks when we enter a new frame.
124 -- Again, that's over-conservative, but generally the cases we can help
125 -- with are pretty local anyway (like the body of a loop for example).
127 -- Third, we must be sure to forget any checks which are no longer valid.
128 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
129 -- used to note any changes to local variables. We only attempt to deal
130 -- with checks involving local variables, so we do not need to worry
131 -- about global variables. Second, a call to any non-global procedure
132 -- causes us to abandon all stored checks, since such a all may affect
133 -- the values of any local variables.
135 -- The following define the data structures used to deal with remembering
136 -- checks so that redundant checks can be eliminated as described above.
138 -- Right now, the only expressions that we deal with are of the form of
139 -- simple local objects (either declared locally, or IN parameters) or
140 -- such objects plus/minus a compile time known constant. We can do
141 -- more later on if it seems worthwhile, but this catches many simple
142 -- cases in practice.
144 -- The following record type reflects a single saved check. An entry
145 -- is made in the stack of saved checks if and only if the expression
146 -- has been elaborated with the indicated checks.
148 type Saved_Check
is record
150 -- Set True if entry is killed by Kill_Checks
153 -- The entity involved in the expression that is checked
156 -- A compile time value indicating the result of adding or
157 -- subtracting a compile time value. This value is to be
158 -- added to the value of the Entity. A value of zero is
159 -- used for the case of a simple entity reference.
161 Check_Type
: Character;
162 -- This is set to 'R' for a range check (in which case Target_Type
163 -- is set to the target type for the range check) or to 'O' for an
164 -- overflow check (in which case Target_Type is set to Empty).
166 Target_Type
: Entity_Id
;
167 -- Used only if Do_Range_Check is set. Records the target type for
168 -- the check. We need this, because a check is a duplicate only if
169 -- it has the same target type (or more accurately one with a
170 -- range that is smaller or equal to the stored target type of a
174 -- The following table keeps track of saved checks. Rather than use an
175 -- extensible table. We just use a table of fixed size, and we discard
176 -- any saved checks that do not fit. That's very unlikely to happen and
177 -- this is only an optimization in any case.
179 Saved_Checks
: array (Int
range 1 .. 200) of Saved_Check
;
180 -- Array of saved checks
182 Num_Saved_Checks
: Nat
:= 0;
183 -- Number of saved checks
185 -- The following stack keeps track of statement ranges. It is treated
186 -- as a stack. When Conditional_Statements_Begin is called, an entry
187 -- is pushed onto this stack containing the value of Num_Saved_Checks
188 -- at the time of the call. Then when Conditional_Statements_End is
189 -- called, this value is popped off and used to reset Num_Saved_Checks.
191 -- Note: again, this is a fixed length stack with a size that should
192 -- always be fine. If the value of the stack pointer goes above the
193 -- limit, then we just forget all saved checks.
195 Saved_Checks_Stack
: array (Int
range 1 .. 100) of Nat
;
196 Saved_Checks_TOS
: Nat
:= 0;
198 -----------------------
199 -- Local Subprograms --
200 -----------------------
202 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
);
203 -- Used to apply arithmetic overflow checks for all cases except operators
204 -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we
205 -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a
206 -- signed integer arithmetic operator (but not an if or case expression).
207 -- It is also called for types other than signed integers.
209 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
);
210 -- Used to apply arithmetic overflow checks for the case where the overflow
211 -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer
212 -- arithmetic op (which includes the case of if and case expressions). Note
213 -- that Do_Overflow_Check may or may not be set for node Op. In these modes
214 -- we have work to do even if overflow checking is suppressed.
216 procedure Apply_Division_Check
221 -- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies
222 -- division checks as required if the Do_Division_Check flag is set.
223 -- Rlo and Rhi give the possible range of the right operand, these values
224 -- can be referenced and trusted only if ROK is set True.
226 procedure Apply_Float_Conversion_Check
228 Target_Typ
: Entity_Id
);
229 -- The checks on a conversion from a floating-point type to an integer
230 -- type are delicate. They have to be performed before conversion, they
231 -- have to raise an exception when the operand is a NaN, and rounding must
232 -- be taken into account to determine the safe bounds of the operand.
234 procedure Apply_Selected_Length_Checks
236 Target_Typ
: Entity_Id
;
237 Source_Typ
: Entity_Id
;
238 Do_Static
: Boolean);
239 -- This is the subprogram that does all the work for Apply_Length_Check
240 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
241 -- described for the above routines. The Do_Static flag indicates that
242 -- only a static check is to be done.
244 procedure Apply_Selected_Range_Checks
246 Target_Typ
: Entity_Id
;
247 Source_Typ
: Entity_Id
;
248 Do_Static
: Boolean);
249 -- This is the subprogram that does all the work for Apply_Range_Check.
250 -- Expr, Target_Typ and Source_Typ are as described for the above
251 -- routine. The Do_Static flag indicates that only a static check is
254 type Check_Type
is new Check_Id
range Access_Check
.. Division_Check
;
255 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean;
256 -- This function is used to see if an access or division by zero check is
257 -- needed. The check is to be applied to a single variable appearing in the
258 -- source, and N is the node for the reference. If N is not of this form,
259 -- True is returned with no further processing. If N is of the right form,
260 -- then further processing determines if the given Check is needed.
262 -- The particular circuit is to see if we have the case of a check that is
263 -- not needed because it appears in the right operand of a short circuited
264 -- conditional where the left operand guards the check. For example:
266 -- if Var = 0 or else Q / Var > 12 then
270 -- In this example, the division check is not required. At the same time
271 -- we can issue warnings for suspicious use of non-short-circuited forms,
274 -- if Var = 0 or Q / Var > 12 then
280 Check_Type
: Character;
281 Target_Type
: Entity_Id
;
282 Entry_OK
: out Boolean;
286 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
287 -- to see if a check is of the form for optimization, and if so, to see
288 -- if it has already been performed. Expr is the expression to check,
289 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
290 -- Target_Type is the target type for a range check, and Empty for an
291 -- overflow check. If the entry is not of the form for optimization,
292 -- then Entry_OK is set to False, and the remaining out parameters
293 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
294 -- entity and offset from the expression. Check_Num is the number of
295 -- a matching saved entry in Saved_Checks, or zero if no such entry
298 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
;
299 -- If a discriminal is used in constraining a prival, Return reference
300 -- to the discriminal of the protected body (which renames the parameter
301 -- of the enclosing protected operation). This clumsy transformation is
302 -- needed because privals are created too late and their actual subtypes
303 -- are not available when analysing the bodies of the protected operations.
304 -- This function is called whenever the bound is an entity and the scope
305 -- indicates a protected operation. If the bound is an in-parameter of
306 -- a protected operation that is not a prival, the function returns the
308 -- To be cleaned up???
310 function Guard_Access
313 Ck_Node
: Node_Id
) return Node_Id
;
314 -- In the access type case, guard the test with a test to ensure
315 -- that the access value is non-null, since the checks do not
316 -- not apply to null access values.
318 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
);
319 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
320 -- Constraint_Error node.
322 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean;
323 -- Returns True if node N is for an arithmetic operation with signed
324 -- integer operands. This includes unary and binary operators, and also
325 -- if and case expression nodes where the dependent expressions are of
326 -- a signed integer type. These are the kinds of nodes for which special
327 -- handling applies in MINIMIZED or ELIMINATED overflow checking mode.
329 function Range_Or_Validity_Checks_Suppressed
330 (Expr
: Node_Id
) return Boolean;
331 -- Returns True if either range or validity checks or both are suppressed
332 -- for the type of the given expression, or, if the expression is the name
333 -- of an entity, if these checks are suppressed for the entity.
335 function Selected_Length_Checks
337 Target_Typ
: Entity_Id
;
338 Source_Typ
: Entity_Id
;
339 Warn_Node
: Node_Id
) return Check_Result
;
340 -- Like Apply_Selected_Length_Checks, except it doesn't modify
341 -- anything, just returns a list of nodes as described in the spec of
342 -- this package for the Range_Check function.
344 function Selected_Range_Checks
346 Target_Typ
: Entity_Id
;
347 Source_Typ
: Entity_Id
;
348 Warn_Node
: Node_Id
) return Check_Result
;
349 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
350 -- just returns a list of nodes as described in the spec of this package
351 -- for the Range_Check function.
353 ------------------------------
354 -- Access_Checks_Suppressed --
355 ------------------------------
357 function Access_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
359 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
360 return Is_Check_Suppressed
(E
, Access_Check
);
362 return Scope_Suppress
.Suppress
(Access_Check
);
364 end Access_Checks_Suppressed
;
366 -------------------------------------
367 -- Accessibility_Checks_Suppressed --
368 -------------------------------------
370 function Accessibility_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
372 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
373 return Is_Check_Suppressed
(E
, Accessibility_Check
);
375 return Scope_Suppress
.Suppress
(Accessibility_Check
);
377 end Accessibility_Checks_Suppressed
;
379 -----------------------------
380 -- Activate_Division_Check --
381 -----------------------------
383 procedure Activate_Division_Check
(N
: Node_Id
) is
385 Set_Do_Division_Check
(N
, True);
386 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
387 end Activate_Division_Check
;
389 -----------------------------
390 -- Activate_Overflow_Check --
391 -----------------------------
393 procedure Activate_Overflow_Check
(N
: Node_Id
) is
395 if not Nkind_In
(N
, N_Op_Rem
, N_Op_Mod
, N_Op_Plus
) then
396 Set_Do_Overflow_Check
(N
, True);
397 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
399 end Activate_Overflow_Check
;
401 --------------------------
402 -- Activate_Range_Check --
403 --------------------------
405 procedure Activate_Range_Check
(N
: Node_Id
) is
407 Set_Do_Range_Check
(N
, True);
408 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
409 end Activate_Range_Check
;
411 ---------------------------------
412 -- Alignment_Checks_Suppressed --
413 ---------------------------------
415 function Alignment_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
417 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
418 return Is_Check_Suppressed
(E
, Alignment_Check
);
420 return Scope_Suppress
.Suppress
(Alignment_Check
);
422 end Alignment_Checks_Suppressed
;
424 -------------------------
425 -- Append_Range_Checks --
426 -------------------------
428 procedure Append_Range_Checks
429 (Checks
: Check_Result
;
431 Suppress_Typ
: Entity_Id
;
432 Static_Sloc
: Source_Ptr
;
435 Internal_Flag_Node
: constant Node_Id
:= Flag_Node
;
436 Internal_Static_Sloc
: constant Source_Ptr
:= Static_Sloc
;
438 Checks_On
: constant Boolean :=
439 (not Index_Checks_Suppressed
(Suppress_Typ
))
440 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
443 -- For now we just return if Checks_On is false, however this should
444 -- be enhanced to check for an always True value in the condition
445 -- and to generate a compilation warning???
447 if not Checks_On
then
452 exit when No
(Checks
(J
));
454 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
455 and then Present
(Condition
(Checks
(J
)))
457 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
458 Append_To
(Stmts
, Checks
(J
));
459 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
465 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
466 Reason
=> CE_Range_Check_Failed
));
469 end Append_Range_Checks
;
471 ------------------------
472 -- Apply_Access_Check --
473 ------------------------
475 procedure Apply_Access_Check
(N
: Node_Id
) is
476 P
: constant Node_Id
:= Prefix
(N
);
479 -- We do not need checks if we are not generating code (i.e. the
480 -- expander is not active). This is not just an optimization, there
481 -- are cases (e.g. with pragma Debug) where generating the checks
482 -- can cause real trouble).
484 if not Expander_Active
then
488 -- No check if short circuiting makes check unnecessary
490 if not Check_Needed
(P
, Access_Check
) then
494 -- No check if accessing the Offset_To_Top component of a dispatch
495 -- table. They are safe by construction.
497 if Tagged_Type_Expansion
498 and then Present
(Etype
(P
))
499 and then RTU_Loaded
(Ada_Tags
)
500 and then RTE_Available
(RE_Offset_To_Top_Ptr
)
501 and then Etype
(P
) = RTE
(RE_Offset_To_Top_Ptr
)
506 -- Otherwise go ahead and install the check
508 Install_Null_Excluding_Check
(P
);
509 end Apply_Access_Check
;
511 -------------------------------
512 -- Apply_Accessibility_Check --
513 -------------------------------
515 procedure Apply_Accessibility_Check
518 Insert_Node
: Node_Id
)
520 Loc
: constant Source_Ptr
:= Sloc
(N
);
521 Param_Ent
: Entity_Id
:= Param_Entity
(N
);
522 Param_Level
: Node_Id
;
523 Type_Level
: Node_Id
;
526 if Ada_Version
>= Ada_2012
527 and then not Present
(Param_Ent
)
528 and then Is_Entity_Name
(N
)
529 and then Ekind_In
(Entity
(N
), E_Constant
, E_Variable
)
530 and then Present
(Effective_Extra_Accessibility
(Entity
(N
)))
532 Param_Ent
:= Entity
(N
);
533 while Present
(Renamed_Object
(Param_Ent
)) loop
535 -- Renamed_Object must return an Entity_Name here
536 -- because of preceding "Present (E_E_A (...))" test.
538 Param_Ent
:= Entity
(Renamed_Object
(Param_Ent
));
542 if Inside_A_Generic
then
545 -- Only apply the run-time check if the access parameter has an
546 -- associated extra access level parameter and when the level of the
547 -- type is less deep than the level of the access parameter, and
548 -- accessibility checks are not suppressed.
550 elsif Present
(Param_Ent
)
551 and then Present
(Extra_Accessibility
(Param_Ent
))
552 and then UI_Gt
(Object_Access_Level
(N
),
553 Deepest_Type_Access_Level
(Typ
))
554 and then not Accessibility_Checks_Suppressed
(Param_Ent
)
555 and then not Accessibility_Checks_Suppressed
(Typ
)
558 New_Occurrence_Of
(Extra_Accessibility
(Param_Ent
), Loc
);
561 Make_Integer_Literal
(Loc
, Deepest_Type_Access_Level
(Typ
));
563 -- Raise Program_Error if the accessibility level of the access
564 -- parameter is deeper than the level of the target access type.
566 Insert_Action
(Insert_Node
,
567 Make_Raise_Program_Error
(Loc
,
570 Left_Opnd
=> Param_Level
,
571 Right_Opnd
=> Type_Level
),
572 Reason
=> PE_Accessibility_Check_Failed
));
574 Analyze_And_Resolve
(N
);
576 end Apply_Accessibility_Check
;
578 --------------------------------
579 -- Apply_Address_Clause_Check --
580 --------------------------------
582 procedure Apply_Address_Clause_Check
(E
: Entity_Id
; N
: Node_Id
) is
583 pragma Assert
(Nkind
(N
) = N_Freeze_Entity
);
585 AC
: constant Node_Id
:= Address_Clause
(E
);
586 Loc
: constant Source_Ptr
:= Sloc
(AC
);
587 Typ
: constant Entity_Id
:= Etype
(E
);
588 Aexp
: constant Node_Id
:= Expression
(AC
);
591 -- Address expression (not necessarily the same as Aexp, for example
592 -- when Aexp is a reference to a constant, in which case Expr gets
593 -- reset to reference the value expression of the constant.
595 procedure Compile_Time_Bad_Alignment
;
596 -- Post error warnings when alignment is known to be incompatible. Note
597 -- that we do not go as far as inserting a raise of Program_Error since
598 -- this is an erroneous case, and it may happen that we are lucky and an
599 -- underaligned address turns out to be OK after all.
601 --------------------------------
602 -- Compile_Time_Bad_Alignment --
603 --------------------------------
605 procedure Compile_Time_Bad_Alignment
is
607 if Address_Clause_Overlay_Warnings
then
609 ("?o?specified address for& may be inconsistent with alignment",
612 ("\?o?program execution may be erroneous (RM 13.3(27))",
614 Set_Address_Warning_Posted
(AC
);
616 end Compile_Time_Bad_Alignment
;
618 -- Start of processing for Apply_Address_Clause_Check
621 -- See if alignment check needed. Note that we never need a check if the
622 -- maximum alignment is one, since the check will always succeed.
624 -- Note: we do not check for checks suppressed here, since that check
625 -- was done in Sem_Ch13 when the address clause was processed. We are
626 -- only called if checks were not suppressed. The reason for this is
627 -- that we have to delay the call to Apply_Alignment_Check till freeze
628 -- time (so that all types etc are elaborated), but we have to check
629 -- the status of check suppressing at the point of the address clause.
632 or else not Check_Address_Alignment
(AC
)
633 or else Maximum_Alignment
= 1
638 -- Obtain expression from address clause
640 Expr
:= Expression
(AC
);
642 -- The following loop digs for the real expression to use in the check
645 -- For constant, get constant expression
647 if Is_Entity_Name
(Expr
)
648 and then Ekind
(Entity
(Expr
)) = E_Constant
650 Expr
:= Constant_Value
(Entity
(Expr
));
652 -- For unchecked conversion, get result to convert
654 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
655 Expr
:= Expression
(Expr
);
657 -- For (common case) of To_Address call, get argument
659 elsif Nkind
(Expr
) = N_Function_Call
660 and then Is_Entity_Name
(Name
(Expr
))
661 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
663 Expr
:= First
(Parameter_Associations
(Expr
));
665 if Nkind
(Expr
) = N_Parameter_Association
then
666 Expr
:= Explicit_Actual_Parameter
(Expr
);
669 -- We finally have the real expression
676 -- See if we know that Expr has a bad alignment at compile time
678 if Compile_Time_Known_Value
(Expr
)
679 and then (Known_Alignment
(E
) or else Known_Alignment
(Typ
))
682 AL
: Uint
:= Alignment
(Typ
);
685 -- The object alignment might be more restrictive than the
688 if Known_Alignment
(E
) then
692 if Expr_Value
(Expr
) mod AL
/= 0 then
693 Compile_Time_Bad_Alignment
;
699 -- If the expression has the form X'Address, then we can find out if
700 -- the object X has an alignment that is compatible with the object E.
701 -- If it hasn't or we don't know, we defer issuing the warning until
702 -- the end of the compilation to take into account back end annotations.
704 elsif Nkind
(Expr
) = N_Attribute_Reference
705 and then Attribute_Name
(Expr
) = Name_Address
706 and then Has_Compatible_Alignment
(E
, Prefix
(Expr
)) = Known_Compatible
711 -- Here we do not know if the value is acceptable. Strictly we don't
712 -- have to do anything, since if the alignment is bad, we have an
713 -- erroneous program. However we are allowed to check for erroneous
714 -- conditions and we decide to do this by default if the check is not
717 -- However, don't do the check if elaboration code is unwanted
719 if Restriction_Active
(No_Elaboration_Code
) then
722 -- Generate a check to raise PE if alignment may be inappropriate
725 -- If the original expression is a non-static constant, use the
726 -- name of the constant itself rather than duplicating its
727 -- defining expression, which was extracted above.
729 -- Note: Expr is empty if the address-clause is applied to in-mode
730 -- actuals (allowed by 13.1(22)).
732 if not Present
(Expr
)
734 (Is_Entity_Name
(Expression
(AC
))
735 and then Ekind
(Entity
(Expression
(AC
))) = E_Constant
736 and then Nkind
(Parent
(Entity
(Expression
(AC
))))
737 = N_Object_Declaration
)
739 Expr
:= New_Copy_Tree
(Expression
(AC
));
741 Remove_Side_Effects
(Expr
);
744 if No
(Actions
(N
)) then
745 Set_Actions
(N
, New_List
);
748 Prepend_To
(Actions
(N
),
749 Make_Raise_Program_Error
(Loc
,
756 (RTE
(RE_Integer_Address
), Expr
),
758 Make_Attribute_Reference
(Loc
,
759 Prefix
=> New_Occurrence_Of
(E
, Loc
),
760 Attribute_Name
=> Name_Alignment
)),
761 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
762 Reason
=> PE_Misaligned_Address_Value
));
763 Analyze
(First
(Actions
(N
)), Suppress
=> All_Checks
);
765 -- If the address clause generates an alignment check and we are
766 -- in ZPF or some restricted run-time, add a warning to explain
767 -- the propagation warning that is generated by the check.
769 if Nkind
(First
(Actions
(N
))) = N_Raise_Program_Error
770 and then not Warnings_Off
(E
)
771 and then Restriction_Active
(No_Exception_Propagation
)
774 ("address value may be incompatible with alignment of object?",
782 -- If we have some missing run time component in configurable run time
783 -- mode then just skip the check (it is not required in any case).
785 when RE_Not_Available
=>
787 end Apply_Address_Clause_Check
;
789 -------------------------------------
790 -- Apply_Arithmetic_Overflow_Check --
791 -------------------------------------
793 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
795 -- Use old routine in almost all cases (the only case we are treating
796 -- specially is the case of a signed integer arithmetic op with the
797 -- overflow checking mode set to MINIMIZED or ELIMINATED).
799 if Overflow_Check_Mode
= Strict
800 or else not Is_Signed_Integer_Arithmetic_Op
(N
)
802 Apply_Arithmetic_Overflow_Strict
(N
);
804 -- Otherwise use the new routine for the case of a signed integer
805 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
806 -- mode is MINIMIZED or ELIMINATED.
809 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
811 end Apply_Arithmetic_Overflow_Check
;
813 --------------------------------------
814 -- Apply_Arithmetic_Overflow_Strict --
815 --------------------------------------
817 -- This routine is called only if the type is an integer type, and a
818 -- software arithmetic overflow check may be needed for op (add, subtract,
819 -- or multiply). This check is performed only if Software_Overflow_Checking
820 -- is enabled and Do_Overflow_Check is set. In this case we expand the
821 -- operation into a more complex sequence of tests that ensures that
822 -- overflow is properly caught.
824 -- This is used in CHECKED modes. It is identical to the code for this
825 -- cases before the big overflow earthquake, thus ensuring that in this
826 -- modes we have compatible behavior (and reliability) to what was there
827 -- before. It is also called for types other than signed integers, and if
828 -- the Do_Overflow_Check flag is off.
830 -- Note: we also call this routine if we decide in the MINIMIZED case
831 -- to give up and just generate an overflow check without any fuss.
833 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
) is
834 Loc
: constant Source_Ptr
:= Sloc
(N
);
835 Typ
: constant Entity_Id
:= Etype
(N
);
836 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
839 -- Nothing to do if Do_Overflow_Check not set or overflow checks
842 if not Do_Overflow_Check
(N
) then
846 -- An interesting special case. If the arithmetic operation appears as
847 -- the operand of a type conversion:
851 -- and all the following conditions apply:
853 -- arithmetic operation is for a signed integer type
854 -- target type type1 is a static integer subtype
855 -- range of x and y are both included in the range of type1
856 -- range of x op y is included in the range of type1
857 -- size of type1 is at least twice the result size of op
859 -- then we don't do an overflow check in any case, instead we transform
860 -- the operation so that we end up with:
862 -- type1 (type1 (x) op type1 (y))
864 -- This avoids intermediate overflow before the conversion. It is
865 -- explicitly permitted by RM 3.5.4(24):
867 -- For the execution of a predefined operation of a signed integer
868 -- type, the implementation need not raise Constraint_Error if the
869 -- result is outside the base range of the type, so long as the
870 -- correct result is produced.
872 -- It's hard to imagine that any programmer counts on the exception
873 -- being raised in this case, and in any case it's wrong coding to
874 -- have this expectation, given the RM permission. Furthermore, other
875 -- Ada compilers do allow such out of range results.
877 -- Note that we do this transformation even if overflow checking is
878 -- off, since this is precisely about giving the "right" result and
879 -- avoiding the need for an overflow check.
881 -- Note: this circuit is partially redundant with respect to the similar
882 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
883 -- with cases that do not come through here. We still need the following
884 -- processing even with the Exp_Ch4 code in place, since we want to be
885 -- sure not to generate the arithmetic overflow check in these cases
886 -- (Exp_Ch4 would have a hard time removing them once generated).
888 if Is_Signed_Integer_Type
(Typ
)
889 and then Nkind
(Parent
(N
)) = N_Type_Conversion
891 Conversion_Optimization
: declare
892 Target_Type
: constant Entity_Id
:=
893 Base_Type
(Entity
(Subtype_Mark
(Parent
(N
))));
907 if Is_Integer_Type
(Target_Type
)
908 and then RM_Size
(Root_Type
(Target_Type
)) >= 2 * RM_Size
(Rtyp
)
910 Tlo
:= Expr_Value
(Type_Low_Bound
(Target_Type
));
911 Thi
:= Expr_Value
(Type_High_Bound
(Target_Type
));
914 (Left_Opnd
(N
), LOK
, Llo
, Lhi
, Assume_Valid
=> True);
916 (Right_Opnd
(N
), ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
919 and then Tlo
<= Llo
and then Lhi
<= Thi
920 and then Tlo
<= Rlo
and then Rhi
<= Thi
922 Determine_Range
(N
, VOK
, Vlo
, Vhi
, Assume_Valid
=> True);
924 if VOK
and then Tlo
<= Vlo
and then Vhi
<= Thi
then
925 Rewrite
(Left_Opnd
(N
),
926 Make_Type_Conversion
(Loc
,
927 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
928 Expression
=> Relocate_Node
(Left_Opnd
(N
))));
930 Rewrite
(Right_Opnd
(N
),
931 Make_Type_Conversion
(Loc
,
932 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
933 Expression
=> Relocate_Node
(Right_Opnd
(N
))));
935 -- Rewrite the conversion operand so that the original
936 -- node is retained, in order to avoid the warning for
937 -- redundant conversions in Resolve_Type_Conversion.
939 Rewrite
(N
, Relocate_Node
(N
));
941 Set_Etype
(N
, Target_Type
);
943 Analyze_And_Resolve
(Left_Opnd
(N
), Target_Type
);
944 Analyze_And_Resolve
(Right_Opnd
(N
), Target_Type
);
946 -- Given that the target type is twice the size of the
947 -- source type, overflow is now impossible, so we can
948 -- safely kill the overflow check and return.
950 Set_Do_Overflow_Check
(N
, False);
955 end Conversion_Optimization
;
958 -- Now see if an overflow check is required
961 Siz
: constant Int
:= UI_To_Int
(Esize
(Rtyp
));
962 Dsiz
: constant Int
:= Siz
* 2;
969 -- Skip check if back end does overflow checks, or the overflow flag
970 -- is not set anyway, or we are not doing code expansion, or the
971 -- parent node is a type conversion whose operand is an arithmetic
972 -- operation on signed integers on which the expander can promote
973 -- later the operands to type Integer (see Expand_N_Type_Conversion).
975 -- Special case CLI target, where arithmetic overflow checks can be
976 -- performed for integer and long_integer
978 if Backend_Overflow_Checks_On_Target
979 or else not Do_Overflow_Check
(N
)
980 or else not Expander_Active
981 or else (Present
(Parent
(N
))
982 and then Nkind
(Parent
(N
)) = N_Type_Conversion
983 and then Integer_Promotion_Possible
(Parent
(N
)))
985 (VM_Target
= CLI_Target
and then Siz
>= Standard_Integer_Size
)
990 -- Otherwise, generate the full general code for front end overflow
991 -- detection, which works by doing arithmetic in a larger type:
997 -- Typ (Checktyp (x) op Checktyp (y));
999 -- where Typ is the type of the original expression, and Checktyp is
1000 -- an integer type of sufficient length to hold the largest possible
1003 -- If the size of check type exceeds the size of Long_Long_Integer,
1004 -- we use a different approach, expanding to:
1006 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
1008 -- where xxx is Add, Multiply or Subtract as appropriate
1010 -- Find check type if one exists
1012 if Dsiz
<= Standard_Integer_Size
then
1013 Ctyp
:= Standard_Integer
;
1015 elsif Dsiz
<= Standard_Long_Long_Integer_Size
then
1016 Ctyp
:= Standard_Long_Long_Integer
;
1018 -- No check type exists, use runtime call
1021 if Nkind
(N
) = N_Op_Add
then
1022 Cent
:= RE_Add_With_Ovflo_Check
;
1024 elsif Nkind
(N
) = N_Op_Multiply
then
1025 Cent
:= RE_Multiply_With_Ovflo_Check
;
1028 pragma Assert
(Nkind
(N
) = N_Op_Subtract
);
1029 Cent
:= RE_Subtract_With_Ovflo_Check
;
1034 Make_Function_Call
(Loc
,
1035 Name
=> New_Reference_To
(RTE
(Cent
), Loc
),
1036 Parameter_Associations
=> New_List
(
1037 OK_Convert_To
(RTE
(RE_Integer_64
), Left_Opnd
(N
)),
1038 OK_Convert_To
(RTE
(RE_Integer_64
), Right_Opnd
(N
))))));
1040 Analyze_And_Resolve
(N
, Typ
);
1044 -- If we fall through, we have the case where we do the arithmetic
1045 -- in the next higher type and get the check by conversion. In these
1046 -- cases Ctyp is set to the type to be used as the check type.
1048 Opnod
:= Relocate_Node
(N
);
1050 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
1053 Set_Etype
(Opnd
, Ctyp
);
1054 Set_Analyzed
(Opnd
, True);
1055 Set_Left_Opnd
(Opnod
, Opnd
);
1057 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
1060 Set_Etype
(Opnd
, Ctyp
);
1061 Set_Analyzed
(Opnd
, True);
1062 Set_Right_Opnd
(Opnod
, Opnd
);
1064 -- The type of the operation changes to the base type of the check
1065 -- type, and we reset the overflow check indication, since clearly no
1066 -- overflow is possible now that we are using a double length type.
1067 -- We also set the Analyzed flag to avoid a recursive attempt to
1070 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
1071 Set_Do_Overflow_Check
(Opnod
, False);
1072 Set_Analyzed
(Opnod
, True);
1074 -- Now build the outer conversion
1076 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
1078 Set_Etype
(Opnd
, Typ
);
1080 -- In the discrete type case, we directly generate the range check
1081 -- for the outer operand. This range check will implement the
1082 -- required overflow check.
1084 if Is_Discrete_Type
(Typ
) then
1086 Generate_Range_Check
1087 (Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
1089 -- For other types, we enable overflow checking on the conversion,
1090 -- after setting the node as analyzed to prevent recursive attempts
1091 -- to expand the conversion node.
1094 Set_Analyzed
(Opnd
, True);
1095 Enable_Overflow_Check
(Opnd
);
1100 when RE_Not_Available
=>
1103 end Apply_Arithmetic_Overflow_Strict
;
1105 ----------------------------------------------------
1106 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1107 ----------------------------------------------------
1109 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
) is
1110 pragma Assert
(Is_Signed_Integer_Arithmetic_Op
(Op
));
1112 Loc
: constant Source_Ptr
:= Sloc
(Op
);
1113 P
: constant Node_Id
:= Parent
(Op
);
1115 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
1116 -- Operands and results are of this type when we convert
1118 Result_Type
: constant Entity_Id
:= Etype
(Op
);
1119 -- Original result type
1121 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1122 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
1125 -- Ranges of values for result
1128 -- Nothing to do if our parent is one of the following:
1130 -- Another signed integer arithmetic op
1131 -- A membership operation
1132 -- A comparison operation
1134 -- In all these cases, we will process at the higher level (and then
1135 -- this node will be processed during the downwards recursion that
1136 -- is part of the processing in Minimize_Eliminate_Overflows).
1138 if Is_Signed_Integer_Arithmetic_Op
(P
)
1139 or else Nkind
(P
) in N_Membership_Test
1140 or else Nkind
(P
) in N_Op_Compare
1142 -- This is also true for an alternative in a case expression
1144 or else Nkind
(P
) = N_Case_Expression_Alternative
1146 -- This is also true for a range operand in a membership test
1148 or else (Nkind
(P
) = N_Range
1149 and then Nkind
(Parent
(P
)) in N_Membership_Test
)
1154 -- Otherwise, we have a top level arithmetic operation node, and this
1155 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1156 -- modes. This is the case where we tell the machinery not to move into
1157 -- Bignum mode at this top level (of course the top level operation
1158 -- will still be in Bignum mode if either of its operands are of type
1161 Minimize_Eliminate_Overflows
(Op
, Lo
, Hi
, Top_Level
=> True);
1163 -- That call may but does not necessarily change the result type of Op.
1164 -- It is the job of this routine to undo such changes, so that at the
1165 -- top level, we have the proper type. This "undoing" is a point at
1166 -- which a final overflow check may be applied.
1168 -- If the result type was not fiddled we are all set. We go to base
1169 -- types here because things may have been rewritten to generate the
1170 -- base type of the operand types.
1172 if Base_Type
(Etype
(Op
)) = Base_Type
(Result_Type
) then
1177 elsif Is_RTE
(Etype
(Op
), RE_Bignum
) then
1179 -- We need a sequence that looks like:
1181 -- Rnn : Result_Type;
1184 -- M : Mark_Id := SS_Mark;
1186 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1190 -- This block is inserted (using Insert_Actions), and then the node
1191 -- is replaced with a reference to Rnn.
1193 -- A special case arises if our parent is a conversion node. In this
1194 -- case no point in generating a conversion to Result_Type, we will
1195 -- let the parent handle this. Note that this special case is not
1196 -- just about optimization. Consider
1200 -- X := Long_Long_Integer'Base (A * (B ** C));
1202 -- Now the product may fit in Long_Long_Integer but not in Integer.
1203 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1204 -- overflow exception for this intermediate value.
1207 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
1208 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R', Op
);
1214 RHS
:= Convert_From_Bignum
(Op
);
1216 if Nkind
(P
) /= N_Type_Conversion
then
1217 Convert_To_And_Rewrite
(Result_Type
, RHS
);
1218 Rtype
:= Result_Type
;
1220 -- Interesting question, do we need a check on that conversion
1221 -- operation. Answer, not if we know the result is in range.
1222 -- At the moment we are not taking advantage of this. To be
1223 -- looked at later ???
1230 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
1231 Make_Assignment_Statement
(Loc
,
1232 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
1233 Expression
=> RHS
));
1235 Insert_Actions
(Op
, New_List
(
1236 Make_Object_Declaration
(Loc
,
1237 Defining_Identifier
=> Rnn
,
1238 Object_Definition
=> New_Occurrence_Of
(Rtype
, Loc
)),
1241 Rewrite
(Op
, New_Occurrence_Of
(Rnn
, Loc
));
1242 Analyze_And_Resolve
(Op
);
1245 -- Here we know the result is Long_Long_Integer'Base, of that it has
1246 -- been rewritten because the parent operation is a conversion. See
1247 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1251 (Etype
(Op
) = LLIB
or else Nkind
(Parent
(Op
)) = N_Type_Conversion
);
1253 -- All we need to do here is to convert the result to the proper
1254 -- result type. As explained above for the Bignum case, we can
1255 -- omit this if our parent is a type conversion.
1257 if Nkind
(P
) /= N_Type_Conversion
then
1258 Convert_To_And_Rewrite
(Result_Type
, Op
);
1261 Analyze_And_Resolve
(Op
);
1263 end Apply_Arithmetic_Overflow_Minimized_Eliminated
;
1265 ----------------------------
1266 -- Apply_Constraint_Check --
1267 ----------------------------
1269 procedure Apply_Constraint_Check
1272 No_Sliding
: Boolean := False)
1274 Desig_Typ
: Entity_Id
;
1277 -- No checks inside a generic (check the instantiations)
1279 if Inside_A_Generic
then
1283 -- Apply required constraint checks
1285 if Is_Scalar_Type
(Typ
) then
1286 Apply_Scalar_Range_Check
(N
, Typ
);
1288 elsif Is_Array_Type
(Typ
) then
1290 -- A useful optimization: an aggregate with only an others clause
1291 -- always has the right bounds.
1293 if Nkind
(N
) = N_Aggregate
1294 and then No
(Expressions
(N
))
1296 (First
(Choices
(First
(Component_Associations
(N
)))))
1302 if Is_Constrained
(Typ
) then
1303 Apply_Length_Check
(N
, Typ
);
1306 Apply_Range_Check
(N
, Typ
);
1309 Apply_Range_Check
(N
, Typ
);
1312 elsif (Is_Record_Type
(Typ
) or else Is_Private_Type
(Typ
))
1313 and then Has_Discriminants
(Base_Type
(Typ
))
1314 and then Is_Constrained
(Typ
)
1316 Apply_Discriminant_Check
(N
, Typ
);
1318 elsif Is_Access_Type
(Typ
) then
1320 Desig_Typ
:= Designated_Type
(Typ
);
1322 -- No checks necessary if expression statically null
1324 if Known_Null
(N
) then
1325 if Can_Never_Be_Null
(Typ
) then
1326 Install_Null_Excluding_Check
(N
);
1329 -- No sliding possible on access to arrays
1331 elsif Is_Array_Type
(Desig_Typ
) then
1332 if Is_Constrained
(Desig_Typ
) then
1333 Apply_Length_Check
(N
, Typ
);
1336 Apply_Range_Check
(N
, Typ
);
1338 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
1339 and then Is_Constrained
(Desig_Typ
)
1341 Apply_Discriminant_Check
(N
, Typ
);
1344 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1345 -- this check if the constraint node is illegal, as shown by having
1346 -- an error posted. This additional guard prevents cascaded errors
1347 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1349 if Can_Never_Be_Null
(Typ
)
1350 and then not Can_Never_Be_Null
(Etype
(N
))
1351 and then not Error_Posted
(N
)
1353 Install_Null_Excluding_Check
(N
);
1356 end Apply_Constraint_Check
;
1358 ------------------------------
1359 -- Apply_Discriminant_Check --
1360 ------------------------------
1362 procedure Apply_Discriminant_Check
1365 Lhs
: Node_Id
:= Empty
)
1367 Loc
: constant Source_Ptr
:= Sloc
(N
);
1368 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1369 S_Typ
: Entity_Id
:= Etype
(N
);
1373 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean;
1374 -- A heap object with an indefinite subtype is constrained by its
1375 -- initial value, and assigning to it requires a constraint_check.
1376 -- The target may be an explicit dereference, or a renaming of one.
1378 function Is_Aliased_Unconstrained_Component
return Boolean;
1379 -- It is possible for an aliased component to have a nominal
1380 -- unconstrained subtype (through instantiation). If this is a
1381 -- discriminated component assigned in the expansion of an aggregate
1382 -- in an initialization, the check must be suppressed. This unusual
1383 -- situation requires a predicate of its own.
1385 ----------------------------------
1386 -- Denotes_Explicit_Dereference --
1387 ----------------------------------
1389 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean is
1392 Nkind
(Obj
) = N_Explicit_Dereference
1394 (Is_Entity_Name
(Obj
)
1395 and then Present
(Renamed_Object
(Entity
(Obj
)))
1396 and then Nkind
(Renamed_Object
(Entity
(Obj
))) =
1397 N_Explicit_Dereference
);
1398 end Denotes_Explicit_Dereference
;
1400 ----------------------------------------
1401 -- Is_Aliased_Unconstrained_Component --
1402 ----------------------------------------
1404 function Is_Aliased_Unconstrained_Component
return Boolean is
1409 if Nkind
(Lhs
) /= N_Selected_Component
then
1412 Comp
:= Entity
(Selector_Name
(Lhs
));
1413 Pref
:= Prefix
(Lhs
);
1416 if Ekind
(Comp
) /= E_Component
1417 or else not Is_Aliased
(Comp
)
1422 return not Comes_From_Source
(Pref
)
1423 and then In_Instance
1424 and then not Is_Constrained
(Etype
(Comp
));
1425 end Is_Aliased_Unconstrained_Component
;
1427 -- Start of processing for Apply_Discriminant_Check
1431 T_Typ
:= Designated_Type
(Typ
);
1436 -- Nothing to do if discriminant checks are suppressed or else no code
1437 -- is to be generated
1439 if not Expander_Active
1440 or else Discriminant_Checks_Suppressed
(T_Typ
)
1445 -- No discriminant checks necessary for an access when expression is
1446 -- statically Null. This is not only an optimization, it is fundamental
1447 -- because otherwise discriminant checks may be generated in init procs
1448 -- for types containing an access to a not-yet-frozen record, causing a
1449 -- deadly forward reference.
1451 -- Also, if the expression is of an access type whose designated type is
1452 -- incomplete, then the access value must be null and we suppress the
1455 if Known_Null
(N
) then
1458 elsif Is_Access_Type
(S_Typ
) then
1459 S_Typ
:= Designated_Type
(S_Typ
);
1461 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1466 -- If an assignment target is present, then we need to generate the
1467 -- actual subtype if the target is a parameter or aliased object with
1468 -- an unconstrained nominal subtype.
1470 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1471 -- subtype to the parameter and dereference cases, since other aliased
1472 -- objects are unconstrained (unless the nominal subtype is explicitly
1476 and then (Present
(Param_Entity
(Lhs
))
1477 or else (Ada_Version
< Ada_2005
1478 and then not Is_Constrained
(T_Typ
)
1479 and then Is_Aliased_View
(Lhs
)
1480 and then not Is_Aliased_Unconstrained_Component
)
1481 or else (Ada_Version
>= Ada_2005
1482 and then not Is_Constrained
(T_Typ
)
1483 and then Denotes_Explicit_Dereference
(Lhs
)
1484 and then Nkind
(Original_Node
(Lhs
)) /=
1487 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1490 -- Nothing to do if the type is unconstrained (this is the case where
1491 -- the actual subtype in the RM sense of N is unconstrained and no check
1494 if not Is_Constrained
(T_Typ
) then
1497 -- Ada 2005: nothing to do if the type is one for which there is a
1498 -- partial view that is constrained.
1500 elsif Ada_Version
>= Ada_2005
1501 and then Object_Type_Has_Constrained_Partial_View
1502 (Typ
=> Base_Type
(T_Typ
),
1503 Scop
=> Current_Scope
)
1508 -- Nothing to do if the type is an Unchecked_Union
1510 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
1514 -- Suppress checks if the subtypes are the same. The check must be
1515 -- preserved in an assignment to a formal, because the constraint is
1516 -- given by the actual.
1518 if Nkind
(Original_Node
(N
)) /= N_Allocator
1520 or else not Is_Entity_Name
(Lhs
)
1521 or else No
(Param_Entity
(Lhs
)))
1524 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1525 and then not Is_Aliased_View
(Lhs
)
1530 -- We can also eliminate checks on allocators with a subtype mark that
1531 -- coincides with the context type. The context type may be a subtype
1532 -- without a constraint (common case, a generic actual).
1534 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1535 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1538 Alloc_Typ
: constant Entity_Id
:=
1539 Entity
(Expression
(Original_Node
(N
)));
1542 if Alloc_Typ
= T_Typ
1543 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1544 and then Is_Entity_Name
(
1545 Subtype_Indication
(Parent
(T_Typ
)))
1546 and then Alloc_Typ
= Base_Type
(T_Typ
))
1554 -- See if we have a case where the types are both constrained, and all
1555 -- the constraints are constants. In this case, we can do the check
1556 -- successfully at compile time.
1558 -- We skip this check for the case where the node is rewritten as
1559 -- an allocator, because it already carries the context subtype,
1560 -- and extracting the discriminants from the aggregate is messy.
1562 if Is_Constrained
(S_Typ
)
1563 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1573 -- S_Typ may not have discriminants in the case where it is a
1574 -- private type completed by a default discriminated type. In that
1575 -- case, we need to get the constraints from the underlying type.
1576 -- If the underlying type is unconstrained (i.e. has no default
1577 -- discriminants) no check is needed.
1579 if Has_Discriminants
(S_Typ
) then
1580 Discr
:= First_Discriminant
(S_Typ
);
1581 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1584 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1587 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1593 -- A further optimization: if T_Typ is derived from S_Typ
1594 -- without imposing a constraint, no check is needed.
1596 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1597 N_Full_Type_Declaration
1600 Type_Def
: constant Node_Id
:=
1601 Type_Definition
(Original_Node
(Parent
(T_Typ
)));
1603 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1604 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1605 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1613 -- Constraint may appear in full view of type
1615 if Ekind
(T_Typ
) = E_Private_Subtype
1616 and then Present
(Full_View
(T_Typ
))
1619 First_Elmt
(Discriminant_Constraint
(Full_View
(T_Typ
)));
1622 First_Elmt
(Discriminant_Constraint
(T_Typ
));
1625 while Present
(Discr
) loop
1626 ItemS
:= Node
(DconS
);
1627 ItemT
:= Node
(DconT
);
1629 -- For a discriminated component type constrained by the
1630 -- current instance of an enclosing type, there is no
1631 -- applicable discriminant check.
1633 if Nkind
(ItemT
) = N_Attribute_Reference
1634 and then Is_Access_Type
(Etype
(ItemT
))
1635 and then Is_Entity_Name
(Prefix
(ItemT
))
1636 and then Is_Type
(Entity
(Prefix
(ItemT
)))
1641 -- If the expressions for the discriminants are identical
1642 -- and it is side-effect free (for now just an entity),
1643 -- this may be a shared constraint, e.g. from a subtype
1644 -- without a constraint introduced as a generic actual.
1645 -- Examine other discriminants if any.
1648 and then Is_Entity_Name
(ItemS
)
1652 elsif not Is_OK_Static_Expression
(ItemS
)
1653 or else not Is_OK_Static_Expression
(ItemT
)
1657 elsif Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1658 if Do_Access
then -- needs run-time check.
1661 Apply_Compile_Time_Constraint_Error
1662 (N
, "incorrect value for discriminant&??",
1663 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1670 Next_Discriminant
(Discr
);
1679 -- Here we need a discriminant check. First build the expression
1680 -- for the comparisons of the discriminants:
1682 -- (n.disc1 /= typ.disc1) or else
1683 -- (n.disc2 /= typ.disc2) or else
1685 -- (n.discn /= typ.discn)
1687 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1689 -- If Lhs is set and is a parameter, then the condition is guarded by:
1690 -- lhs'constrained and then (condition built above)
1692 if Present
(Param_Entity
(Lhs
)) then
1696 Make_Attribute_Reference
(Loc
,
1697 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1698 Attribute_Name
=> Name_Constrained
),
1699 Right_Opnd
=> Cond
);
1703 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1707 Make_Raise_Constraint_Error
(Loc
,
1709 Reason
=> CE_Discriminant_Check_Failed
));
1710 end Apply_Discriminant_Check
;
1712 -------------------------
1713 -- Apply_Divide_Checks --
1714 -------------------------
1716 procedure Apply_Divide_Checks
(N
: Node_Id
) is
1717 Loc
: constant Source_Ptr
:= Sloc
(N
);
1718 Typ
: constant Entity_Id
:= Etype
(N
);
1719 Left
: constant Node_Id
:= Left_Opnd
(N
);
1720 Right
: constant Node_Id
:= Right_Opnd
(N
);
1722 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1723 -- Current overflow checking mode
1733 pragma Warnings
(Off
, Lhi
);
1734 -- Don't actually use this value
1737 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1738 -- operating on signed integer types, then the only thing this routine
1739 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1740 -- procedure will (possibly later on during recursive downward calls),
1741 -- ensure that any needed overflow/division checks are properly applied.
1743 if Mode
in Minimized_Or_Eliminated
1744 and then Is_Signed_Integer_Type
(Typ
)
1746 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
1750 -- Proceed here in SUPPRESSED or CHECKED modes
1753 and then not Backend_Divide_Checks_On_Target
1754 and then Check_Needed
(Right
, Division_Check
)
1756 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
1758 -- Deal with division check
1760 if Do_Division_Check
(N
)
1761 and then not Division_Checks_Suppressed
(Typ
)
1763 Apply_Division_Check
(N
, Rlo
, Rhi
, ROK
);
1766 -- Deal with overflow check
1768 if Do_Overflow_Check
(N
)
1769 and then not Overflow_Checks_Suppressed
(Etype
(N
))
1772 -- Test for extremely annoying case of xxx'First divided by -1
1773 -- for division of signed integer types (only overflow case).
1775 if Nkind
(N
) = N_Op_Divide
1776 and then Is_Signed_Integer_Type
(Typ
)
1778 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
1779 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1781 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1783 ((not LOK
) or else (Llo
= LLB
))
1786 Make_Raise_Constraint_Error
(Loc
,
1792 Duplicate_Subexpr_Move_Checks
(Left
),
1793 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1797 Left_Opnd
=> Duplicate_Subexpr
(Right
),
1798 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1))),
1800 Reason
=> CE_Overflow_Check_Failed
));
1805 end Apply_Divide_Checks
;
1807 --------------------------
1808 -- Apply_Division_Check --
1809 --------------------------
1811 procedure Apply_Division_Check
1817 pragma Assert
(Do_Division_Check
(N
));
1819 Loc
: constant Source_Ptr
:= Sloc
(N
);
1820 Right
: constant Node_Id
:= Right_Opnd
(N
);
1824 and then not Backend_Divide_Checks_On_Target
1825 and then Check_Needed
(Right
, Division_Check
)
1827 -- See if division by zero possible, and if so generate test. This
1828 -- part of the test is not controlled by the -gnato switch, since
1829 -- it is a Division_Check and not an Overflow_Check.
1831 if Do_Division_Check
(N
) then
1832 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1834 Make_Raise_Constraint_Error
(Loc
,
1837 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1838 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1839 Reason
=> CE_Divide_By_Zero
));
1843 end Apply_Division_Check
;
1845 ----------------------------------
1846 -- Apply_Float_Conversion_Check --
1847 ----------------------------------
1849 -- Let F and I be the source and target types of the conversion. The RM
1850 -- specifies that a floating-point value X is rounded to the nearest
1851 -- integer, with halfway cases being rounded away from zero. The rounded
1852 -- value of X is checked against I'Range.
1854 -- The catch in the above paragraph is that there is no good way to know
1855 -- whether the round-to-integer operation resulted in overflow. A remedy is
1856 -- to perform a range check in the floating-point domain instead, however:
1858 -- (1) The bounds may not be known at compile time
1859 -- (2) The check must take into account rounding or truncation.
1860 -- (3) The range of type I may not be exactly representable in F.
1861 -- (4) For the rounding case, The end-points I'First - 0.5 and
1862 -- I'Last + 0.5 may or may not be in range, depending on the
1863 -- sign of I'First and I'Last.
1864 -- (5) X may be a NaN, which will fail any comparison
1866 -- The following steps correctly convert X with rounding:
1868 -- (1) If either I'First or I'Last is not known at compile time, use
1869 -- I'Base instead of I in the next three steps and perform a
1870 -- regular range check against I'Range after conversion.
1871 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1872 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1873 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1874 -- In other words, take one of the closest floating-point numbers
1875 -- (which is an integer value) to I'First, and see if it is in
1877 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1878 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1879 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1880 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1881 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1883 -- For the truncating case, replace steps (2) and (3) as follows:
1884 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1885 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1887 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1888 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1891 procedure Apply_Float_Conversion_Check
1893 Target_Typ
: Entity_Id
)
1895 LB
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1896 HB
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1897 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1898 Expr_Type
: constant Entity_Id
:= Base_Type
(Etype
(Ck_Node
));
1899 Target_Base
: constant Entity_Id
:=
1900 Implementation_Base_Type
(Target_Typ
);
1902 Par
: constant Node_Id
:= Parent
(Ck_Node
);
1903 pragma Assert
(Nkind
(Par
) = N_Type_Conversion
);
1904 -- Parent of check node, must be a type conversion
1906 Truncate
: constant Boolean := Float_Truncate
(Par
);
1907 Max_Bound
: constant Uint
:=
1909 (Machine_Radix_Value
(Expr_Type
),
1910 Machine_Mantissa_Value
(Expr_Type
) - 1) - 1;
1912 -- Largest bound, so bound plus or minus half is a machine number of F
1914 Ifirst
, Ilast
: Uint
;
1915 -- Bounds of integer type
1918 -- Bounds to check in floating-point domain
1920 Lo_OK
, Hi_OK
: Boolean;
1921 -- True iff Lo resp. Hi belongs to I'Range
1923 Lo_Chk
, Hi_Chk
: Node_Id
;
1924 -- Expressions that are False iff check fails
1926 Reason
: RT_Exception_Code
;
1929 -- We do not need checks if we are not generating code (i.e. the full
1930 -- expander is not active). In SPARK mode, we specifically don't want
1931 -- the frontend to expand these checks, which are dealt with directly
1932 -- in the formal verification backend.
1934 if not Expander_Active
then
1938 if not Compile_Time_Known_Value
(LB
)
1939 or not Compile_Time_Known_Value
(HB
)
1942 -- First check that the value falls in the range of the base type,
1943 -- to prevent overflow during conversion and then perform a
1944 -- regular range check against the (dynamic) bounds.
1946 pragma Assert
(Target_Base
/= Target_Typ
);
1948 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Par
);
1951 Apply_Float_Conversion_Check
(Ck_Node
, Target_Base
);
1952 Set_Etype
(Temp
, Target_Base
);
1954 Insert_Action
(Parent
(Par
),
1955 Make_Object_Declaration
(Loc
,
1956 Defining_Identifier
=> Temp
,
1957 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
),
1958 Expression
=> New_Copy_Tree
(Par
)),
1959 Suppress
=> All_Checks
);
1962 Make_Raise_Constraint_Error
(Loc
,
1965 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
1966 Right_Opnd
=> New_Occurrence_Of
(Target_Typ
, Loc
)),
1967 Reason
=> CE_Range_Check_Failed
));
1968 Rewrite
(Par
, New_Occurrence_Of
(Temp
, Loc
));
1974 -- Get the (static) bounds of the target type
1976 Ifirst
:= Expr_Value
(LB
);
1977 Ilast
:= Expr_Value
(HB
);
1979 -- A simple optimization: if the expression is a universal literal,
1980 -- we can do the comparison with the bounds and the conversion to
1981 -- an integer type statically. The range checks are unchanged.
1983 if Nkind
(Ck_Node
) = N_Real_Literal
1984 and then Etype
(Ck_Node
) = Universal_Real
1985 and then Is_Integer_Type
(Target_Typ
)
1986 and then Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
1989 Int_Val
: constant Uint
:= UR_To_Uint
(Realval
(Ck_Node
));
1992 if Int_Val
<= Ilast
and then Int_Val
>= Ifirst
then
1994 -- Conversion is safe
1996 Rewrite
(Parent
(Ck_Node
),
1997 Make_Integer_Literal
(Loc
, UI_To_Int
(Int_Val
)));
1998 Analyze_And_Resolve
(Parent
(Ck_Node
), Target_Typ
);
2004 -- Check against lower bound
2006 if Truncate
and then Ifirst
> 0 then
2007 Lo
:= Pred
(Expr_Type
, UR_From_Uint
(Ifirst
));
2011 Lo
:= Succ
(Expr_Type
, UR_From_Uint
(Ifirst
- 1));
2014 elsif abs (Ifirst
) < Max_Bound
then
2015 Lo
:= UR_From_Uint
(Ifirst
) - Ureal_Half
;
2016 Lo_OK
:= (Ifirst
> 0);
2019 Lo
:= Machine
(Expr_Type
, UR_From_Uint
(Ifirst
), Round_Even
, Ck_Node
);
2020 Lo_OK
:= (Lo
>= UR_From_Uint
(Ifirst
));
2025 -- Lo_Chk := (X >= Lo)
2027 Lo_Chk
:= Make_Op_Ge
(Loc
,
2028 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2029 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2032 -- Lo_Chk := (X > Lo)
2034 Lo_Chk
:= Make_Op_Gt
(Loc
,
2035 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2036 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2039 -- Check against higher bound
2041 if Truncate
and then Ilast
< 0 then
2042 Hi
:= Succ
(Expr_Type
, UR_From_Uint
(Ilast
));
2046 Hi
:= Pred
(Expr_Type
, UR_From_Uint
(Ilast
+ 1));
2049 elsif abs (Ilast
) < Max_Bound
then
2050 Hi
:= UR_From_Uint
(Ilast
) + Ureal_Half
;
2051 Hi_OK
:= (Ilast
< 0);
2053 Hi
:= Machine
(Expr_Type
, UR_From_Uint
(Ilast
), Round_Even
, Ck_Node
);
2054 Hi_OK
:= (Hi
<= UR_From_Uint
(Ilast
));
2059 -- Hi_Chk := (X <= Hi)
2061 Hi_Chk
:= Make_Op_Le
(Loc
,
2062 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2063 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2066 -- Hi_Chk := (X < Hi)
2068 Hi_Chk
:= Make_Op_Lt
(Loc
,
2069 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2070 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2073 -- If the bounds of the target type are the same as those of the base
2074 -- type, the check is an overflow check as a range check is not
2075 -- performed in these cases.
2077 if Expr_Value
(Type_Low_Bound
(Target_Base
)) = Ifirst
2078 and then Expr_Value
(Type_High_Bound
(Target_Base
)) = Ilast
2080 Reason
:= CE_Overflow_Check_Failed
;
2082 Reason
:= CE_Range_Check_Failed
;
2085 -- Raise CE if either conditions does not hold
2087 Insert_Action
(Ck_Node
,
2088 Make_Raise_Constraint_Error
(Loc
,
2089 Condition
=> Make_Op_Not
(Loc
, Make_And_Then
(Loc
, Lo_Chk
, Hi_Chk
)),
2091 end Apply_Float_Conversion_Check
;
2093 ------------------------
2094 -- Apply_Length_Check --
2095 ------------------------
2097 procedure Apply_Length_Check
2099 Target_Typ
: Entity_Id
;
2100 Source_Typ
: Entity_Id
:= Empty
)
2103 Apply_Selected_Length_Checks
2104 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2105 end Apply_Length_Check
;
2107 -------------------------------------
2108 -- Apply_Parameter_Aliasing_Checks --
2109 -------------------------------------
2111 procedure Apply_Parameter_Aliasing_Checks
2115 Loc
: constant Source_Ptr
:= Sloc
(Call
);
2117 function May_Cause_Aliasing
2118 (Formal_1
: Entity_Id
;
2119 Formal_2
: Entity_Id
) return Boolean;
2120 -- Determine whether two formal parameters can alias each other
2121 -- depending on their modes.
2123 function Original_Actual
(N
: Node_Id
) return Node_Id
;
2124 -- The expander may replace an actual with a temporary for the sake of
2125 -- side effect removal. The temporary may hide a potential aliasing as
2126 -- it does not share the address of the actual. This routine attempts
2127 -- to retrieve the original actual.
2129 procedure Overlap_Check
2130 (Actual_1
: Node_Id
;
2132 Formal_1
: Entity_Id
;
2133 Formal_2
: Entity_Id
;
2134 Check
: in out Node_Id
);
2135 -- Create a check to determine whether Actual_1 overlaps with Actual_2.
2136 -- If detailed exception messages are enabled, the check is augmented to
2137 -- provide information about the names of the corresponding formals. See
2138 -- the body for details. Actual_1 and Actual_2 denote the two actuals to
2139 -- be tested. Formal_1 and Formal_2 denote the corresponding formals.
2140 -- Check contains all and-ed simple tests generated so far or remains
2141 -- unchanged in the case of detailed exception messaged.
2143 ------------------------
2144 -- May_Cause_Aliasing --
2145 ------------------------
2147 function May_Cause_Aliasing
2148 (Formal_1
: Entity_Id
;
2149 Formal_2
: Entity_Id
) return Boolean
2152 -- The following combination cannot lead to aliasing
2154 -- Formal 1 Formal 2
2157 if Ekind
(Formal_1
) = E_In_Parameter
2159 Ekind
(Formal_2
) = E_In_Parameter
2163 -- The following combinations may lead to aliasing
2165 -- Formal 1 Formal 2
2175 end May_Cause_Aliasing
;
2177 ---------------------
2178 -- Original_Actual --
2179 ---------------------
2181 function Original_Actual
(N
: Node_Id
) return Node_Id
is
2183 if Nkind
(N
) = N_Type_Conversion
then
2184 return Expression
(N
);
2186 -- The expander created a temporary to capture the result of a type
2187 -- conversion where the expression is the real actual.
2189 elsif Nkind
(N
) = N_Identifier
2190 and then Present
(Original_Node
(N
))
2191 and then Nkind
(Original_Node
(N
)) = N_Type_Conversion
2193 return Expression
(Original_Node
(N
));
2197 end Original_Actual
;
2203 procedure Overlap_Check
2204 (Actual_1
: Node_Id
;
2206 Formal_1
: Entity_Id
;
2207 Formal_2
: Entity_Id
;
2208 Check
: in out Node_Id
)
2211 ID_Casing
: constant Casing_Type
:=
2212 Identifier_Casing
(Source_Index
(Current_Sem_Unit
));
2216 -- Actual_1'Overlaps_Storage (Actual_2)
2219 Make_Attribute_Reference
(Loc
,
2220 Prefix
=> New_Copy_Tree
(Original_Actual
(Actual_1
)),
2221 Attribute_Name
=> Name_Overlaps_Storage
,
2223 New_List
(New_Copy_Tree
(Original_Actual
(Actual_2
))));
2225 -- Generate the following check when detailed exception messages are
2228 -- if Actual_1'Overlaps_Storage (Actual_2) then
2229 -- raise Program_Error with <detailed message>;
2232 if Exception_Extra_Info
then
2235 -- Do not generate location information for internal calls
2237 if Comes_From_Source
(Call
) then
2238 Store_String_Chars
(Build_Location_String
(Loc
));
2239 Store_String_Char
(' ');
2242 Store_String_Chars
("aliased parameters, actuals for """);
2244 Get_Name_String
(Chars
(Formal_1
));
2245 Set_Casing
(ID_Casing
);
2246 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2248 Store_String_Chars
(""" and """);
2250 Get_Name_String
(Chars
(Formal_2
));
2251 Set_Casing
(ID_Casing
);
2252 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2254 Store_String_Chars
(""" overlap");
2256 Insert_Action
(Call
,
2257 Make_If_Statement
(Loc
,
2259 Then_Statements
=> New_List
(
2260 Make_Raise_Statement
(Loc
,
2262 New_Reference_To
(Standard_Program_Error
, Loc
),
2263 Expression
=> Make_String_Literal
(Loc
, End_String
)))));
2265 -- Create a sequence of overlapping checks by and-ing them all
2275 Right_Opnd
=> Cond
);
2285 Formal_1
: Entity_Id
;
2286 Formal_2
: Entity_Id
;
2288 -- Start of processing for Apply_Parameter_Aliasing_Checks
2293 Actual_1
:= First_Actual
(Call
);
2294 Formal_1
:= First_Formal
(Subp
);
2295 while Present
(Actual_1
) and then Present
(Formal_1
) loop
2297 -- Ensure that the actual is an object that is not passed by value.
2298 -- Elementary types are always passed by value, therefore actuals of
2299 -- such types cannot lead to aliasing.
2301 if Is_Object_Reference
(Original_Actual
(Actual_1
))
2302 and then not Is_Elementary_Type
(Etype
(Original_Actual
(Actual_1
)))
2304 Actual_2
:= Next_Actual
(Actual_1
);
2305 Formal_2
:= Next_Formal
(Formal_1
);
2306 while Present
(Actual_2
) and then Present
(Formal_2
) loop
2308 -- The other actual we are testing against must also denote
2309 -- a non pass-by-value object. Generate the check only when
2310 -- the mode of the two formals may lead to aliasing.
2312 if Is_Object_Reference
(Original_Actual
(Actual_2
))
2314 Is_Elementary_Type
(Etype
(Original_Actual
(Actual_2
)))
2315 and then May_Cause_Aliasing
(Formal_1
, Formal_2
)
2318 (Actual_1
=> Actual_1
,
2319 Actual_2
=> Actual_2
,
2320 Formal_1
=> Formal_1
,
2321 Formal_2
=> Formal_2
,
2325 Next_Actual
(Actual_2
);
2326 Next_Formal
(Formal_2
);
2330 Next_Actual
(Actual_1
);
2331 Next_Formal
(Formal_1
);
2334 -- Place a simple check right before the call
2336 if Present
(Check
) and then not Exception_Extra_Info
then
2337 Insert_Action
(Call
,
2338 Make_Raise_Program_Error
(Loc
,
2340 Reason
=> PE_Aliased_Parameters
));
2342 end Apply_Parameter_Aliasing_Checks
;
2344 -------------------------------------
2345 -- Apply_Parameter_Validity_Checks --
2346 -------------------------------------
2348 procedure Apply_Parameter_Validity_Checks
(Subp
: Entity_Id
) is
2349 Subp_Decl
: Node_Id
;
2351 procedure Add_Validity_Check
2352 (Context
: Entity_Id
;
2354 For_Result
: Boolean := False);
2355 -- Add a single 'Valid[_Scalar] check which verifies the initialization
2356 -- of Context. PPC_Nam denotes the pre or post condition pragma name.
2357 -- Set flag For_Result when to verify the result of a function.
2359 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
);
2360 -- Create a pre or post condition pragma with name PPC_Nam which
2361 -- tests expression Check.
2363 ------------------------
2364 -- Add_Validity_Check --
2365 ------------------------
2367 procedure Add_Validity_Check
2368 (Context
: Entity_Id
;
2370 For_Result
: Boolean := False)
2372 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2373 Typ
: constant Entity_Id
:= Etype
(Context
);
2378 -- Pick the proper version of 'Valid depending on the type of the
2379 -- context. If the context is not eligible for such a check, return.
2381 if Is_Scalar_Type
(Typ
) then
2383 elsif not No_Scalar_Parts
(Typ
) then
2384 Nam
:= Name_Valid_Scalars
;
2389 -- Step 1: Create the expression to verify the validity of the
2392 Check
:= New_Reference_To
(Context
, Loc
);
2394 -- When processing a function result, use 'Result. Generate
2399 Make_Attribute_Reference
(Loc
,
2401 Attribute_Name
=> Name_Result
);
2405 -- Context['Result]'Valid[_Scalars]
2408 Make_Attribute_Reference
(Loc
,
2410 Attribute_Name
=> Nam
);
2412 -- Step 2: Create a pre or post condition pragma
2414 Build_PPC_Pragma
(PPC_Nam
, Check
);
2415 end Add_Validity_Check
;
2417 ----------------------
2418 -- Build_PPC_Pragma --
2419 ----------------------
2421 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
) is
2422 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2429 Pragma_Identifier
=> Make_Identifier
(Loc
, PPC_Nam
),
2430 Pragma_Argument_Associations
=> New_List
(
2431 Make_Pragma_Argument_Association
(Loc
,
2432 Chars
=> Name_Check
,
2433 Expression
=> Check
)));
2435 -- Add a message unless exception messages are suppressed
2437 if not Exception_Locations_Suppressed
then
2438 Append_To
(Pragma_Argument_Associations
(Prag
),
2439 Make_Pragma_Argument_Association
(Loc
,
2440 Chars
=> Name_Message
,
2442 Make_String_Literal
(Loc
,
2443 Strval
=> "failed " & Get_Name_String
(PPC_Nam
) &
2444 " from " & Build_Location_String
(Loc
))));
2447 -- Insert the pragma in the tree
2449 if Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
then
2450 Add_Global_Declaration
(Prag
);
2453 -- PPC pragmas associated with subprogram bodies must be inserted in
2454 -- the declarative part of the body.
2456 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
then
2457 Decls
:= Declarations
(Subp_Decl
);
2461 Set_Declarations
(Subp_Decl
, Decls
);
2464 Prepend_To
(Decls
, Prag
);
2466 -- Ensure the proper visibility of the subprogram body and its
2473 -- For subprogram declarations insert the PPC pragma right after the
2474 -- declarative node.
2477 Insert_After_And_Analyze
(Subp_Decl
, Prag
);
2479 end Build_PPC_Pragma
;
2484 Subp_Spec
: Node_Id
;
2486 -- Start of processing for Apply_Parameter_Validity_Checks
2489 -- Extract the subprogram specification and declaration nodes
2491 Subp_Spec
:= Parent
(Subp
);
2493 if Nkind
(Subp_Spec
) = N_Defining_Program_Unit_Name
then
2494 Subp_Spec
:= Parent
(Subp_Spec
);
2497 Subp_Decl
:= Parent
(Subp_Spec
);
2499 if not Comes_From_Source
(Subp
)
2501 -- Do not process formal subprograms because the corresponding actual
2502 -- will receive the proper checks when the instance is analyzed.
2504 or else Is_Formal_Subprogram
(Subp
)
2506 -- Do not process imported subprograms since pre and post conditions
2507 -- are never verified on routines coming from a different language.
2509 or else Is_Imported
(Subp
)
2510 or else Is_Intrinsic_Subprogram
(Subp
)
2512 -- The PPC pragmas generated by this routine do not correspond to
2513 -- source aspects, therefore they cannot be applied to abstract
2516 or else Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
2518 -- Do not consider subprogram renaminds because the renamed entity
2519 -- already has the proper PPC pragmas.
2521 or else Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
2523 -- Do not process null procedures because there is no benefit of
2524 -- adding the checks to a no action routine.
2526 or else (Nkind
(Subp_Spec
) = N_Procedure_Specification
2527 and then Null_Present
(Subp_Spec
))
2532 -- Inspect all the formals applying aliasing and scalar initialization
2533 -- checks where applicable.
2535 Formal
:= First_Formal
(Subp
);
2536 while Present
(Formal
) loop
2538 -- Generate the following scalar initialization checks for each
2539 -- formal parameter:
2541 -- mode IN - Pre => Formal'Valid[_Scalars]
2542 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2543 -- mode OUT - Post => Formal'Valid[_Scalars]
2545 if Check_Validity_Of_Parameters
then
2546 if Ekind_In
(Formal
, E_In_Parameter
, E_In_Out_Parameter
) then
2547 Add_Validity_Check
(Formal
, Name_Precondition
, False);
2550 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
2551 Add_Validity_Check
(Formal
, Name_Postcondition
, False);
2555 Next_Formal
(Formal
);
2558 -- Generate following scalar initialization check for function result:
2560 -- Post => Subp'Result'Valid[_Scalars]
2562 if Check_Validity_Of_Parameters
and then Ekind
(Subp
) = E_Function
then
2563 Add_Validity_Check
(Subp
, Name_Postcondition
, True);
2565 end Apply_Parameter_Validity_Checks
;
2567 ---------------------------
2568 -- Apply_Predicate_Check --
2569 ---------------------------
2571 procedure Apply_Predicate_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
2575 if Present
(Predicate_Function
(Typ
)) then
2577 -- A predicate check does not apply within internally generated
2578 -- subprograms, such as TSS functions.
2581 while Present
(S
) and then not Is_Subprogram
(S
) loop
2585 if Present
(S
) and then Get_TSS_Name
(S
) /= TSS_Null
then
2588 -- If the check appears within the predicate function itself, it
2589 -- means that the user specified a check whose formal is the
2590 -- predicated subtype itself, rather than some covering type. This
2591 -- is likely to be a common error, and thus deserves a warning.
2593 elsif S
= Predicate_Function
(Typ
) then
2595 ("predicate check includes a function call that "
2596 & "requires a predicate check??", Parent
(N
));
2598 ("\this will result in infinite recursion??", Parent
(N
));
2600 Make_Raise_Storage_Error
(Sloc
(N
),
2601 Reason
=> SE_Infinite_Recursion
));
2603 -- Here for normal case of predicate active
2606 -- If the type has a static predicate and the expression is known
2607 -- at compile time, see if the expression satisfies the predicate.
2609 Check_Expression_Against_Static_Predicate
(N
, Typ
);
2612 Make_Predicate_Check
(Typ
, Duplicate_Subexpr
(N
)));
2615 end Apply_Predicate_Check
;
2617 -----------------------
2618 -- Apply_Range_Check --
2619 -----------------------
2621 procedure Apply_Range_Check
2623 Target_Typ
: Entity_Id
;
2624 Source_Typ
: Entity_Id
:= Empty
)
2627 Apply_Selected_Range_Checks
2628 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2629 end Apply_Range_Check
;
2631 ------------------------------
2632 -- Apply_Scalar_Range_Check --
2633 ------------------------------
2635 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
2636 -- off if it is already set on.
2638 procedure Apply_Scalar_Range_Check
2640 Target_Typ
: Entity_Id
;
2641 Source_Typ
: Entity_Id
:= Empty
;
2642 Fixed_Int
: Boolean := False)
2644 Parnt
: constant Node_Id
:= Parent
(Expr
);
2646 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
2647 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
2650 Is_Subscr_Ref
: Boolean;
2651 -- Set true if Expr is a subscript
2653 Is_Unconstrained_Subscr_Ref
: Boolean;
2654 -- Set true if Expr is a subscript of an unconstrained array. In this
2655 -- case we do not attempt to do an analysis of the value against the
2656 -- range of the subscript, since we don't know the actual subtype.
2659 -- Set to True if Expr should be regarded as a real value even though
2660 -- the type of Expr might be discrete.
2662 procedure Bad_Value
;
2663 -- Procedure called if value is determined to be out of range
2669 procedure Bad_Value
is
2671 Apply_Compile_Time_Constraint_Error
2672 (Expr
, "value not in range of}??", CE_Range_Check_Failed
,
2677 -- Start of processing for Apply_Scalar_Range_Check
2680 -- Return if check obviously not needed
2683 -- Not needed inside generic
2687 -- Not needed if previous error
2689 or else Target_Typ
= Any_Type
2690 or else Nkind
(Expr
) = N_Error
2692 -- Not needed for non-scalar type
2694 or else not Is_Scalar_Type
(Target_Typ
)
2696 -- Not needed if we know node raises CE already
2698 or else Raises_Constraint_Error
(Expr
)
2703 -- Now, see if checks are suppressed
2706 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
2708 if Is_Subscr_Ref
then
2709 Arr
:= Prefix
(Parnt
);
2710 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
2712 if Is_Access_Type
(Arr_Typ
) then
2713 Arr_Typ
:= Designated_Type
(Arr_Typ
);
2717 if not Do_Range_Check
(Expr
) then
2719 -- Subscript reference. Check for Index_Checks suppressed
2721 if Is_Subscr_Ref
then
2723 -- Check array type and its base type
2725 if Index_Checks_Suppressed
(Arr_Typ
)
2726 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
2730 -- Check array itself if it is an entity name
2732 elsif Is_Entity_Name
(Arr
)
2733 and then Index_Checks_Suppressed
(Entity
(Arr
))
2737 -- Check expression itself if it is an entity name
2739 elsif Is_Entity_Name
(Expr
)
2740 and then Index_Checks_Suppressed
(Entity
(Expr
))
2745 -- All other cases, check for Range_Checks suppressed
2748 -- Check target type and its base type
2750 if Range_Checks_Suppressed
(Target_Typ
)
2751 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
2755 -- Check expression itself if it is an entity name
2757 elsif Is_Entity_Name
(Expr
)
2758 and then Range_Checks_Suppressed
(Entity
(Expr
))
2762 -- If Expr is part of an assignment statement, then check left
2763 -- side of assignment if it is an entity name.
2765 elsif Nkind
(Parnt
) = N_Assignment_Statement
2766 and then Is_Entity_Name
(Name
(Parnt
))
2767 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
2774 -- Do not set range checks if they are killed
2776 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
2777 and then Kill_Range_Check
(Expr
)
2782 -- Do not set range checks for any values from System.Scalar_Values
2783 -- since the whole idea of such values is to avoid checking them.
2785 if Is_Entity_Name
(Expr
)
2786 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
2791 -- Now see if we need a check
2793 if No
(Source_Typ
) then
2794 S_Typ
:= Etype
(Expr
);
2796 S_Typ
:= Source_Typ
;
2799 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
2803 Is_Unconstrained_Subscr_Ref
:=
2804 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
2806 -- Special checks for floating-point type
2808 if Is_Floating_Point_Type
(S_Typ
) then
2810 -- Always do a range check if the source type includes infinities and
2811 -- the target type does not include infinities. We do not do this if
2812 -- range checks are killed.
2814 if Has_Infinities
(S_Typ
)
2815 and then not Has_Infinities
(Target_Typ
)
2817 Enable_Range_Check
(Expr
);
2819 -- Always do a range check for operators if option set
2821 elsif Check_Float_Overflow
and then Nkind
(Expr
) in N_Op
then
2822 Enable_Range_Check
(Expr
);
2826 -- Return if we know expression is definitely in the range of the target
2827 -- type as determined by Determine_Range. Right now we only do this for
2828 -- discrete types, and not fixed-point or floating-point types.
2830 -- The additional less-precise tests below catch these cases
2832 -- Note: skip this if we are given a source_typ, since the point of
2833 -- supplying a Source_Typ is to stop us looking at the expression.
2834 -- We could sharpen this test to be out parameters only ???
2836 if Is_Discrete_Type
(Target_Typ
)
2837 and then Is_Discrete_Type
(Etype
(Expr
))
2838 and then not Is_Unconstrained_Subscr_Ref
2839 and then No
(Source_Typ
)
2842 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
2843 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
2848 if Compile_Time_Known_Value
(Tlo
)
2849 and then Compile_Time_Known_Value
(Thi
)
2852 Lov
: constant Uint
:= Expr_Value
(Tlo
);
2853 Hiv
: constant Uint
:= Expr_Value
(Thi
);
2856 -- If range is null, we for sure have a constraint error
2857 -- (we don't even need to look at the value involved,
2858 -- since all possible values will raise CE).
2865 -- Otherwise determine range of value
2867 Determine_Range
(Expr
, OK
, Lo
, Hi
, Assume_Valid
=> True);
2871 -- If definitely in range, all OK
2873 if Lo
>= Lov
and then Hi
<= Hiv
then
2876 -- If definitely not in range, warn
2878 elsif Lov
> Hi
or else Hiv
< Lo
then
2882 -- Otherwise we don't know
2894 Is_Floating_Point_Type
(S_Typ
)
2895 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
2897 -- Check if we can determine at compile time whether Expr is in the
2898 -- range of the target type. Note that if S_Typ is within the bounds
2899 -- of Target_Typ then this must be the case. This check is meaningful
2900 -- only if this is not a conversion between integer and real types.
2902 if not Is_Unconstrained_Subscr_Ref
2903 and then Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
2905 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
2907 Is_In_Range
(Expr
, Target_Typ
,
2908 Assume_Valid
=> True,
2909 Fixed_Int
=> Fixed_Int
,
2910 Int_Real
=> Int_Real
))
2914 elsif Is_Out_Of_Range
(Expr
, Target_Typ
,
2915 Assume_Valid
=> True,
2916 Fixed_Int
=> Fixed_Int
,
2917 Int_Real
=> Int_Real
)
2922 -- Floating-point case
2923 -- In the floating-point case, we only do range checks if the type is
2924 -- constrained. We definitely do NOT want range checks for unconstrained
2925 -- types, since we want to have infinities
2927 elsif Is_Floating_Point_Type
(S_Typ
) then
2929 -- Normally, we only do range checks if the type is constrained. We do
2930 -- NOT want range checks for unconstrained types, since we want to have
2931 -- infinities. Override this decision in Check_Float_Overflow mode.
2933 if Is_Constrained
(S_Typ
) or else Check_Float_Overflow
then
2934 Enable_Range_Check
(Expr
);
2937 -- For all other cases we enable a range check unconditionally
2940 Enable_Range_Check
(Expr
);
2943 end Apply_Scalar_Range_Check
;
2945 ----------------------------------
2946 -- Apply_Selected_Length_Checks --
2947 ----------------------------------
2949 procedure Apply_Selected_Length_Checks
2951 Target_Typ
: Entity_Id
;
2952 Source_Typ
: Entity_Id
;
2953 Do_Static
: Boolean)
2956 R_Result
: Check_Result
;
2959 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
2960 Checks_On
: constant Boolean :=
2961 (not Index_Checks_Suppressed
(Target_Typ
))
2962 or else (not Length_Checks_Suppressed
(Target_Typ
));
2965 -- Note: this means that we lose some useful warnings if the expander
2966 -- is not active, and we also lose these warnings in SPARK mode ???
2968 if not Expander_Active
then
2973 Selected_Length_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
2975 for J
in 1 .. 2 loop
2976 R_Cno
:= R_Result
(J
);
2977 exit when No
(R_Cno
);
2979 -- A length check may mention an Itype which is attached to a
2980 -- subsequent node. At the top level in a package this can cause
2981 -- an order-of-elaboration problem, so we make sure that the itype
2982 -- is referenced now.
2984 if Ekind
(Current_Scope
) = E_Package
2985 and then Is_Compilation_Unit
(Current_Scope
)
2987 Ensure_Defined
(Target_Typ
, Ck_Node
);
2989 if Present
(Source_Typ
) then
2990 Ensure_Defined
(Source_Typ
, Ck_Node
);
2992 elsif Is_Itype
(Etype
(Ck_Node
)) then
2993 Ensure_Defined
(Etype
(Ck_Node
), Ck_Node
);
2997 -- If the item is a conditional raise of constraint error, then have
2998 -- a look at what check is being performed and ???
3000 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
3001 and then Present
(Condition
(R_Cno
))
3003 Cond
:= Condition
(R_Cno
);
3005 -- Case where node does not now have a dynamic check
3007 if not Has_Dynamic_Length_Check
(Ck_Node
) then
3009 -- If checks are on, just insert the check
3012 Insert_Action
(Ck_Node
, R_Cno
);
3014 if not Do_Static
then
3015 Set_Has_Dynamic_Length_Check
(Ck_Node
);
3018 -- If checks are off, then analyze the length check after
3019 -- temporarily attaching it to the tree in case the relevant
3020 -- condition can be evaluated at compile time. We still want a
3021 -- compile time warning in this case.
3024 Set_Parent
(R_Cno
, Ck_Node
);
3029 -- Output a warning if the condition is known to be True
3031 if Is_Entity_Name
(Cond
)
3032 and then Entity
(Cond
) = Standard_True
3034 Apply_Compile_Time_Constraint_Error
3035 (Ck_Node
, "wrong length for array of}??",
3036 CE_Length_Check_Failed
,
3040 -- If we were only doing a static check, or if checks are not
3041 -- on, then we want to delete the check, since it is not needed.
3042 -- We do this by replacing the if statement by a null statement
3044 elsif Do_Static
or else not Checks_On
then
3045 Remove_Warning_Messages
(R_Cno
);
3046 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3050 Install_Static_Check
(R_Cno
, Loc
);
3053 end Apply_Selected_Length_Checks
;
3055 ---------------------------------
3056 -- Apply_Selected_Range_Checks --
3057 ---------------------------------
3059 procedure Apply_Selected_Range_Checks
3061 Target_Typ
: Entity_Id
;
3062 Source_Typ
: Entity_Id
;
3063 Do_Static
: Boolean)
3066 R_Result
: Check_Result
;
3069 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
3070 Checks_On
: constant Boolean :=
3071 (not Index_Checks_Suppressed
(Target_Typ
))
3072 or else (not Range_Checks_Suppressed
(Target_Typ
));
3075 if not Expander_Active
or else not Checks_On
then
3080 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
3082 for J
in 1 .. 2 loop
3084 R_Cno
:= R_Result
(J
);
3085 exit when No
(R_Cno
);
3087 -- If the item is a conditional raise of constraint error, then have
3088 -- a look at what check is being performed and ???
3090 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
3091 and then Present
(Condition
(R_Cno
))
3093 Cond
:= Condition
(R_Cno
);
3095 if not Has_Dynamic_Range_Check
(Ck_Node
) then
3096 Insert_Action
(Ck_Node
, R_Cno
);
3098 if not Do_Static
then
3099 Set_Has_Dynamic_Range_Check
(Ck_Node
);
3103 -- Output a warning if the condition is known to be True
3105 if Is_Entity_Name
(Cond
)
3106 and then Entity
(Cond
) = Standard_True
3108 -- Since an N_Range is technically not an expression, we have
3109 -- to set one of the bounds to C_E and then just flag the
3110 -- N_Range. The warning message will point to the lower bound
3111 -- and complain about a range, which seems OK.
3113 if Nkind
(Ck_Node
) = N_Range
then
3114 Apply_Compile_Time_Constraint_Error
3115 (Low_Bound
(Ck_Node
), "static range out of bounds of}??",
3116 CE_Range_Check_Failed
,
3120 Set_Raises_Constraint_Error
(Ck_Node
);
3123 Apply_Compile_Time_Constraint_Error
3124 (Ck_Node
, "static value out of range of}?",
3125 CE_Range_Check_Failed
,
3130 -- If we were only doing a static check, or if checks are not
3131 -- on, then we want to delete the check, since it is not needed.
3132 -- We do this by replacing the if statement by a null statement
3134 elsif Do_Static
or else not Checks_On
then
3135 Remove_Warning_Messages
(R_Cno
);
3136 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3140 Install_Static_Check
(R_Cno
, Loc
);
3143 end Apply_Selected_Range_Checks
;
3145 -------------------------------
3146 -- Apply_Static_Length_Check --
3147 -------------------------------
3149 procedure Apply_Static_Length_Check
3151 Target_Typ
: Entity_Id
;
3152 Source_Typ
: Entity_Id
:= Empty
)
3155 Apply_Selected_Length_Checks
3156 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
3157 end Apply_Static_Length_Check
;
3159 -------------------------------------
3160 -- Apply_Subscript_Validity_Checks --
3161 -------------------------------------
3163 procedure Apply_Subscript_Validity_Checks
(Expr
: Node_Id
) is
3167 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
3169 -- Loop through subscripts
3171 Sub
:= First
(Expressions
(Expr
));
3172 while Present
(Sub
) loop
3174 -- Check one subscript. Note that we do not worry about enumeration
3175 -- type with holes, since we will convert the value to a Pos value
3176 -- for the subscript, and that convert will do the necessary validity
3179 Ensure_Valid
(Sub
, Holes_OK
=> True);
3181 -- Move to next subscript
3185 end Apply_Subscript_Validity_Checks
;
3187 ----------------------------------
3188 -- Apply_Type_Conversion_Checks --
3189 ----------------------------------
3191 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
3192 Target_Type
: constant Entity_Id
:= Etype
(N
);
3193 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
3194 Expr
: constant Node_Id
:= Expression
(N
);
3196 Expr_Type
: constant Entity_Id
:= Underlying_Type
(Etype
(Expr
));
3197 -- Note: if Etype (Expr) is a private type without discriminants, its
3198 -- full view might have discriminants with defaults, so we need the
3199 -- full view here to retrieve the constraints.
3202 if Inside_A_Generic
then
3205 -- Skip these checks if serious errors detected, there are some nasty
3206 -- situations of incomplete trees that blow things up.
3208 elsif Serious_Errors_Detected
> 0 then
3211 -- Scalar type conversions of the form Target_Type (Expr) require a
3212 -- range check if we cannot be sure that Expr is in the base type of
3213 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3214 -- are not quite the same condition from an implementation point of
3215 -- view, but clearly the second includes the first.
3217 elsif Is_Scalar_Type
(Target_Type
) then
3219 Conv_OK
: constant Boolean := Conversion_OK
(N
);
3220 -- If the Conversion_OK flag on the type conversion is set and no
3221 -- floating point type is involved in the type conversion then
3222 -- fixed point values must be read as integral values.
3224 Float_To_Int
: constant Boolean :=
3225 Is_Floating_Point_Type
(Expr_Type
)
3226 and then Is_Integer_Type
(Target_Type
);
3229 if not Overflow_Checks_Suppressed
(Target_Base
)
3230 and then not Overflow_Checks_Suppressed
(Target_Type
)
3232 In_Subrange_Of
(Expr_Type
, Target_Base
, Fixed_Int
=> Conv_OK
)
3233 and then not Float_To_Int
3235 Activate_Overflow_Check
(N
);
3238 if not Range_Checks_Suppressed
(Target_Type
)
3239 and then not Range_Checks_Suppressed
(Expr_Type
)
3241 if Float_To_Int
then
3242 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
3244 Apply_Scalar_Range_Check
3245 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
3247 -- If the target type has predicates, we need to indicate
3248 -- the need for a check, even if Determine_Range finds
3249 -- that the value is within bounds. This may be the case
3250 -- e.g for a division with a constant denominator.
3252 if Has_Predicates
(Target_Type
) then
3253 Enable_Range_Check
(Expr
);
3259 elsif Comes_From_Source
(N
)
3260 and then not Discriminant_Checks_Suppressed
(Target_Type
)
3261 and then Is_Record_Type
(Target_Type
)
3262 and then Is_Derived_Type
(Target_Type
)
3263 and then not Is_Tagged_Type
(Target_Type
)
3264 and then not Is_Constrained
(Target_Type
)
3265 and then Present
(Stored_Constraint
(Target_Type
))
3267 -- An unconstrained derived type may have inherited discriminant.
3268 -- Build an actual discriminant constraint list using the stored
3269 -- constraint, to verify that the expression of the parent type
3270 -- satisfies the constraints imposed by the (unconstrained)
3271 -- derived type. This applies to value conversions, not to view
3272 -- conversions of tagged types.
3275 Loc
: constant Source_Ptr
:= Sloc
(N
);
3277 Constraint
: Elmt_Id
;
3278 Discr_Value
: Node_Id
;
3281 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
3282 Old_Constraints
: constant Elist_Id
:=
3283 Discriminant_Constraint
(Expr_Type
);
3286 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
3287 while Present
(Constraint
) loop
3288 Discr_Value
:= Node
(Constraint
);
3290 if Is_Entity_Name
(Discr_Value
)
3291 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
3293 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
3296 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
3298 -- Parent is constrained by new discriminant. Obtain
3299 -- Value of original discriminant in expression. If the
3300 -- new discriminant has been used to constrain more than
3301 -- one of the stored discriminants, this will provide the
3302 -- required consistency check.
3305 (Make_Selected_Component
(Loc
,
3307 Duplicate_Subexpr_No_Checks
3308 (Expr
, Name_Req
=> True),
3310 Make_Identifier
(Loc
, Chars
(Discr
))),
3314 -- Discriminant of more remote ancestor ???
3319 -- Derived type definition has an explicit value for this
3320 -- stored discriminant.
3324 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
3328 Next_Elmt
(Constraint
);
3331 -- Use the unconstrained expression type to retrieve the
3332 -- discriminants of the parent, and apply momentarily the
3333 -- discriminant constraint synthesized above.
3335 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
3336 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
3337 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
3340 Make_Raise_Constraint_Error
(Loc
,
3342 Reason
=> CE_Discriminant_Check_Failed
));
3345 -- For arrays, checks are set now, but conversions are applied during
3346 -- expansion, to take into accounts changes of representation. The
3347 -- checks become range checks on the base type or length checks on the
3348 -- subtype, depending on whether the target type is unconstrained or
3349 -- constrained. Note that the range check is put on the expression of a
3350 -- type conversion, while the length check is put on the type conversion
3353 elsif Is_Array_Type
(Target_Type
) then
3354 if Is_Constrained
(Target_Type
) then
3355 Set_Do_Length_Check
(N
);
3357 Set_Do_Range_Check
(Expr
);
3360 end Apply_Type_Conversion_Checks
;
3362 ----------------------------------------------
3363 -- Apply_Universal_Integer_Attribute_Checks --
3364 ----------------------------------------------
3366 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
3367 Loc
: constant Source_Ptr
:= Sloc
(N
);
3368 Typ
: constant Entity_Id
:= Etype
(N
);
3371 if Inside_A_Generic
then
3374 -- Nothing to do if checks are suppressed
3376 elsif Range_Checks_Suppressed
(Typ
)
3377 and then Overflow_Checks_Suppressed
(Typ
)
3381 -- Nothing to do if the attribute does not come from source. The
3382 -- internal attributes we generate of this type do not need checks,
3383 -- and furthermore the attempt to check them causes some circular
3384 -- elaboration orders when dealing with packed types.
3386 elsif not Comes_From_Source
(N
) then
3389 -- If the prefix is a selected component that depends on a discriminant
3390 -- the check may improperly expose a discriminant instead of using
3391 -- the bounds of the object itself. Set the type of the attribute to
3392 -- the base type of the context, so that a check will be imposed when
3393 -- needed (e.g. if the node appears as an index).
3395 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
3396 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
3397 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
3399 Set_Etype
(N
, Base_Type
(Typ
));
3401 -- Otherwise, replace the attribute node with a type conversion node
3402 -- whose expression is the attribute, retyped to universal integer, and
3403 -- whose subtype mark is the target type. The call to analyze this
3404 -- conversion will set range and overflow checks as required for proper
3405 -- detection of an out of range value.
3408 Set_Etype
(N
, Universal_Integer
);
3409 Set_Analyzed
(N
, True);
3412 Make_Type_Conversion
(Loc
,
3413 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
3414 Expression
=> Relocate_Node
(N
)));
3416 Analyze_And_Resolve
(N
, Typ
);
3419 end Apply_Universal_Integer_Attribute_Checks
;
3421 -------------------------------------
3422 -- Atomic_Synchronization_Disabled --
3423 -------------------------------------
3425 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3426 -- using a bogus check called Atomic_Synchronization. This is to make it
3427 -- more convenient to get exactly the same semantics as [Un]Suppress.
3429 function Atomic_Synchronization_Disabled
(E
: Entity_Id
) return Boolean is
3431 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3432 -- looks enabled, since it is never disabled.
3434 if Debug_Flag_Dot_E
then
3437 -- If debug flag d.d is set then always return True, i.e. all atomic
3438 -- sync looks disabled, since it always tests True.
3440 elsif Debug_Flag_Dot_D
then
3443 -- If entity present, then check result for that entity
3445 elsif Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3446 return Is_Check_Suppressed
(E
, Atomic_Synchronization
);
3448 -- Otherwise result depends on current scope setting
3451 return Scope_Suppress
.Suppress
(Atomic_Synchronization
);
3453 end Atomic_Synchronization_Disabled
;
3455 -------------------------------
3456 -- Build_Discriminant_Checks --
3457 -------------------------------
3459 function Build_Discriminant_Checks
3461 T_Typ
: Entity_Id
) return Node_Id
3463 Loc
: constant Source_Ptr
:= Sloc
(N
);
3466 Disc_Ent
: Entity_Id
;
3470 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
;
3472 ----------------------------------
3473 -- Aggregate_Discriminant_Value --
3474 ----------------------------------
3476 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
is
3480 -- The aggregate has been normalized with named associations. We use
3481 -- the Chars field to locate the discriminant to take into account
3482 -- discriminants in derived types, which carry the same name as those
3485 Assoc
:= First
(Component_Associations
(N
));
3486 while Present
(Assoc
) loop
3487 if Chars
(First
(Choices
(Assoc
))) = Chars
(Disc
) then
3488 return Expression
(Assoc
);
3494 -- Discriminant must have been found in the loop above
3496 raise Program_Error
;
3497 end Aggregate_Discriminant_Val
;
3499 -- Start of processing for Build_Discriminant_Checks
3502 -- Loop through discriminants evolving the condition
3505 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
3507 -- For a fully private type, use the discriminants of the parent type
3509 if Is_Private_Type
(T_Typ
)
3510 and then No
(Full_View
(T_Typ
))
3512 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
3514 Disc_Ent
:= First_Discriminant
(T_Typ
);
3517 while Present
(Disc
) loop
3518 Dval
:= Node
(Disc
);
3520 if Nkind
(Dval
) = N_Identifier
3521 and then Ekind
(Entity
(Dval
)) = E_Discriminant
3523 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
3525 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
3528 -- If we have an Unchecked_Union node, we can infer the discriminants
3531 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
3533 Get_Discriminant_Value
(
3534 First_Discriminant
(T_Typ
),
3536 Stored_Constraint
(T_Typ
)));
3538 elsif Nkind
(N
) = N_Aggregate
then
3540 Duplicate_Subexpr_No_Checks
3541 (Aggregate_Discriminant_Val
(Disc_Ent
));
3545 Make_Selected_Component
(Loc
,
3547 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
3548 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
3550 Set_Is_In_Discriminant_Check
(Dref
);
3553 Evolve_Or_Else
(Cond
,
3556 Right_Opnd
=> Dval
));
3559 Next_Discriminant
(Disc_Ent
);
3563 end Build_Discriminant_Checks
;
3569 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
3576 function Left_Expression
(Op
: Node_Id
) return Node_Id
;
3577 -- Return the relevant expression from the left operand of the given
3578 -- short circuit form: this is LO itself, except if LO is a qualified
3579 -- expression, a type conversion, or an expression with actions, in
3580 -- which case this is Left_Expression (Expression (LO)).
3582 ---------------------
3583 -- Left_Expression --
3584 ---------------------
3586 function Left_Expression
(Op
: Node_Id
) return Node_Id
is
3587 LE
: Node_Id
:= Left_Opnd
(Op
);
3589 while Nkind_In
(LE
, N_Qualified_Expression
,
3591 N_Expression_With_Actions
)
3593 LE
:= Expression
(LE
);
3597 end Left_Expression
;
3599 -- Start of processing for Check_Needed
3602 -- Always check if not simple entity
3604 if Nkind
(Nod
) not in N_Has_Entity
3605 or else not Comes_From_Source
(Nod
)
3610 -- Look up tree for short circuit
3617 -- Done if out of subexpression (note that we allow generated stuff
3618 -- such as itype declarations in this context, to keep the loop going
3619 -- since we may well have generated such stuff in complex situations.
3620 -- Also done if no parent (probably an error condition, but no point
3621 -- in behaving nasty if we find it).
3624 or else (K
not in N_Subexpr
and then Comes_From_Source
(P
))
3628 -- Or/Or Else case, where test is part of the right operand, or is
3629 -- part of one of the actions associated with the right operand, and
3630 -- the left operand is an equality test.
3632 elsif K
= N_Op_Or
then
3633 exit when N
= Right_Opnd
(P
)
3634 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
3636 elsif K
= N_Or_Else
then
3637 exit when (N
= Right_Opnd
(P
)
3640 and then List_Containing
(N
) = Actions
(P
)))
3641 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
3643 -- Similar test for the And/And then case, where the left operand
3644 -- is an inequality test.
3646 elsif K
= N_Op_And
then
3647 exit when N
= Right_Opnd
(P
)
3648 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
3650 elsif K
= N_And_Then
then
3651 exit when (N
= Right_Opnd
(P
)
3654 and then List_Containing
(N
) = Actions
(P
)))
3655 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
3661 -- If we fall through the loop, then we have a conditional with an
3662 -- appropriate test as its left operand, so look further.
3664 L
:= Left_Expression
(P
);
3666 -- L is an "=" or "/=" operator: extract its operands
3668 R
:= Right_Opnd
(L
);
3671 -- Left operand of test must match original variable
3673 if Nkind
(L
) not in N_Has_Entity
or else Entity
(L
) /= Entity
(Nod
) then
3677 -- Right operand of test must be key value (zero or null)
3680 when Access_Check
=>
3681 if not Known_Null
(R
) then
3685 when Division_Check
=>
3686 if not Compile_Time_Known_Value
(R
)
3687 or else Expr_Value
(R
) /= Uint_0
3693 raise Program_Error
;
3696 -- Here we have the optimizable case, warn if not short-circuited
3698 if K
= N_Op_And
or else K
= N_Op_Or
then
3699 Error_Msg_Warn
:= SPARK_Mode
/= On
;
3702 when Access_Check
=>
3703 if GNATprove_Mode
then
3705 ("Constraint_Error might have been raised (access check)",
3709 ("Constraint_Error may be raised (access check)??",
3713 when Division_Check
=>
3714 if GNATprove_Mode
then
3716 ("Constraint_Error might have been raised (zero divide)",
3720 ("Constraint_Error may be raised (zero divide)??",
3725 raise Program_Error
;
3728 if K
= N_Op_And
then
3729 Error_Msg_N
-- CODEFIX
3730 ("use `AND THEN` instead of AND??", P
);
3732 Error_Msg_N
-- CODEFIX
3733 ("use `OR ELSE` instead of OR??", P
);
3736 -- If not short-circuited, we need the check
3740 -- If short-circuited, we can omit the check
3747 -----------------------------------
3748 -- Check_Valid_Lvalue_Subscripts --
3749 -----------------------------------
3751 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
3753 -- Skip this if range checks are suppressed
3755 if Range_Checks_Suppressed
(Etype
(Expr
)) then
3758 -- Only do this check for expressions that come from source. We assume
3759 -- that expander generated assignments explicitly include any necessary
3760 -- checks. Note that this is not just an optimization, it avoids
3761 -- infinite recursions.
3763 elsif not Comes_From_Source
(Expr
) then
3766 -- For a selected component, check the prefix
3768 elsif Nkind
(Expr
) = N_Selected_Component
then
3769 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3772 -- Case of indexed component
3774 elsif Nkind
(Expr
) = N_Indexed_Component
then
3775 Apply_Subscript_Validity_Checks
(Expr
);
3777 -- Prefix may itself be or contain an indexed component, and these
3778 -- subscripts need checking as well.
3780 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3782 end Check_Valid_Lvalue_Subscripts
;
3784 ----------------------------------
3785 -- Null_Exclusion_Static_Checks --
3786 ----------------------------------
3788 procedure Null_Exclusion_Static_Checks
(N
: Node_Id
) is
3789 Error_Node
: Node_Id
;
3791 Has_Null
: constant Boolean := Has_Null_Exclusion
(N
);
3792 K
: constant Node_Kind
:= Nkind
(N
);
3797 (K
= N_Component_Declaration
3798 or else K
= N_Discriminant_Specification
3799 or else K
= N_Function_Specification
3800 or else K
= N_Object_Declaration
3801 or else K
= N_Parameter_Specification
);
3803 if K
= N_Function_Specification
then
3804 Typ
:= Etype
(Defining_Entity
(N
));
3806 Typ
:= Etype
(Defining_Identifier
(N
));
3810 when N_Component_Declaration
=>
3811 if Present
(Access_Definition
(Component_Definition
(N
))) then
3812 Error_Node
:= Component_Definition
(N
);
3814 Error_Node
:= Subtype_Indication
(Component_Definition
(N
));
3817 when N_Discriminant_Specification
=>
3818 Error_Node
:= Discriminant_Type
(N
);
3820 when N_Function_Specification
=>
3821 Error_Node
:= Result_Definition
(N
);
3823 when N_Object_Declaration
=>
3824 Error_Node
:= Object_Definition
(N
);
3826 when N_Parameter_Specification
=>
3827 Error_Node
:= Parameter_Type
(N
);
3830 raise Program_Error
;
3835 -- Enforce legality rule 3.10 (13): A null exclusion can only be
3836 -- applied to an access [sub]type.
3838 if not Is_Access_Type
(Typ
) then
3840 ("`NOT NULL` allowed only for an access type", Error_Node
);
3842 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
3843 -- be applied to a [sub]type that does not exclude null already.
3845 elsif Can_Never_Be_Null
(Typ
)
3846 and then Comes_From_Source
(Typ
)
3849 ("`NOT NULL` not allowed (& already excludes null)",
3854 -- Check that null-excluding objects are always initialized, except for
3855 -- deferred constants, for which the expression will appear in the full
3858 if K
= N_Object_Declaration
3859 and then No
(Expression
(N
))
3860 and then not Constant_Present
(N
)
3861 and then not No_Initialization
(N
)
3863 -- Add an expression that assigns null. This node is needed by
3864 -- Apply_Compile_Time_Constraint_Error, which will replace this with
3865 -- a Constraint_Error node.
3867 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
3868 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
3870 Apply_Compile_Time_Constraint_Error
3871 (N
=> Expression
(N
),
3873 "(Ada 2005) null-excluding objects must be initialized??",
3874 Reason
=> CE_Null_Not_Allowed
);
3877 -- Check that a null-excluding component, formal or object is not being
3878 -- assigned a null value. Otherwise generate a warning message and
3879 -- replace Expression (N) by an N_Constraint_Error node.
3881 if K
/= N_Function_Specification
then
3882 Expr
:= Expression
(N
);
3884 if Present
(Expr
) and then Known_Null
(Expr
) then
3886 when N_Component_Declaration |
3887 N_Discriminant_Specification
=>
3888 Apply_Compile_Time_Constraint_Error
3890 Msg
=> "(Ada 2005) null not allowed "
3891 & "in null-excluding components??",
3892 Reason
=> CE_Null_Not_Allowed
);
3894 when N_Object_Declaration
=>
3895 Apply_Compile_Time_Constraint_Error
3897 Msg
=> "(Ada 2005) null not allowed "
3898 & "in null-excluding objects?",
3899 Reason
=> CE_Null_Not_Allowed
);
3901 when N_Parameter_Specification
=>
3902 Apply_Compile_Time_Constraint_Error
3904 Msg
=> "(Ada 2005) null not allowed "
3905 & "in null-excluding formals??",
3906 Reason
=> CE_Null_Not_Allowed
);
3913 end Null_Exclusion_Static_Checks
;
3915 ----------------------------------
3916 -- Conditional_Statements_Begin --
3917 ----------------------------------
3919 procedure Conditional_Statements_Begin
is
3921 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
3923 -- If stack overflows, kill all checks, that way we know to simply reset
3924 -- the number of saved checks to zero on return. This should never occur
3927 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
3930 -- In the normal case, we just make a new stack entry saving the current
3931 -- number of saved checks for a later restore.
3934 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
3936 if Debug_Flag_CC
then
3937 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
3941 end Conditional_Statements_Begin
;
3943 --------------------------------
3944 -- Conditional_Statements_End --
3945 --------------------------------
3947 procedure Conditional_Statements_End
is
3949 pragma Assert
(Saved_Checks_TOS
> 0);
3951 -- If the saved checks stack overflowed, then we killed all checks, so
3952 -- setting the number of saved checks back to zero is correct. This
3953 -- should never occur in practice.
3955 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
3956 Num_Saved_Checks
:= 0;
3958 -- In the normal case, restore the number of saved checks from the top
3962 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
3964 if Debug_Flag_CC
then
3965 w
("Conditional_Statements_End: Num_Saved_Checks = ",
3970 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
3971 end Conditional_Statements_End
;
3973 -------------------------
3974 -- Convert_From_Bignum --
3975 -------------------------
3977 function Convert_From_Bignum
(N
: Node_Id
) return Node_Id
is
3978 Loc
: constant Source_Ptr
:= Sloc
(N
);
3981 pragma Assert
(Is_RTE
(Etype
(N
), RE_Bignum
));
3983 -- Construct call From Bignum
3986 Make_Function_Call
(Loc
,
3988 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3989 Parameter_Associations
=> New_List
(Relocate_Node
(N
)));
3990 end Convert_From_Bignum
;
3992 -----------------------
3993 -- Convert_To_Bignum --
3994 -----------------------
3996 function Convert_To_Bignum
(N
: Node_Id
) return Node_Id
is
3997 Loc
: constant Source_Ptr
:= Sloc
(N
);
4000 -- Nothing to do if Bignum already except call Relocate_Node
4002 if Is_RTE
(Etype
(N
), RE_Bignum
) then
4003 return Relocate_Node
(N
);
4005 -- Otherwise construct call to To_Bignum, converting the operand to the
4006 -- required Long_Long_Integer form.
4009 pragma Assert
(Is_Signed_Integer_Type
(Etype
(N
)));
4011 Make_Function_Call
(Loc
,
4013 New_Occurrence_Of
(RTE
(RE_To_Bignum
), Loc
),
4014 Parameter_Associations
=> New_List
(
4015 Convert_To
(Standard_Long_Long_Integer
, Relocate_Node
(N
))));
4017 end Convert_To_Bignum
;
4019 ---------------------
4020 -- Determine_Range --
4021 ---------------------
4023 Cache_Size
: constant := 2 ** 10;
4024 type Cache_Index
is range 0 .. Cache_Size
- 1;
4025 -- Determine size of below cache (power of 2 is more efficient)
4027 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
4028 Determine_Range_Cache_V
: array (Cache_Index
) of Boolean;
4029 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
4030 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
4031 -- The above arrays are used to implement a small direct cache for
4032 -- Determine_Range calls. Because of the way Determine_Range recursively
4033 -- traces subexpressions, and because overflow checking calls the routine
4034 -- on the way up the tree, a quadratic behavior can otherwise be
4035 -- encountered in large expressions. The cache entry for node N is stored
4036 -- in the (N mod Cache_Size) entry, and can be validated by checking the
4037 -- actual node value stored there. The Range_Cache_V array records the
4038 -- setting of Assume_Valid for the cache entry.
4040 procedure Determine_Range
4045 Assume_Valid
: Boolean := False)
4047 Typ
: Entity_Id
:= Etype
(N
);
4048 -- Type to use, may get reset to base type for possibly invalid entity
4052 -- Lo and Hi bounds of left operand
4056 -- Lo and Hi bounds of right (or only) operand
4059 -- Temp variable used to hold a bound node
4062 -- High bound of base type of expression
4066 -- Refined values for low and high bounds, after tightening
4069 -- Used in lower level calls to indicate if call succeeded
4071 Cindex
: Cache_Index
;
4072 -- Used to search cache
4077 function OK_Operands
return Boolean;
4078 -- Used for binary operators. Determines the ranges of the left and
4079 -- right operands, and if they are both OK, returns True, and puts
4080 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4086 function OK_Operands
return Boolean is
4089 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
4096 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4100 -- Start of processing for Determine_Range
4103 -- For temporary constants internally generated to remove side effects
4104 -- we must use the corresponding expression to determine the range of
4107 if Is_Entity_Name
(N
)
4108 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
4109 and then Ekind
(Entity
(N
)) = E_Constant
4110 and then Is_Internal_Name
(Chars
(Entity
(N
)))
4113 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
4117 -- Prevent junk warnings by initializing range variables
4124 -- If type is not defined, we can't determine its range
4128 -- We don't deal with anything except discrete types
4130 or else not Is_Discrete_Type
(Typ
)
4132 -- Ignore type for which an error has been posted, since range in
4133 -- this case may well be a bogosity deriving from the error. Also
4134 -- ignore if error posted on the reference node.
4136 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
4142 -- For all other cases, we can determine the range
4146 -- If value is compile time known, then the possible range is the one
4147 -- value that we know this expression definitely has.
4149 if Compile_Time_Known_Value
(N
) then
4150 Lo
:= Expr_Value
(N
);
4155 -- Return if already in the cache
4157 Cindex
:= Cache_Index
(N
mod Cache_Size
);
4159 if Determine_Range_Cache_N
(Cindex
) = N
4161 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
4163 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
4164 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
4168 -- Otherwise, start by finding the bounds of the type of the expression,
4169 -- the value cannot be outside this range (if it is, then we have an
4170 -- overflow situation, which is a separate check, we are talking here
4171 -- only about the expression value).
4173 -- First a check, never try to find the bounds of a generic type, since
4174 -- these bounds are always junk values, and it is only valid to look at
4175 -- the bounds in an instance.
4177 if Is_Generic_Type
(Typ
) then
4182 -- First step, change to use base type unless we know the value is valid
4184 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
4185 or else Assume_No_Invalid_Values
4186 or else Assume_Valid
4190 Typ
:= Underlying_Type
(Base_Type
(Typ
));
4193 -- Retrieve the base type. Handle the case where the base type is a
4194 -- private enumeration type.
4196 Btyp
:= Base_Type
(Typ
);
4198 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
4199 Btyp
:= Full_View
(Btyp
);
4202 -- We use the actual bound unless it is dynamic, in which case use the
4203 -- corresponding base type bound if possible. If we can't get a bound
4204 -- then we figure we can't determine the range (a peculiar case, that
4205 -- perhaps cannot happen, but there is no point in bombing in this
4206 -- optimization circuit.
4208 -- First the low bound
4210 Bound
:= Type_Low_Bound
(Typ
);
4212 if Compile_Time_Known_Value
(Bound
) then
4213 Lo
:= Expr_Value
(Bound
);
4215 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
4216 Lo
:= Expr_Value
(Type_Low_Bound
(Btyp
));
4223 -- Now the high bound
4225 Bound
:= Type_High_Bound
(Typ
);
4227 -- We need the high bound of the base type later on, and this should
4228 -- always be compile time known. Again, it is not clear that this
4229 -- can ever be false, but no point in bombing.
4231 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
4232 Hbound
:= Expr_Value
(Type_High_Bound
(Btyp
));
4240 -- If we have a static subtype, then that may have a tighter bound so
4241 -- use the upper bound of the subtype instead in this case.
4243 if Compile_Time_Known_Value
(Bound
) then
4244 Hi
:= Expr_Value
(Bound
);
4247 -- We may be able to refine this value in certain situations. If any
4248 -- refinement is possible, then Lor and Hir are set to possibly tighter
4249 -- bounds, and OK1 is set to True.
4253 -- For unary plus, result is limited by range of operand
4257 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4259 -- For unary minus, determine range of operand, and negate it
4263 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4270 -- For binary addition, get range of each operand and do the
4271 -- addition to get the result range.
4275 Lor
:= Lo_Left
+ Lo_Right
;
4276 Hir
:= Hi_Left
+ Hi_Right
;
4279 -- Division is tricky. The only case we consider is where the right
4280 -- operand is a positive constant, and in this case we simply divide
4281 -- the bounds of the left operand
4285 if Lo_Right
= Hi_Right
4286 and then Lo_Right
> 0
4288 Lor
:= Lo_Left
/ Lo_Right
;
4289 Hir
:= Hi_Left
/ Lo_Right
;
4295 -- For binary subtraction, get range of each operand and do the worst
4296 -- case subtraction to get the result range.
4298 when N_Op_Subtract
=>
4300 Lor
:= Lo_Left
- Hi_Right
;
4301 Hir
:= Hi_Left
- Lo_Right
;
4304 -- For MOD, if right operand is a positive constant, then result must
4305 -- be in the allowable range of mod results.
4309 if Lo_Right
= Hi_Right
4310 and then Lo_Right
/= 0
4312 if Lo_Right
> 0 then
4314 Hir
:= Lo_Right
- 1;
4316 else -- Lo_Right < 0
4317 Lor
:= Lo_Right
+ 1;
4326 -- For REM, if right operand is a positive constant, then result must
4327 -- be in the allowable range of mod results.
4331 if Lo_Right
= Hi_Right
4332 and then Lo_Right
/= 0
4335 Dval
: constant Uint
:= (abs Lo_Right
) - 1;
4338 -- The sign of the result depends on the sign of the
4339 -- dividend (but not on the sign of the divisor, hence
4340 -- the abs operation above).
4360 -- Attribute reference cases
4362 when N_Attribute_Reference
=>
4363 case Attribute_Name
(N
) is
4365 -- For Pos/Val attributes, we can refine the range using the
4366 -- possible range of values of the attribute expression.
4368 when Name_Pos | Name_Val
=>
4370 (First
(Expressions
(N
)), OK1
, Lor
, Hir
, Assume_Valid
);
4372 -- For Length attribute, use the bounds of the corresponding
4373 -- index type to refine the range.
4377 Atyp
: Entity_Id
:= Etype
(Prefix
(N
));
4385 if Is_Access_Type
(Atyp
) then
4386 Atyp
:= Designated_Type
(Atyp
);
4389 -- For string literal, we know exact value
4391 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
4393 Lo
:= String_Literal_Length
(Atyp
);
4394 Hi
:= String_Literal_Length
(Atyp
);
4398 -- Otherwise check for expression given
4400 if No
(Expressions
(N
)) then
4404 UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
4407 Indx
:= First_Index
(Atyp
);
4408 for J
in 2 .. Inum
loop
4409 Indx
:= Next_Index
(Indx
);
4412 -- If the index type is a formal type or derived from
4413 -- one, the bounds are not static.
4415 if Is_Generic_Type
(Root_Type
(Etype
(Indx
))) then
4421 (Type_Low_Bound
(Etype
(Indx
)), OK1
, LL
, LU
,
4426 (Type_High_Bound
(Etype
(Indx
)), OK1
, UL
, UU
,
4431 -- The maximum value for Length is the biggest
4432 -- possible gap between the values of the bounds.
4433 -- But of course, this value cannot be negative.
4435 Hir
:= UI_Max
(Uint_0
, UU
- LL
+ 1);
4437 -- For constrained arrays, the minimum value for
4438 -- Length is taken from the actual value of the
4439 -- bounds, since the index will be exactly of this
4442 if Is_Constrained
(Atyp
) then
4443 Lor
:= UI_Max
(Uint_0
, UL
- LU
+ 1);
4445 -- For an unconstrained array, the minimum value
4446 -- for length is always zero.
4455 -- No special handling for other attributes
4456 -- Probably more opportunities exist here???
4463 -- For type conversion from one discrete type to another, we can
4464 -- refine the range using the converted value.
4466 when N_Type_Conversion
=>
4467 Determine_Range
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4469 -- Nothing special to do for all other expression kinds
4477 -- At this stage, if OK1 is true, then we know that the actual result of
4478 -- the computed expression is in the range Lor .. Hir. We can use this
4479 -- to restrict the possible range of results.
4483 -- If the refined value of the low bound is greater than the type
4484 -- high bound, then reset it to the more restrictive value. However,
4485 -- we do NOT do this for the case of a modular type where the
4486 -- possible upper bound on the value is above the base type high
4487 -- bound, because that means the result could wrap.
4490 and then not (Is_Modular_Integer_Type
(Typ
) and then Hir
> Hbound
)
4495 -- Similarly, if the refined value of the high bound is less than the
4496 -- value so far, then reset it to the more restrictive value. Again,
4497 -- we do not do this if the refined low bound is negative for a
4498 -- modular type, since this would wrap.
4501 and then not (Is_Modular_Integer_Type
(Typ
) and then Lor
< Uint_0
)
4507 -- Set cache entry for future call and we are all done
4509 Determine_Range_Cache_N
(Cindex
) := N
;
4510 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
4511 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
4512 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
4515 -- If any exception occurs, it means that we have some bug in the compiler,
4516 -- possibly triggered by a previous error, or by some unforeseen peculiar
4517 -- occurrence. However, this is only an optimization attempt, so there is
4518 -- really no point in crashing the compiler. Instead we just decide, too
4519 -- bad, we can't figure out a range in this case after all.
4524 -- Debug flag K disables this behavior (useful for debugging)
4526 if Debug_Flag_K
then
4534 end Determine_Range
;
4536 ------------------------------------
4537 -- Discriminant_Checks_Suppressed --
4538 ------------------------------------
4540 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4543 if Is_Unchecked_Union
(E
) then
4545 elsif Checks_May_Be_Suppressed
(E
) then
4546 return Is_Check_Suppressed
(E
, Discriminant_Check
);
4550 return Scope_Suppress
.Suppress
(Discriminant_Check
);
4551 end Discriminant_Checks_Suppressed
;
4553 --------------------------------
4554 -- Division_Checks_Suppressed --
4555 --------------------------------
4557 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4559 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4560 return Is_Check_Suppressed
(E
, Division_Check
);
4562 return Scope_Suppress
.Suppress
(Division_Check
);
4564 end Division_Checks_Suppressed
;
4566 -----------------------------------
4567 -- Elaboration_Checks_Suppressed --
4568 -----------------------------------
4570 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4572 -- The complication in this routine is that if we are in the dynamic
4573 -- model of elaboration, we also check All_Checks, since All_Checks
4574 -- does not set Elaboration_Check explicitly.
4577 if Kill_Elaboration_Checks
(E
) then
4580 elsif Checks_May_Be_Suppressed
(E
) then
4581 if Is_Check_Suppressed
(E
, Elaboration_Check
) then
4583 elsif Dynamic_Elaboration_Checks
then
4584 return Is_Check_Suppressed
(E
, All_Checks
);
4591 if Scope_Suppress
.Suppress
(Elaboration_Check
) then
4593 elsif Dynamic_Elaboration_Checks
then
4594 return Scope_Suppress
.Suppress
(All_Checks
);
4598 end Elaboration_Checks_Suppressed
;
4600 ---------------------------
4601 -- Enable_Overflow_Check --
4602 ---------------------------
4604 procedure Enable_Overflow_Check
(N
: Node_Id
) is
4605 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
4606 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
4615 if Debug_Flag_CC
then
4616 w
("Enable_Overflow_Check for node ", Int
(N
));
4617 Write_Str
(" Source location = ");
4622 -- No check if overflow checks suppressed for type of node
4624 if Overflow_Checks_Suppressed
(Etype
(N
)) then
4627 -- Nothing to do for unsigned integer types, which do not overflow
4629 elsif Is_Modular_Integer_Type
(Typ
) then
4633 -- This is the point at which processing for STRICT mode diverges
4634 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
4635 -- probably more extreme that it needs to be, but what is going on here
4636 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
4637 -- to leave the processing for STRICT mode untouched. There were
4638 -- two reasons for this. First it avoided any incompatible change of
4639 -- behavior. Second, it guaranteed that STRICT mode continued to be
4642 -- The big difference is that in STRICT mode there is a fair amount of
4643 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
4644 -- know that no check is needed. We skip all that in the two new modes,
4645 -- since really overflow checking happens over a whole subtree, and we
4646 -- do the corresponding optimizations later on when applying the checks.
4648 if Mode
in Minimized_Or_Eliminated
then
4649 if not (Overflow_Checks_Suppressed
(Etype
(N
)))
4650 and then not (Is_Entity_Name
(N
)
4651 and then Overflow_Checks_Suppressed
(Entity
(N
)))
4653 Activate_Overflow_Check
(N
);
4656 if Debug_Flag_CC
then
4657 w
("Minimized/Eliminated mode");
4663 -- Remainder of processing is for STRICT case, and is unchanged from
4664 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
4666 -- Nothing to do if the range of the result is known OK. We skip this
4667 -- for conversions, since the caller already did the check, and in any
4668 -- case the condition for deleting the check for a type conversion is
4671 if Nkind
(N
) /= N_Type_Conversion
then
4672 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
4674 -- Note in the test below that we assume that the range is not OK
4675 -- if a bound of the range is equal to that of the type. That's not
4676 -- quite accurate but we do this for the following reasons:
4678 -- a) The way that Determine_Range works, it will typically report
4679 -- the bounds of the value as being equal to the bounds of the
4680 -- type, because it either can't tell anything more precise, or
4681 -- does not think it is worth the effort to be more precise.
4683 -- b) It is very unusual to have a situation in which this would
4684 -- generate an unnecessary overflow check (an example would be
4685 -- a subtype with a range 0 .. Integer'Last - 1 to which the
4686 -- literal value one is added).
4688 -- c) The alternative is a lot of special casing in this routine
4689 -- which would partially duplicate Determine_Range processing.
4692 and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
4693 and then Hi
< Expr_Value
(Type_High_Bound
(Typ
))
4695 if Debug_Flag_CC
then
4696 w
("No overflow check required");
4703 -- If not in optimizing mode, set flag and we are done. We are also done
4704 -- (and just set the flag) if the type is not a discrete type, since it
4705 -- is not worth the effort to eliminate checks for other than discrete
4706 -- types. In addition, we take this same path if we have stored the
4707 -- maximum number of checks possible already (a very unlikely situation,
4708 -- but we do not want to blow up).
4710 if Optimization_Level
= 0
4711 or else not Is_Discrete_Type
(Etype
(N
))
4712 or else Num_Saved_Checks
= Saved_Checks
'Last
4714 Activate_Overflow_Check
(N
);
4716 if Debug_Flag_CC
then
4717 w
("Optimization off");
4723 -- Otherwise evaluate and check the expression
4728 Target_Type
=> Empty
,
4734 if Debug_Flag_CC
then
4735 w
("Called Find_Check");
4739 w
(" Check_Num = ", Chk
);
4740 w
(" Ent = ", Int
(Ent
));
4741 Write_Str
(" Ofs = ");
4746 -- If check is not of form to optimize, then set flag and we are done
4749 Activate_Overflow_Check
(N
);
4753 -- If check is already performed, then return without setting flag
4756 if Debug_Flag_CC
then
4757 w
("Check suppressed!");
4763 -- Here we will make a new entry for the new check
4765 Activate_Overflow_Check
(N
);
4766 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
4767 Saved_Checks
(Num_Saved_Checks
) :=
4772 Target_Type
=> Empty
);
4774 if Debug_Flag_CC
then
4775 w
("Make new entry, check number = ", Num_Saved_Checks
);
4776 w
(" Entity = ", Int
(Ent
));
4777 Write_Str
(" Offset = ");
4779 w
(" Check_Type = O");
4780 w
(" Target_Type = Empty");
4783 -- If we get an exception, then something went wrong, probably because of
4784 -- an error in the structure of the tree due to an incorrect program. Or
4785 -- it may be a bug in the optimization circuit. In either case the safest
4786 -- thing is simply to set the check flag unconditionally.
4790 Activate_Overflow_Check
(N
);
4792 if Debug_Flag_CC
then
4793 w
(" exception occurred, overflow flag set");
4797 end Enable_Overflow_Check
;
4799 ------------------------
4800 -- Enable_Range_Check --
4801 ------------------------
4803 procedure Enable_Range_Check
(N
: Node_Id
) is
4812 -- Return if unchecked type conversion with range check killed. In this
4813 -- case we never set the flag (that's what Kill_Range_Check is about).
4815 if Nkind
(N
) = N_Unchecked_Type_Conversion
4816 and then Kill_Range_Check
(N
)
4821 -- Do not set range check flag if parent is assignment statement or
4822 -- object declaration with Suppress_Assignment_Checks flag set
4824 if Nkind_In
(Parent
(N
), N_Assignment_Statement
, N_Object_Declaration
)
4825 and then Suppress_Assignment_Checks
(Parent
(N
))
4830 -- Check for various cases where we should suppress the range check
4832 -- No check if range checks suppressed for type of node
4834 if Present
(Etype
(N
)) and then Range_Checks_Suppressed
(Etype
(N
)) then
4837 -- No check if node is an entity name, and range checks are suppressed
4838 -- for this entity, or for the type of this entity.
4840 elsif Is_Entity_Name
(N
)
4841 and then (Range_Checks_Suppressed
(Entity
(N
))
4842 or else Range_Checks_Suppressed
(Etype
(Entity
(N
))))
4846 -- No checks if index of array, and index checks are suppressed for
4847 -- the array object or the type of the array.
4849 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
then
4851 Pref
: constant Node_Id
:= Prefix
(Parent
(N
));
4853 if Is_Entity_Name
(Pref
)
4854 and then Index_Checks_Suppressed
(Entity
(Pref
))
4857 elsif Index_Checks_Suppressed
(Etype
(Pref
)) then
4863 -- Debug trace output
4865 if Debug_Flag_CC
then
4866 w
("Enable_Range_Check for node ", Int
(N
));
4867 Write_Str
(" Source location = ");
4872 -- If not in optimizing mode, set flag and we are done. We are also done
4873 -- (and just set the flag) if the type is not a discrete type, since it
4874 -- is not worth the effort to eliminate checks for other than discrete
4875 -- types. In addition, we take this same path if we have stored the
4876 -- maximum number of checks possible already (a very unlikely situation,
4877 -- but we do not want to blow up).
4879 if Optimization_Level
= 0
4880 or else No
(Etype
(N
))
4881 or else not Is_Discrete_Type
(Etype
(N
))
4882 or else Num_Saved_Checks
= Saved_Checks
'Last
4884 Activate_Range_Check
(N
);
4886 if Debug_Flag_CC
then
4887 w
("Optimization off");
4893 -- Otherwise find out the target type
4897 -- For assignment, use left side subtype
4899 if Nkind
(P
) = N_Assignment_Statement
4900 and then Expression
(P
) = N
4902 Ttyp
:= Etype
(Name
(P
));
4904 -- For indexed component, use subscript subtype
4906 elsif Nkind
(P
) = N_Indexed_Component
then
4913 Atyp
:= Etype
(Prefix
(P
));
4915 if Is_Access_Type
(Atyp
) then
4916 Atyp
:= Designated_Type
(Atyp
);
4918 -- If the prefix is an access to an unconstrained array,
4919 -- perform check unconditionally: it depends on the bounds of
4920 -- an object and we cannot currently recognize whether the test
4921 -- may be redundant.
4923 if not Is_Constrained
(Atyp
) then
4924 Activate_Range_Check
(N
);
4928 -- Ditto if the prefix is an explicit dereference whose designated
4929 -- type is unconstrained.
4931 elsif Nkind
(Prefix
(P
)) = N_Explicit_Dereference
4932 and then not Is_Constrained
(Atyp
)
4934 Activate_Range_Check
(N
);
4938 Indx
:= First_Index
(Atyp
);
4939 Subs
:= First
(Expressions
(P
));
4942 Ttyp
:= Etype
(Indx
);
4951 -- For now, ignore all other cases, they are not so interesting
4954 if Debug_Flag_CC
then
4955 w
(" target type not found, flag set");
4958 Activate_Range_Check
(N
);
4962 -- Evaluate and check the expression
4967 Target_Type
=> Ttyp
,
4973 if Debug_Flag_CC
then
4974 w
("Called Find_Check");
4975 w
("Target_Typ = ", Int
(Ttyp
));
4979 w
(" Check_Num = ", Chk
);
4980 w
(" Ent = ", Int
(Ent
));
4981 Write_Str
(" Ofs = ");
4986 -- If check is not of form to optimize, then set flag and we are done
4989 if Debug_Flag_CC
then
4990 w
(" expression not of optimizable type, flag set");
4993 Activate_Range_Check
(N
);
4997 -- If check is already performed, then return without setting flag
5000 if Debug_Flag_CC
then
5001 w
("Check suppressed!");
5007 -- Here we will make a new entry for the new check
5009 Activate_Range_Check
(N
);
5010 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
5011 Saved_Checks
(Num_Saved_Checks
) :=
5016 Target_Type
=> Ttyp
);
5018 if Debug_Flag_CC
then
5019 w
("Make new entry, check number = ", Num_Saved_Checks
);
5020 w
(" Entity = ", Int
(Ent
));
5021 Write_Str
(" Offset = ");
5023 w
(" Check_Type = R");
5024 w
(" Target_Type = ", Int
(Ttyp
));
5025 pg
(Union_Id
(Ttyp
));
5028 -- If we get an exception, then something went wrong, probably because of
5029 -- an error in the structure of the tree due to an incorrect program. Or
5030 -- it may be a bug in the optimization circuit. In either case the safest
5031 -- thing is simply to set the check flag unconditionally.
5035 Activate_Range_Check
(N
);
5037 if Debug_Flag_CC
then
5038 w
(" exception occurred, range flag set");
5042 end Enable_Range_Check
;
5048 procedure Ensure_Valid
(Expr
: Node_Id
; Holes_OK
: Boolean := False) is
5049 Typ
: constant Entity_Id
:= Etype
(Expr
);
5052 -- Ignore call if we are not doing any validity checking
5054 if not Validity_Checks_On
then
5057 -- Ignore call if range or validity checks suppressed on entity or type
5059 elsif Range_Or_Validity_Checks_Suppressed
(Expr
) then
5062 -- No check required if expression is from the expander, we assume the
5063 -- expander will generate whatever checks are needed. Note that this is
5064 -- not just an optimization, it avoids infinite recursions.
5066 -- Unchecked conversions must be checked, unless they are initialized
5067 -- scalar values, as in a component assignment in an init proc.
5069 -- In addition, we force a check if Force_Validity_Checks is set
5071 elsif not Comes_From_Source
(Expr
)
5072 and then not Force_Validity_Checks
5073 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
5074 or else Kill_Range_Check
(Expr
))
5078 -- No check required if expression is known to have valid value
5080 elsif Expr_Known_Valid
(Expr
) then
5083 -- Ignore case of enumeration with holes where the flag is set not to
5084 -- worry about holes, since no special validity check is needed
5086 elsif Is_Enumeration_Type
(Typ
)
5087 and then Has_Non_Standard_Rep
(Typ
)
5092 -- No check required on the left-hand side of an assignment
5094 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
5095 and then Expr
= Name
(Parent
(Expr
))
5099 -- No check on a universal real constant. The context will eventually
5100 -- convert it to a machine number for some target type, or report an
5103 elsif Nkind
(Expr
) = N_Real_Literal
5104 and then Etype
(Expr
) = Universal_Real
5108 -- If the expression denotes a component of a packed boolean array,
5109 -- no possible check applies. We ignore the old ACATS chestnuts that
5110 -- involve Boolean range True..True.
5112 -- Note: validity checks are generated for expressions that yield a
5113 -- scalar type, when it is possible to create a value that is outside of
5114 -- the type. If this is a one-bit boolean no such value exists. This is
5115 -- an optimization, and it also prevents compiler blowing up during the
5116 -- elaboration of improperly expanded packed array references.
5118 elsif Nkind
(Expr
) = N_Indexed_Component
5119 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Expr
)))
5120 and then Root_Type
(Etype
(Expr
)) = Standard_Boolean
5124 -- For an expression with actions, we want to insert the validity check
5125 -- on the final Expression.
5127 elsif Nkind
(Expr
) = N_Expression_With_Actions
then
5128 Ensure_Valid
(Expression
(Expr
));
5131 -- An annoying special case. If this is an out parameter of a scalar
5132 -- type, then the value is not going to be accessed, therefore it is
5133 -- inappropriate to do any validity check at the call site.
5136 -- Only need to worry about scalar types
5138 if Is_Scalar_Type
(Typ
) then
5148 -- Find actual argument (which may be a parameter association)
5149 -- and the parent of the actual argument (the call statement)
5154 if Nkind
(P
) = N_Parameter_Association
then
5159 -- Only need to worry if we are argument of a procedure call
5160 -- since functions don't have out parameters. If this is an
5161 -- indirect or dispatching call, get signature from the
5164 if Nkind
(P
) = N_Procedure_Call_Statement
then
5165 L
:= Parameter_Associations
(P
);
5167 if Is_Entity_Name
(Name
(P
)) then
5168 E
:= Entity
(Name
(P
));
5170 pragma Assert
(Nkind
(Name
(P
)) = N_Explicit_Dereference
);
5171 E
:= Etype
(Name
(P
));
5174 -- Only need to worry if there are indeed actuals, and if
5175 -- this could be a procedure call, otherwise we cannot get a
5176 -- match (either we are not an argument, or the mode of the
5177 -- formal is not OUT). This test also filters out the
5180 if Is_Non_Empty_List
(L
) and then Is_Subprogram
(E
) then
5182 -- This is the loop through parameters, looking for an
5183 -- OUT parameter for which we are the argument.
5185 F
:= First_Formal
(E
);
5187 while Present
(F
) loop
5188 if Ekind
(F
) = E_Out_Parameter
and then A
= N
then
5201 -- If this is a boolean expression, only its elementary operands need
5202 -- checking: if they are valid, a boolean or short-circuit operation
5203 -- with them will be valid as well.
5205 if Base_Type
(Typ
) = Standard_Boolean
5207 (Nkind
(Expr
) in N_Op
or else Nkind
(Expr
) in N_Short_Circuit
)
5212 -- If we fall through, a validity check is required
5214 Insert_Valid_Check
(Expr
);
5216 if Is_Entity_Name
(Expr
)
5217 and then Safe_To_Capture_Value
(Expr
, Entity
(Expr
))
5219 Set_Is_Known_Valid
(Entity
(Expr
));
5223 ----------------------
5224 -- Expr_Known_Valid --
5225 ----------------------
5227 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
5228 Typ
: constant Entity_Id
:= Etype
(Expr
);
5231 -- Non-scalar types are always considered valid, since they never give
5232 -- rise to the issues of erroneous or bounded error behavior that are
5233 -- the concern. In formal reference manual terms the notion of validity
5234 -- only applies to scalar types. Note that even when packed arrays are
5235 -- represented using modular types, they are still arrays semantically,
5236 -- so they are also always valid (in particular, the unused bits can be
5237 -- random rubbish without affecting the validity of the array value).
5239 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Type
(Typ
) then
5242 -- If no validity checking, then everything is considered valid
5244 elsif not Validity_Checks_On
then
5247 -- Floating-point types are considered valid unless floating-point
5248 -- validity checks have been specifically turned on.
5250 elsif Is_Floating_Point_Type
(Typ
)
5251 and then not Validity_Check_Floating_Point
5255 -- If the expression is the value of an object that is known to be
5256 -- valid, then clearly the expression value itself is valid.
5258 elsif Is_Entity_Name
(Expr
)
5259 and then Is_Known_Valid
(Entity
(Expr
))
5261 -- Exclude volatile variables
5263 and then not Treat_As_Volatile
(Entity
(Expr
))
5267 -- References to discriminants are always considered valid. The value
5268 -- of a discriminant gets checked when the object is built. Within the
5269 -- record, we consider it valid, and it is important to do so, since
5270 -- otherwise we can try to generate bogus validity checks which
5271 -- reference discriminants out of scope. Discriminants of concurrent
5272 -- types are excluded for the same reason.
5274 elsif Is_Entity_Name
(Expr
)
5275 and then Denotes_Discriminant
(Expr
, Check_Concurrent
=> True)
5279 -- If the type is one for which all values are known valid, then we are
5280 -- sure that the value is valid except in the slightly odd case where
5281 -- the expression is a reference to a variable whose size has been
5282 -- explicitly set to a value greater than the object size.
5284 elsif Is_Known_Valid
(Typ
) then
5285 if Is_Entity_Name
(Expr
)
5286 and then Ekind
(Entity
(Expr
)) = E_Variable
5287 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
5294 -- Integer and character literals always have valid values, where
5295 -- appropriate these will be range checked in any case.
5297 elsif Nkind_In
(Expr
, N_Integer_Literal
, N_Character_Literal
) then
5300 -- Real literals are assumed to be valid in VM targets
5302 elsif VM_Target
/= No_VM
and then Nkind
(Expr
) = N_Real_Literal
then
5305 -- If we have a type conversion or a qualification of a known valid
5306 -- value, then the result will always be valid.
5308 elsif Nkind_In
(Expr
, N_Type_Conversion
, N_Qualified_Expression
) then
5309 return Expr_Known_Valid
(Expression
(Expr
));
5311 -- Case of expression is a non-floating-point operator. In this case we
5312 -- can assume the result is valid the generated code for the operator
5313 -- will include whatever checks are needed (e.g. range checks) to ensure
5314 -- validity. This assumption does not hold for the floating-point case,
5315 -- since floating-point operators can generate Infinite or NaN results
5316 -- which are considered invalid.
5318 -- Historical note: in older versions, the exemption of floating-point
5319 -- types from this assumption was done only in cases where the parent
5320 -- was an assignment, function call or parameter association. Presumably
5321 -- the idea was that in other contexts, the result would be checked
5322 -- elsewhere, but this list of cases was missing tests (at least the
5323 -- N_Object_Declaration case, as shown by a reported missing validity
5324 -- check), and it is not clear why function calls but not procedure
5325 -- calls were tested for. It really seems more accurate and much
5326 -- safer to recognize that expressions which are the result of a
5327 -- floating-point operator can never be assumed to be valid.
5329 elsif Nkind
(Expr
) in N_Op
and then not Is_Floating_Point_Type
(Typ
) then
5332 -- The result of a membership test is always valid, since it is true or
5333 -- false, there are no other possibilities.
5335 elsif Nkind
(Expr
) in N_Membership_Test
then
5338 -- For all other cases, we do not know the expression is valid
5343 end Expr_Known_Valid
;
5349 procedure Find_Check
5351 Check_Type
: Character;
5352 Target_Type
: Entity_Id
;
5353 Entry_OK
: out Boolean;
5354 Check_Num
: out Nat
;
5355 Ent
: out Entity_Id
;
5358 function Within_Range_Of
5359 (Target_Type
: Entity_Id
;
5360 Check_Type
: Entity_Id
) return Boolean;
5361 -- Given a requirement for checking a range against Target_Type, and
5362 -- and a range Check_Type against which a check has already been made,
5363 -- determines if the check against check type is sufficient to ensure
5364 -- that no check against Target_Type is required.
5366 ---------------------
5367 -- Within_Range_Of --
5368 ---------------------
5370 function Within_Range_Of
5371 (Target_Type
: Entity_Id
;
5372 Check_Type
: Entity_Id
) return Boolean
5375 if Target_Type
= Check_Type
then
5380 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
5381 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
5382 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
5383 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
5387 or else (Compile_Time_Known_Value
(Tlo
)
5389 Compile_Time_Known_Value
(Clo
)
5391 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
5394 or else (Compile_Time_Known_Value
(Thi
)
5396 Compile_Time_Known_Value
(Chi
)
5398 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
5406 end Within_Range_Of
;
5408 -- Start of processing for Find_Check
5411 -- Establish default, in case no entry is found
5415 -- Case of expression is simple entity reference
5417 if Is_Entity_Name
(Expr
) then
5418 Ent
:= Entity
(Expr
);
5421 -- Case of expression is entity + known constant
5423 elsif Nkind
(Expr
) = N_Op_Add
5424 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
5425 and then Is_Entity_Name
(Left_Opnd
(Expr
))
5427 Ent
:= Entity
(Left_Opnd
(Expr
));
5428 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
5430 -- Case of expression is entity - known constant
5432 elsif Nkind
(Expr
) = N_Op_Subtract
5433 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
5434 and then Is_Entity_Name
(Left_Opnd
(Expr
))
5436 Ent
:= Entity
(Left_Opnd
(Expr
));
5437 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
5439 -- Any other expression is not of the right form
5448 -- Come here with expression of appropriate form, check if entity is an
5449 -- appropriate one for our purposes.
5451 if (Ekind
(Ent
) = E_Variable
5452 or else Is_Constant_Object
(Ent
))
5453 and then not Is_Library_Level_Entity
(Ent
)
5461 -- See if there is matching check already
5463 for J
in reverse 1 .. Num_Saved_Checks
loop
5465 SC
: Saved_Check
renames Saved_Checks
(J
);
5467 if SC
.Killed
= False
5468 and then SC
.Entity
= Ent
5469 and then SC
.Offset
= Ofs
5470 and then SC
.Check_Type
= Check_Type
5471 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
5479 -- If we fall through entry was not found
5484 ---------------------------------
5485 -- Generate_Discriminant_Check --
5486 ---------------------------------
5488 -- Note: the code for this procedure is derived from the
5489 -- Emit_Discriminant_Check Routine in trans.c.
5491 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
5492 Loc
: constant Source_Ptr
:= Sloc
(N
);
5493 Pref
: constant Node_Id
:= Prefix
(N
);
5494 Sel
: constant Node_Id
:= Selector_Name
(N
);
5496 Orig_Comp
: constant Entity_Id
:=
5497 Original_Record_Component
(Entity
(Sel
));
5498 -- The original component to be checked
5500 Discr_Fct
: constant Entity_Id
:=
5501 Discriminant_Checking_Func
(Orig_Comp
);
5502 -- The discriminant checking function
5505 -- One discriminant to be checked in the type
5507 Real_Discr
: Entity_Id
;
5508 -- Actual discriminant in the call
5510 Pref_Type
: Entity_Id
;
5511 -- Type of relevant prefix (ignoring private/access stuff)
5514 -- List of arguments for function call
5517 -- Keep track of the formal corresponding to the actual we build for
5518 -- each discriminant, in order to be able to perform the necessary type
5522 -- Selected component reference for checking function argument
5525 Pref_Type
:= Etype
(Pref
);
5527 -- Force evaluation of the prefix, so that it does not get evaluated
5528 -- twice (once for the check, once for the actual reference). Such a
5529 -- double evaluation is always a potential source of inefficiency, and
5530 -- is functionally incorrect in the volatile case, or when the prefix
5531 -- may have side-effects. A non-volatile entity or a component of a
5532 -- non-volatile entity requires no evaluation.
5534 if Is_Entity_Name
(Pref
) then
5535 if Treat_As_Volatile
(Entity
(Pref
)) then
5536 Force_Evaluation
(Pref
, Name_Req
=> True);
5539 elsif Treat_As_Volatile
(Etype
(Pref
)) then
5540 Force_Evaluation
(Pref
, Name_Req
=> True);
5542 elsif Nkind
(Pref
) = N_Selected_Component
5543 and then Is_Entity_Name
(Prefix
(Pref
))
5548 Force_Evaluation
(Pref
, Name_Req
=> True);
5551 -- For a tagged type, use the scope of the original component to
5552 -- obtain the type, because ???
5554 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
5555 Pref_Type
:= Scope
(Orig_Comp
);
5557 -- For an untagged derived type, use the discriminants of the parent
5558 -- which have been renamed in the derivation, possibly by a one-to-many
5559 -- discriminant constraint. For non-tagged type, initially get the Etype
5563 if Is_Derived_Type
(Pref_Type
)
5564 and then Number_Discriminants
(Pref_Type
) /=
5565 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
5567 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
5571 -- We definitely should have a checking function, This routine should
5572 -- not be called if no discriminant checking function is present.
5574 pragma Assert
(Present
(Discr_Fct
));
5576 -- Create the list of the actual parameters for the call. This list
5577 -- is the list of the discriminant fields of the record expression to
5578 -- be discriminant checked.
5581 Formal
:= First_Formal
(Discr_Fct
);
5582 Discr
:= First_Discriminant
(Pref_Type
);
5583 while Present
(Discr
) loop
5585 -- If we have a corresponding discriminant field, and a parent
5586 -- subtype is present, then we want to use the corresponding
5587 -- discriminant since this is the one with the useful value.
5589 if Present
(Corresponding_Discriminant
(Discr
))
5590 and then Ekind
(Pref_Type
) = E_Record_Type
5591 and then Present
(Parent_Subtype
(Pref_Type
))
5593 Real_Discr
:= Corresponding_Discriminant
(Discr
);
5595 Real_Discr
:= Discr
;
5598 -- Construct the reference to the discriminant
5601 Make_Selected_Component
(Loc
,
5603 Unchecked_Convert_To
(Pref_Type
,
5604 Duplicate_Subexpr
(Pref
)),
5605 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
5607 -- Manually analyze and resolve this selected component. We really
5608 -- want it just as it appears above, and do not want the expander
5609 -- playing discriminal games etc with this reference. Then we append
5610 -- the argument to the list we are gathering.
5612 Set_Etype
(Scomp
, Etype
(Real_Discr
));
5613 Set_Analyzed
(Scomp
, True);
5614 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
5616 Next_Formal_With_Extras
(Formal
);
5617 Next_Discriminant
(Discr
);
5620 -- Now build and insert the call
5623 Make_Raise_Constraint_Error
(Loc
,
5625 Make_Function_Call
(Loc
,
5626 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
5627 Parameter_Associations
=> Args
),
5628 Reason
=> CE_Discriminant_Check_Failed
));
5629 end Generate_Discriminant_Check
;
5631 ---------------------------
5632 -- Generate_Index_Checks --
5633 ---------------------------
5635 procedure Generate_Index_Checks
(N
: Node_Id
) is
5637 function Entity_Of_Prefix
return Entity_Id
;
5638 -- Returns the entity of the prefix of N (or Empty if not found)
5640 ----------------------
5641 -- Entity_Of_Prefix --
5642 ----------------------
5644 function Entity_Of_Prefix
return Entity_Id
is
5649 while not Is_Entity_Name
(P
) loop
5650 if not Nkind_In
(P
, N_Selected_Component
,
5651 N_Indexed_Component
)
5660 end Entity_Of_Prefix
;
5664 Loc
: constant Source_Ptr
:= Sloc
(N
);
5665 A
: constant Node_Id
:= Prefix
(N
);
5666 A_Ent
: constant Entity_Id
:= Entity_Of_Prefix
;
5669 -- Start of processing for Generate_Index_Checks
5672 -- Ignore call if the prefix is not an array since we have a serious
5673 -- error in the sources. Ignore it also if index checks are suppressed
5674 -- for array object or type.
5676 if not Is_Array_Type
(Etype
(A
))
5677 or else (Present
(A_Ent
) and then Index_Checks_Suppressed
(A_Ent
))
5678 or else Index_Checks_Suppressed
(Etype
(A
))
5682 -- The indexed component we are dealing with contains 'Loop_Entry in its
5683 -- prefix. This case arises when analysis has determined that constructs
5686 -- Prefix'Loop_Entry (Expr)
5687 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
5689 -- require rewriting for error detection purposes. A side effect of this
5690 -- action is the generation of index checks that mention 'Loop_Entry.
5691 -- Delay the generation of the check until 'Loop_Entry has been properly
5692 -- expanded. This is done in Expand_Loop_Entry_Attributes.
5694 elsif Nkind
(Prefix
(N
)) = N_Attribute_Reference
5695 and then Attribute_Name
(Prefix
(N
)) = Name_Loop_Entry
5700 -- Generate a raise of constraint error with the appropriate reason and
5701 -- a condition of the form:
5703 -- Base_Type (Sub) not in Array'Range (Subscript)
5705 -- Note that the reason we generate the conversion to the base type here
5706 -- is that we definitely want the range check to take place, even if it
5707 -- looks like the subtype is OK. Optimization considerations that allow
5708 -- us to omit the check have already been taken into account in the
5709 -- setting of the Do_Range_Check flag earlier on.
5711 Sub
:= First
(Expressions
(N
));
5713 -- Handle string literals
5715 if Ekind
(Etype
(A
)) = E_String_Literal_Subtype
then
5716 if Do_Range_Check
(Sub
) then
5717 Set_Do_Range_Check
(Sub
, False);
5719 -- For string literals we obtain the bounds of the string from the
5720 -- associated subtype.
5723 Make_Raise_Constraint_Error
(Loc
,
5727 Convert_To
(Base_Type
(Etype
(Sub
)),
5728 Duplicate_Subexpr_Move_Checks
(Sub
)),
5730 Make_Attribute_Reference
(Loc
,
5731 Prefix
=> New_Reference_To
(Etype
(A
), Loc
),
5732 Attribute_Name
=> Name_Range
)),
5733 Reason
=> CE_Index_Check_Failed
));
5740 A_Idx
: Node_Id
:= Empty
;
5747 A_Idx
:= First_Index
(Etype
(A
));
5749 while Present
(Sub
) loop
5750 if Do_Range_Check
(Sub
) then
5751 Set_Do_Range_Check
(Sub
, False);
5753 -- Force evaluation except for the case of a simple name of
5754 -- a non-volatile entity.
5756 if not Is_Entity_Name
(Sub
)
5757 or else Treat_As_Volatile
(Entity
(Sub
))
5759 Force_Evaluation
(Sub
);
5762 if Nkind
(A_Idx
) = N_Range
then
5765 elsif Nkind
(A_Idx
) = N_Identifier
5766 or else Nkind
(A_Idx
) = N_Expanded_Name
5768 A_Range
:= Scalar_Range
(Entity
(A_Idx
));
5770 else pragma Assert
(Nkind
(A_Idx
) = N_Subtype_Indication
);
5771 A_Range
:= Range_Expression
(Constraint
(A_Idx
));
5774 -- For array objects with constant bounds we can generate
5775 -- the index check using the bounds of the type of the index
5778 and then Ekind
(A_Ent
) = E_Variable
5779 and then Is_Constant_Bound
(Low_Bound
(A_Range
))
5780 and then Is_Constant_Bound
(High_Bound
(A_Range
))
5783 Make_Attribute_Reference
(Loc
,
5785 New_Reference_To
(Etype
(A_Idx
), Loc
),
5786 Attribute_Name
=> Name_Range
);
5788 -- For arrays with non-constant bounds we cannot generate
5789 -- the index check using the bounds of the type of the index
5790 -- since it may reference discriminants of some enclosing
5791 -- type. We obtain the bounds directly from the prefix
5798 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
5802 Make_Attribute_Reference
(Loc
,
5804 Duplicate_Subexpr_Move_Checks
(A
, Name_Req
=> True),
5805 Attribute_Name
=> Name_Range
,
5806 Expressions
=> Num
);
5810 Make_Raise_Constraint_Error
(Loc
,
5814 Convert_To
(Base_Type
(Etype
(Sub
)),
5815 Duplicate_Subexpr_Move_Checks
(Sub
)),
5816 Right_Opnd
=> Range_N
),
5817 Reason
=> CE_Index_Check_Failed
));
5820 A_Idx
:= Next_Index
(A_Idx
);
5826 end Generate_Index_Checks
;
5828 --------------------------
5829 -- Generate_Range_Check --
5830 --------------------------
5832 procedure Generate_Range_Check
5834 Target_Type
: Entity_Id
;
5835 Reason
: RT_Exception_Code
)
5837 Loc
: constant Source_Ptr
:= Sloc
(N
);
5838 Source_Type
: constant Entity_Id
:= Etype
(N
);
5839 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
5840 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
5843 -- First special case, if the source type is already within the range
5844 -- of the target type, then no check is needed (probably we should have
5845 -- stopped Do_Range_Check from being set in the first place, but better
5846 -- late than never in preventing junk code.
5848 if In_Subrange_Of
(Source_Type
, Target_Type
)
5850 -- We do NOT apply this if the source node is a literal, since in this
5851 -- case the literal has already been labeled as having the subtype of
5855 (Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
, N_Character_Literal
)
5858 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
5860 -- Also do not apply this for floating-point if Check_Float_Overflow
5863 (Is_Floating_Point_Type
(Source_Type
) and Check_Float_Overflow
)
5868 -- We need a check, so force evaluation of the node, so that it does
5869 -- not get evaluated twice (once for the check, once for the actual
5870 -- reference). Such a double evaluation is always a potential source
5871 -- of inefficiency, and is functionally incorrect in the volatile case.
5873 if not Is_Entity_Name
(N
) or else Treat_As_Volatile
(Entity
(N
)) then
5874 Force_Evaluation
(N
);
5877 -- The easiest case is when Source_Base_Type and Target_Base_Type are
5878 -- the same since in this case we can simply do a direct check of the
5879 -- value of N against the bounds of Target_Type.
5881 -- [constraint_error when N not in Target_Type]
5883 -- Note: this is by far the most common case, for example all cases of
5884 -- checks on the RHS of assignments are in this category, but not all
5885 -- cases are like this. Notably conversions can involve two types.
5887 if Source_Base_Type
= Target_Base_Type
then
5889 Make_Raise_Constraint_Error
(Loc
,
5892 Left_Opnd
=> Duplicate_Subexpr
(N
),
5893 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
5896 -- Next test for the case where the target type is within the bounds
5897 -- of the base type of the source type, since in this case we can
5898 -- simply convert these bounds to the base type of T to do the test.
5900 -- [constraint_error when N not in
5901 -- Source_Base_Type (Target_Type'First)
5903 -- Source_Base_Type(Target_Type'Last))]
5905 -- The conversions will always work and need no check
5907 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
5908 -- of converting from an enumeration value to an integer type, such as
5909 -- occurs for the case of generating a range check on Enum'Val(Exp)
5910 -- (which used to be handled by gigi). This is OK, since the conversion
5911 -- itself does not require a check.
5913 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
5915 Make_Raise_Constraint_Error
(Loc
,
5918 Left_Opnd
=> Duplicate_Subexpr
(N
),
5923 Unchecked_Convert_To
(Source_Base_Type
,
5924 Make_Attribute_Reference
(Loc
,
5926 New_Occurrence_Of
(Target_Type
, Loc
),
5927 Attribute_Name
=> Name_First
)),
5930 Unchecked_Convert_To
(Source_Base_Type
,
5931 Make_Attribute_Reference
(Loc
,
5933 New_Occurrence_Of
(Target_Type
, Loc
),
5934 Attribute_Name
=> Name_Last
)))),
5937 -- Note that at this stage we now that the Target_Base_Type is not in
5938 -- the range of the Source_Base_Type (since even the Target_Type itself
5939 -- is not in this range). It could still be the case that Source_Type is
5940 -- in range of the target base type since we have not checked that case.
5942 -- If that is the case, we can freely convert the source to the target,
5943 -- and then test the target result against the bounds.
5945 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
5947 -- We make a temporary to hold the value of the converted value
5948 -- (converted to the base type), and then we will do the test against
5951 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
5952 -- [constraint_error when Tnn not in Target_Type]
5954 -- Then the conversion itself is replaced by an occurrence of Tnn
5957 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
5960 Insert_Actions
(N
, New_List
(
5961 Make_Object_Declaration
(Loc
,
5962 Defining_Identifier
=> Tnn
,
5963 Object_Definition
=>
5964 New_Occurrence_Of
(Target_Base_Type
, Loc
),
5965 Constant_Present
=> True,
5967 Make_Type_Conversion
(Loc
,
5968 Subtype_Mark
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
5969 Expression
=> Duplicate_Subexpr
(N
))),
5971 Make_Raise_Constraint_Error
(Loc
,
5974 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
5975 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
5977 Reason
=> Reason
)));
5979 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
5981 -- Set the type of N, because the declaration for Tnn might not
5982 -- be analyzed yet, as is the case if N appears within a record
5983 -- declaration, as a discriminant constraint or expression.
5985 Set_Etype
(N
, Target_Base_Type
);
5988 -- At this stage, we know that we have two scalar types, which are
5989 -- directly convertible, and where neither scalar type has a base
5990 -- range that is in the range of the other scalar type.
5992 -- The only way this can happen is with a signed and unsigned type.
5993 -- So test for these two cases:
5996 -- Case of the source is unsigned and the target is signed
5998 if Is_Unsigned_Type
(Source_Base_Type
)
5999 and then not Is_Unsigned_Type
(Target_Base_Type
)
6001 -- If the source is unsigned and the target is signed, then we
6002 -- know that the source is not shorter than the target (otherwise
6003 -- the source base type would be in the target base type range).
6005 -- In other words, the unsigned type is either the same size as
6006 -- the target, or it is larger. It cannot be smaller.
6009 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
6011 -- We only need to check the low bound if the low bound of the
6012 -- target type is non-negative. If the low bound of the target
6013 -- type is negative, then we know that we will fit fine.
6015 -- If the high bound of the target type is negative, then we
6016 -- know we have a constraint error, since we can't possibly
6017 -- have a negative source.
6019 -- With these two checks out of the way, we can do the check
6020 -- using the source type safely
6022 -- This is definitely the most annoying case.
6024 -- [constraint_error
6025 -- when (Target_Type'First >= 0
6027 -- N < Source_Base_Type (Target_Type'First))
6028 -- or else Target_Type'Last < 0
6029 -- or else N > Source_Base_Type (Target_Type'Last)];
6031 -- We turn off all checks since we know that the conversions
6032 -- will work fine, given the guards for negative values.
6035 Make_Raise_Constraint_Error
(Loc
,
6041 Left_Opnd
=> Make_Op_Ge
(Loc
,
6043 Make_Attribute_Reference
(Loc
,
6045 New_Occurrence_Of
(Target_Type
, Loc
),
6046 Attribute_Name
=> Name_First
),
6047 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
6051 Left_Opnd
=> Duplicate_Subexpr
(N
),
6053 Convert_To
(Source_Base_Type
,
6054 Make_Attribute_Reference
(Loc
,
6056 New_Occurrence_Of
(Target_Type
, Loc
),
6057 Attribute_Name
=> Name_First
)))),
6062 Make_Attribute_Reference
(Loc
,
6063 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
6064 Attribute_Name
=> Name_Last
),
6065 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
6069 Left_Opnd
=> Duplicate_Subexpr
(N
),
6071 Convert_To
(Source_Base_Type
,
6072 Make_Attribute_Reference
(Loc
,
6073 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
6074 Attribute_Name
=> Name_Last
)))),
6077 Suppress
=> All_Checks
);
6079 -- Only remaining possibility is that the source is signed and
6080 -- the target is unsigned.
6083 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
6084 and then Is_Unsigned_Type
(Target_Base_Type
));
6086 -- If the source is signed and the target is unsigned, then we
6087 -- know that the target is not shorter than the source (otherwise
6088 -- the target base type would be in the source base type range).
6090 -- In other words, the unsigned type is either the same size as
6091 -- the target, or it is larger. It cannot be smaller.
6093 -- Clearly we have an error if the source value is negative since
6094 -- no unsigned type can have negative values. If the source type
6095 -- is non-negative, then the check can be done using the target
6098 -- Tnn : constant Target_Base_Type (N) := Target_Type;
6100 -- [constraint_error
6101 -- when N < 0 or else Tnn not in Target_Type];
6103 -- We turn off all checks for the conversion of N to the target
6104 -- base type, since we generate the explicit check to ensure that
6105 -- the value is non-negative
6108 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
6111 Insert_Actions
(N
, New_List
(
6112 Make_Object_Declaration
(Loc
,
6113 Defining_Identifier
=> Tnn
,
6114 Object_Definition
=>
6115 New_Occurrence_Of
(Target_Base_Type
, Loc
),
6116 Constant_Present
=> True,
6118 Make_Unchecked_Type_Conversion
(Loc
,
6120 New_Occurrence_Of
(Target_Base_Type
, Loc
),
6121 Expression
=> Duplicate_Subexpr
(N
))),
6123 Make_Raise_Constraint_Error
(Loc
,
6128 Left_Opnd
=> Duplicate_Subexpr
(N
),
6129 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
6133 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
6135 New_Occurrence_Of
(Target_Type
, Loc
))),
6138 Suppress
=> All_Checks
);
6140 -- Set the Etype explicitly, because Insert_Actions may have
6141 -- placed the declaration in the freeze list for an enclosing
6142 -- construct, and thus it is not analyzed yet.
6144 Set_Etype
(Tnn
, Target_Base_Type
);
6145 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
6149 end Generate_Range_Check
;
6155 function Get_Check_Id
(N
: Name_Id
) return Check_Id
is
6157 -- For standard check name, we can do a direct computation
6159 if N
in First_Check_Name
.. Last_Check_Name
then
6160 return Check_Id
(N
- (First_Check_Name
- 1));
6162 -- For non-standard names added by pragma Check_Name, search table
6165 for J
in All_Checks
+ 1 .. Check_Names
.Last
loop
6166 if Check_Names
.Table
(J
) = N
then
6172 -- No matching name found
6177 ---------------------
6178 -- Get_Discriminal --
6179 ---------------------
6181 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
6182 Loc
: constant Source_Ptr
:= Sloc
(E
);
6187 -- The bound can be a bona fide parameter of a protected operation,
6188 -- rather than a prival encoded as an in-parameter.
6190 if No
(Discriminal_Link
(Entity
(Bound
))) then
6194 -- Climb the scope stack looking for an enclosing protected type. If
6195 -- we run out of scopes, return the bound itself.
6198 while Present
(Sc
) loop
6199 if Sc
= Standard_Standard
then
6201 elsif Ekind
(Sc
) = E_Protected_Type
then
6208 D
:= First_Discriminant
(Sc
);
6209 while Present
(D
) loop
6210 if Chars
(D
) = Chars
(Bound
) then
6211 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
6214 Next_Discriminant
(D
);
6218 end Get_Discriminal
;
6220 ----------------------
6221 -- Get_Range_Checks --
6222 ----------------------
6224 function Get_Range_Checks
6226 Target_Typ
: Entity_Id
;
6227 Source_Typ
: Entity_Id
:= Empty
;
6228 Warn_Node
: Node_Id
:= Empty
) return Check_Result
6232 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Warn_Node
);
6233 end Get_Range_Checks
;
6239 function Guard_Access
6242 Ck_Node
: Node_Id
) return Node_Id
6245 if Nkind
(Cond
) = N_Or_Else
then
6246 Set_Paren_Count
(Cond
, 1);
6249 if Nkind
(Ck_Node
) = N_Allocator
then
6257 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
6258 Right_Opnd
=> Make_Null
(Loc
)),
6259 Right_Opnd
=> Cond
);
6263 -----------------------------
6264 -- Index_Checks_Suppressed --
6265 -----------------------------
6267 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6269 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6270 return Is_Check_Suppressed
(E
, Index_Check
);
6272 return Scope_Suppress
.Suppress
(Index_Check
);
6274 end Index_Checks_Suppressed
;
6280 procedure Initialize
is
6282 for J
in Determine_Range_Cache_N
'Range loop
6283 Determine_Range_Cache_N
(J
) := Empty
;
6288 for J
in Int
range 1 .. All_Checks
loop
6289 Check_Names
.Append
(Name_Id
(Int
(First_Check_Name
) + J
- 1));
6293 -------------------------
6294 -- Insert_Range_Checks --
6295 -------------------------
6297 procedure Insert_Range_Checks
6298 (Checks
: Check_Result
;
6300 Suppress_Typ
: Entity_Id
;
6301 Static_Sloc
: Source_Ptr
:= No_Location
;
6302 Flag_Node
: Node_Id
:= Empty
;
6303 Do_Before
: Boolean := False)
6305 Internal_Flag_Node
: Node_Id
:= Flag_Node
;
6306 Internal_Static_Sloc
: Source_Ptr
:= Static_Sloc
;
6308 Check_Node
: Node_Id
;
6309 Checks_On
: constant Boolean :=
6310 (not Index_Checks_Suppressed
(Suppress_Typ
))
6311 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
6314 -- For now we just return if Checks_On is false, however this should be
6315 -- enhanced to check for an always True value in the condition and to
6316 -- generate a compilation warning???
6318 if not Expander_Active
or not Checks_On
then
6322 if Static_Sloc
= No_Location
then
6323 Internal_Static_Sloc
:= Sloc
(Node
);
6326 if No
(Flag_Node
) then
6327 Internal_Flag_Node
:= Node
;
6330 for J
in 1 .. 2 loop
6331 exit when No
(Checks
(J
));
6333 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
6334 and then Present
(Condition
(Checks
(J
)))
6336 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
6337 Check_Node
:= Checks
(J
);
6338 Mark_Rewrite_Insertion
(Check_Node
);
6341 Insert_Before_And_Analyze
(Node
, Check_Node
);
6343 Insert_After_And_Analyze
(Node
, Check_Node
);
6346 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
6351 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
6352 Reason
=> CE_Range_Check_Failed
);
6353 Mark_Rewrite_Insertion
(Check_Node
);
6356 Insert_Before_And_Analyze
(Node
, Check_Node
);
6358 Insert_After_And_Analyze
(Node
, Check_Node
);
6362 end Insert_Range_Checks
;
6364 ------------------------
6365 -- Insert_Valid_Check --
6366 ------------------------
6368 procedure Insert_Valid_Check
(Expr
: Node_Id
) is
6369 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6370 Typ
: constant Entity_Id
:= Etype
(Expr
);
6374 -- Do not insert if checks off, or if not checking validity or
6375 -- if expression is known to be valid
6377 if not Validity_Checks_On
6378 or else Range_Or_Validity_Checks_Suppressed
(Expr
)
6379 or else Expr_Known_Valid
(Expr
)
6384 -- Do not insert checks within a predicate function. This will arise
6385 -- if the current unit and the predicate function are being compiled
6386 -- with validity checks enabled.
6388 if Present
(Predicate_Function
(Typ
))
6389 and then Current_Scope
= Predicate_Function
(Typ
)
6394 -- If we have a checked conversion, then validity check applies to
6395 -- the expression inside the conversion, not the result, since if
6396 -- the expression inside is valid, then so is the conversion result.
6399 while Nkind
(Exp
) = N_Type_Conversion
loop
6400 Exp
:= Expression
(Exp
);
6403 -- We are about to insert the validity check for Exp. We save and
6404 -- reset the Do_Range_Check flag over this validity check, and then
6405 -- put it back for the final original reference (Exp may be rewritten).
6408 DRC
: constant Boolean := Do_Range_Check
(Exp
);
6413 Set_Do_Range_Check
(Exp
, False);
6415 -- Force evaluation to avoid multiple reads for atomic/volatile
6417 if Is_Entity_Name
(Exp
)
6418 and then Is_Volatile
(Entity
(Exp
))
6420 Force_Evaluation
(Exp
, Name_Req
=> True);
6423 -- Build the prefix for the 'Valid call
6425 PV
:= Duplicate_Subexpr_No_Checks
(Exp
, Name_Req
=> True);
6427 -- A rather specialized kludge. If PV is an analyzed expression
6428 -- which is an indexed component of a packed array that has not
6429 -- been properly expanded, turn off its Analyzed flag to make sure
6430 -- it gets properly reexpanded.
6432 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
6433 -- an analyze with the old parent pointer. This may point e.g. to
6434 -- a subprogram call, which deactivates this expansion.
6437 and then Nkind
(PV
) = N_Indexed_Component
6438 and then Present
(Packed_Array_Type
(Etype
(Prefix
(PV
))))
6440 Set_Analyzed
(PV
, False);
6443 -- Build the raise CE node to check for validity
6446 Make_Raise_Constraint_Error
(Loc
,
6450 Make_Attribute_Reference
(Loc
,
6452 Attribute_Name
=> Name_Valid
)),
6453 Reason
=> CE_Invalid_Data
);
6455 -- Insert the validity check. Note that we do this with validity
6456 -- checks turned off, to avoid recursion, we do not want validity
6457 -- checks on the validity checking code itself.
6459 Insert_Action
(Expr
, CE
, Suppress
=> Validity_Check
);
6461 -- If the expression is a reference to an element of a bit-packed
6462 -- array, then it is rewritten as a renaming declaration. If the
6463 -- expression is an actual in a call, it has not been expanded,
6464 -- waiting for the proper point at which to do it. The same happens
6465 -- with renamings, so that we have to force the expansion now. This
6466 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
6469 if Is_Entity_Name
(Exp
)
6470 and then Nkind
(Parent
(Entity
(Exp
))) =
6471 N_Object_Renaming_Declaration
6474 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
6476 if Nkind
(Old_Exp
) = N_Indexed_Component
6477 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
6479 Expand_Packed_Element_Reference
(Old_Exp
);
6484 -- Put back the Do_Range_Check flag on the resulting (possibly
6485 -- rewritten) expression.
6487 -- Note: it might be thought that a validity check is not required
6488 -- when a range check is present, but that's not the case, because
6489 -- the back end is allowed to assume for the range check that the
6490 -- operand is within its declared range (an assumption that validity
6491 -- checking is all about NOT assuming).
6493 -- Note: no need to worry about Possible_Local_Raise here, it will
6494 -- already have been called if original node has Do_Range_Check set.
6496 Set_Do_Range_Check
(Exp
, DRC
);
6498 end Insert_Valid_Check
;
6500 -------------------------------------
6501 -- Is_Signed_Integer_Arithmetic_Op --
6502 -------------------------------------
6504 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean is
6507 when N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
6508 N_Op_Minus | N_Op_Mod | N_Op_Multiply | N_Op_Plus |
6509 N_Op_Rem | N_Op_Subtract
=>
6510 return Is_Signed_Integer_Type
(Etype
(N
));
6512 when N_If_Expression | N_Case_Expression
=>
6513 return Is_Signed_Integer_Type
(Etype
(N
));
6518 end Is_Signed_Integer_Arithmetic_Op
;
6520 ----------------------------------
6521 -- Install_Null_Excluding_Check --
6522 ----------------------------------
6524 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
6525 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
6526 Typ
: constant Entity_Id
:= Etype
(N
);
6528 function Safe_To_Capture_In_Parameter_Value
return Boolean;
6529 -- Determines if it is safe to capture Known_Non_Null status for an
6530 -- the entity referenced by node N. The caller ensures that N is indeed
6531 -- an entity name. It is safe to capture the non-null status for an IN
6532 -- parameter when the reference occurs within a declaration that is sure
6533 -- to be executed as part of the declarative region.
6535 procedure Mark_Non_Null
;
6536 -- After installation of check, if the node in question is an entity
6537 -- name, then mark this entity as non-null if possible.
6539 function Safe_To_Capture_In_Parameter_Value
return Boolean is
6540 E
: constant Entity_Id
:= Entity
(N
);
6541 S
: constant Entity_Id
:= Current_Scope
;
6545 if Ekind
(E
) /= E_In_Parameter
then
6549 -- Two initial context checks. We must be inside a subprogram body
6550 -- with declarations and reference must not appear in nested scopes.
6552 if (Ekind
(S
) /= E_Function
and then Ekind
(S
) /= E_Procedure
)
6553 or else Scope
(E
) /= S
6558 S_Par
:= Parent
(Parent
(S
));
6560 if Nkind
(S_Par
) /= N_Subprogram_Body
6561 or else No
(Declarations
(S_Par
))
6571 -- Retrieve the declaration node of N (if any). Note that N
6572 -- may be a part of a complex initialization expression.
6576 while Present
(P
) loop
6578 -- If we have a short circuit form, and we are within the right
6579 -- hand expression, we return false, since the right hand side
6580 -- is not guaranteed to be elaborated.
6582 if Nkind
(P
) in N_Short_Circuit
6583 and then N
= Right_Opnd
(P
)
6588 -- Similarly, if we are in an if expression and not part of the
6589 -- condition, then we return False, since neither the THEN or
6590 -- ELSE dependent expressions will always be elaborated.
6592 if Nkind
(P
) = N_If_Expression
6593 and then N
/= First
(Expressions
(P
))
6598 -- If within a case expression, and not part of the expression,
6599 -- then return False, since a particular dependent expression
6600 -- may not always be elaborated
6602 if Nkind
(P
) = N_Case_Expression
6603 and then N
/= Expression
(P
)
6608 -- While traversing the parent chain, if node N belongs to a
6609 -- statement, then it may never appear in a declarative region.
6611 if Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
6612 or else Nkind
(P
) = N_Procedure_Call_Statement
6617 -- If we are at a declaration, record it and exit
6619 if Nkind
(P
) in N_Declaration
6620 and then Nkind
(P
) not in N_Subprogram_Specification
6633 return List_Containing
(N_Decl
) = Declarations
(S_Par
);
6635 end Safe_To_Capture_In_Parameter_Value
;
6641 procedure Mark_Non_Null
is
6643 -- Only case of interest is if node N is an entity name
6645 if Is_Entity_Name
(N
) then
6647 -- For sure, we want to clear an indication that this is known to
6648 -- be null, since if we get past this check, it definitely is not.
6650 Set_Is_Known_Null
(Entity
(N
), False);
6652 -- We can mark the entity as known to be non-null if either it is
6653 -- safe to capture the value, or in the case of an IN parameter,
6654 -- which is a constant, if the check we just installed is in the
6655 -- declarative region of the subprogram body. In this latter case,
6656 -- a check is decisive for the rest of the body if the expression
6657 -- is sure to be elaborated, since we know we have to elaborate
6658 -- all declarations before executing the body.
6660 -- Couldn't this always be part of Safe_To_Capture_Value ???
6662 if Safe_To_Capture_Value
(N
, Entity
(N
))
6663 or else Safe_To_Capture_In_Parameter_Value
6665 Set_Is_Known_Non_Null
(Entity
(N
));
6670 -- Start of processing for Install_Null_Excluding_Check
6673 pragma Assert
(Is_Access_Type
(Typ
));
6675 -- No check inside a generic, check will be emitted in instance
6677 if Inside_A_Generic
then
6681 -- No check needed if known to be non-null
6683 if Known_Non_Null
(N
) then
6687 -- If known to be null, here is where we generate a compile time check
6689 if Known_Null
(N
) then
6691 -- Avoid generating warning message inside init procs. In SPARK mode
6692 -- we can go ahead and call Apply_Compile_Time_Constraint_Error
6693 -- since it will be turned into an error in any case.
6695 if (not Inside_Init_Proc
or else SPARK_Mode
= On
)
6697 -- Do not emit the warning within a conditional expression,
6698 -- where the expression might not be evaluated, and the warning
6699 -- appear as extraneous noise.
6701 and then not Within_Case_Or_If_Expression
(N
)
6703 Apply_Compile_Time_Constraint_Error
6704 (N
, "null value not allowed here??", CE_Access_Check_Failed
);
6706 -- Remaining cases, where we silently insert the raise
6710 Make_Raise_Constraint_Error
(Loc
,
6711 Reason
=> CE_Access_Check_Failed
));
6718 -- If entity is never assigned, for sure a warning is appropriate
6720 if Is_Entity_Name
(N
) then
6721 Check_Unset_Reference
(N
);
6724 -- No check needed if checks are suppressed on the range. Note that we
6725 -- don't set Is_Known_Non_Null in this case (we could legitimately do
6726 -- so, since the program is erroneous, but we don't like to casually
6727 -- propagate such conclusions from erroneosity).
6729 if Access_Checks_Suppressed
(Typ
) then
6733 -- No check needed for access to concurrent record types generated by
6734 -- the expander. This is not just an optimization (though it does indeed
6735 -- remove junk checks). It also avoids generation of junk warnings.
6737 if Nkind
(N
) in N_Has_Chars
6738 and then Chars
(N
) = Name_uObject
6739 and then Is_Concurrent_Record_Type
6740 (Directly_Designated_Type
(Etype
(N
)))
6745 -- No check needed in interface thunks since the runtime check is
6746 -- already performed at the caller side.
6748 if Is_Thunk
(Current_Scope
) then
6752 -- No check needed for the Get_Current_Excep.all.all idiom generated by
6753 -- the expander within exception handlers, since we know that the value
6754 -- can never be null.
6756 -- Is this really the right way to do this? Normally we generate such
6757 -- code in the expander with checks off, and that's how we suppress this
6758 -- kind of junk check ???
6760 if Nkind
(N
) = N_Function_Call
6761 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
6762 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
6763 and then Is_RTE
(Entity
(Prefix
(Name
(N
))), RE_Get_Current_Excep
)
6768 -- Otherwise install access check
6771 Make_Raise_Constraint_Error
(Loc
,
6774 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
6775 Right_Opnd
=> Make_Null
(Loc
)),
6776 Reason
=> CE_Access_Check_Failed
));
6779 end Install_Null_Excluding_Check
;
6781 --------------------------
6782 -- Install_Static_Check --
6783 --------------------------
6785 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
6786 Stat
: constant Boolean := Is_Static_Expression
(R_Cno
);
6787 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
6791 Make_Raise_Constraint_Error
(Loc
,
6792 Reason
=> CE_Range_Check_Failed
));
6793 Set_Analyzed
(R_Cno
);
6794 Set_Etype
(R_Cno
, Typ
);
6795 Set_Raises_Constraint_Error
(R_Cno
);
6796 Set_Is_Static_Expression
(R_Cno
, Stat
);
6798 -- Now deal with possible local raise handling
6800 Possible_Local_Raise
(R_Cno
, Standard_Constraint_Error
);
6801 end Install_Static_Check
;
6803 -------------------------
6804 -- Is_Check_Suppressed --
6805 -------------------------
6807 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
6808 Ptr
: Suppress_Stack_Entry_Ptr
;
6811 -- First search the local entity suppress stack. We search this from the
6812 -- top of the stack down so that we get the innermost entry that applies
6813 -- to this case if there are nested entries.
6815 Ptr
:= Local_Suppress_Stack_Top
;
6816 while Ptr
/= null loop
6817 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
6818 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
6820 return Ptr
.Suppress
;
6826 -- Now search the global entity suppress table for a matching entry.
6827 -- We also search this from the top down so that if there are multiple
6828 -- pragmas for the same entity, the last one applies (not clear what
6829 -- or whether the RM specifies this handling, but it seems reasonable).
6831 Ptr
:= Global_Suppress_Stack_Top
;
6832 while Ptr
/= null loop
6833 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
6834 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
6836 return Ptr
.Suppress
;
6842 -- If we did not find a matching entry, then use the normal scope
6843 -- suppress value after all (actually this will be the global setting
6844 -- since it clearly was not overridden at any point). For a predefined
6845 -- check, we test the specific flag. For a user defined check, we check
6846 -- the All_Checks flag. The Overflow flag requires special handling to
6847 -- deal with the General vs Assertion case
6849 if C
= Overflow_Check
then
6850 return Overflow_Checks_Suppressed
(Empty
);
6851 elsif C
in Predefined_Check_Id
then
6852 return Scope_Suppress
.Suppress
(C
);
6854 return Scope_Suppress
.Suppress
(All_Checks
);
6856 end Is_Check_Suppressed
;
6858 ---------------------
6859 -- Kill_All_Checks --
6860 ---------------------
6862 procedure Kill_All_Checks
is
6864 if Debug_Flag_CC
then
6865 w
("Kill_All_Checks");
6868 -- We reset the number of saved checks to zero, and also modify all
6869 -- stack entries for statement ranges to indicate that the number of
6870 -- checks at each level is now zero.
6872 Num_Saved_Checks
:= 0;
6874 -- Note: the Int'Min here avoids any possibility of J being out of
6875 -- range when called from e.g. Conditional_Statements_Begin.
6877 for J
in 1 .. Int
'Min (Saved_Checks_TOS
, Saved_Checks_Stack
'Last) loop
6878 Saved_Checks_Stack
(J
) := 0;
6880 end Kill_All_Checks
;
6886 procedure Kill_Checks
(V
: Entity_Id
) is
6888 if Debug_Flag_CC
then
6889 w
("Kill_Checks for entity", Int
(V
));
6892 for J
in 1 .. Num_Saved_Checks
loop
6893 if Saved_Checks
(J
).Entity
= V
then
6894 if Debug_Flag_CC
then
6895 w
(" Checks killed for saved check ", J
);
6898 Saved_Checks
(J
).Killed
:= True;
6903 ------------------------------
6904 -- Length_Checks_Suppressed --
6905 ------------------------------
6907 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6909 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6910 return Is_Check_Suppressed
(E
, Length_Check
);
6912 return Scope_Suppress
.Suppress
(Length_Check
);
6914 end Length_Checks_Suppressed
;
6916 -----------------------
6917 -- Make_Bignum_Block --
6918 -----------------------
6920 function Make_Bignum_Block
(Loc
: Source_Ptr
) return Node_Id
is
6921 M
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uM
);
6925 Make_Block_Statement
(Loc
,
6926 Declarations
=> New_List
(
6927 Make_Object_Declaration
(Loc
,
6928 Defining_Identifier
=> M
,
6929 Object_Definition
=>
6930 New_Occurrence_Of
(RTE
(RE_Mark_Id
), Loc
),
6932 Make_Function_Call
(Loc
,
6933 Name
=> New_Reference_To
(RTE
(RE_SS_Mark
), Loc
)))),
6935 Handled_Statement_Sequence
=>
6936 Make_Handled_Sequence_Of_Statements
(Loc
,
6937 Statements
=> New_List
(
6938 Make_Procedure_Call_Statement
(Loc
,
6939 Name
=> New_Occurrence_Of
(RTE
(RE_SS_Release
), Loc
),
6940 Parameter_Associations
=> New_List
(
6941 New_Reference_To
(M
, Loc
))))));
6942 end Make_Bignum_Block
;
6944 ----------------------------------
6945 -- Minimize_Eliminate_Overflows --
6946 ----------------------------------
6948 -- This is a recursive routine that is called at the top of an expression
6949 -- tree to properly process overflow checking for a whole subtree by making
6950 -- recursive calls to process operands. This processing may involve the use
6951 -- of bignum or long long integer arithmetic, which will change the types
6952 -- of operands and results. That's why we can't do this bottom up (since
6953 -- it would interfere with semantic analysis).
6955 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
6956 -- the operator expansion routines, as well as the expansion routines for
6957 -- if/case expression, do nothing (for the moment) except call the routine
6958 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
6959 -- routine does nothing for non top-level nodes, so at the point where the
6960 -- call is made for the top level node, the entire expression subtree has
6961 -- not been expanded, or processed for overflow. All that has to happen as
6962 -- a result of the top level call to this routine.
6964 -- As noted above, the overflow processing works by making recursive calls
6965 -- for the operands, and figuring out what to do, based on the processing
6966 -- of these operands (e.g. if a bignum operand appears, the parent op has
6967 -- to be done in bignum mode), and the determined ranges of the operands.
6969 -- After possible rewriting of a constituent subexpression node, a call is
6970 -- made to either reexpand the node (if nothing has changed) or reanalyze
6971 -- the node (if it has been modified by the overflow check processing). The
6972 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
6973 -- a recursive call into the whole overflow apparatus, an important rule
6974 -- for this call is that the overflow handling mode must be temporarily set
6977 procedure Minimize_Eliminate_Overflows
6981 Top_Level
: Boolean)
6983 Rtyp
: constant Entity_Id
:= Etype
(N
);
6984 pragma Assert
(Is_Signed_Integer_Type
(Rtyp
));
6985 -- Result type, must be a signed integer type
6987 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
6988 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
6990 Loc
: constant Source_Ptr
:= Sloc
(N
);
6993 -- Ranges of values for right operand (operator case)
6996 -- Ranges of values for left operand (operator case)
6998 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
6999 -- Operands and results are of this type when we convert
7001 LLLo
: constant Uint
:= Intval
(Type_Low_Bound
(LLIB
));
7002 LLHi
: constant Uint
:= Intval
(Type_High_Bound
(LLIB
));
7003 -- Bounds of Long_Long_Integer
7005 Binary
: constant Boolean := Nkind
(N
) in N_Binary_Op
;
7006 -- Indicates binary operator case
7009 -- Used in call to Determine_Range
7011 Bignum_Operands
: Boolean;
7012 -- Set True if one or more operands is already of type Bignum, meaning
7013 -- that for sure (regardless of Top_Level setting) we are committed to
7014 -- doing the operation in Bignum mode (or in the case of a case or if
7015 -- expression, converting all the dependent expressions to Bignum).
7017 Long_Long_Integer_Operands
: Boolean;
7018 -- Set True if one or more operands is already of type Long_Long_Integer
7019 -- which means that if the result is known to be in the result type
7020 -- range, then we must convert such operands back to the result type.
7022 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False);
7023 -- This is called when we have modified the node and we therefore need
7024 -- to reanalyze it. It is important that we reset the mode to STRICT for
7025 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
7026 -- we would reenter this routine recursively which would not be good.
7027 -- The argument Suppress is set True if we also want to suppress
7028 -- overflow checking for the reexpansion (this is set when we know
7029 -- overflow is not possible). Typ is the type for the reanalysis.
7031 procedure Reexpand
(Suppress
: Boolean := False);
7032 -- This is like Reanalyze, but does not do the Analyze step, it only
7033 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
7034 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
7035 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
7036 -- Note that skipping reanalysis is not just an optimization, testing
7037 -- has showed up several complex cases in which reanalyzing an already
7038 -- analyzed node causes incorrect behavior.
7040 function In_Result_Range
return Boolean;
7041 -- Returns True iff Lo .. Hi are within range of the result type
7043 procedure Max
(A
: in out Uint
; B
: Uint
);
7044 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
7046 procedure Min
(A
: in out Uint
; B
: Uint
);
7047 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
7049 ---------------------
7050 -- In_Result_Range --
7051 ---------------------
7053 function In_Result_Range
return Boolean is
7055 if Lo
= No_Uint
or else Hi
= No_Uint
then
7058 elsif Is_Static_Subtype
(Etype
(N
)) then
7059 return Lo
>= Expr_Value
(Type_Low_Bound
(Rtyp
))
7061 Hi
<= Expr_Value
(Type_High_Bound
(Rtyp
));
7064 return Lo
>= Expr_Value
(Type_Low_Bound
(Base_Type
(Rtyp
)))
7066 Hi
<= Expr_Value
(Type_High_Bound
(Base_Type
(Rtyp
)));
7068 end In_Result_Range
;
7074 procedure Max
(A
: in out Uint
; B
: Uint
) is
7076 if A
= No_Uint
or else B
> A
then
7085 procedure Min
(A
: in out Uint
; B
: Uint
) is
7087 if A
= No_Uint
or else B
< A
then
7096 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False) is
7097 Svg
: constant Overflow_Mode_Type
:=
7098 Scope_Suppress
.Overflow_Mode_General
;
7099 Sva
: constant Overflow_Mode_Type
:=
7100 Scope_Suppress
.Overflow_Mode_Assertions
;
7101 Svo
: constant Boolean :=
7102 Scope_Suppress
.Suppress
(Overflow_Check
);
7105 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7106 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7109 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
7112 Analyze_And_Resolve
(N
, Typ
);
7114 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
7115 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
7116 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
7123 procedure Reexpand
(Suppress
: Boolean := False) is
7124 Svg
: constant Overflow_Mode_Type
:=
7125 Scope_Suppress
.Overflow_Mode_General
;
7126 Sva
: constant Overflow_Mode_Type
:=
7127 Scope_Suppress
.Overflow_Mode_Assertions
;
7128 Svo
: constant Boolean :=
7129 Scope_Suppress
.Suppress
(Overflow_Check
);
7132 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7133 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7134 Set_Analyzed
(N
, False);
7137 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
7142 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
7143 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
7144 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
7147 -- Start of processing for Minimize_Eliminate_Overflows
7150 -- Case where we do not have a signed integer arithmetic operation
7152 if not Is_Signed_Integer_Arithmetic_Op
(N
) then
7154 -- Use the normal Determine_Range routine to get the range. We
7155 -- don't require operands to be valid, invalid values may result in
7156 -- rubbish results where the result has not been properly checked for
7157 -- overflow, that's fine.
7159 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> False);
7161 -- If Determine_Range did not work (can this in fact happen? Not
7162 -- clear but might as well protect), use type bounds.
7165 Lo
:= Intval
(Type_Low_Bound
(Base_Type
(Etype
(N
))));
7166 Hi
:= Intval
(Type_High_Bound
(Base_Type
(Etype
(N
))));
7169 -- If we don't have a binary operator, all we have to do is to set
7170 -- the Hi/Lo range, so we are done.
7174 -- Processing for if expression
7176 elsif Nkind
(N
) = N_If_Expression
then
7178 Then_DE
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
7179 Else_DE
: constant Node_Id
:= Next
(Then_DE
);
7182 Bignum_Operands
:= False;
7184 Minimize_Eliminate_Overflows
7185 (Then_DE
, Lo
, Hi
, Top_Level
=> False);
7187 if Lo
= No_Uint
then
7188 Bignum_Operands
:= True;
7191 Minimize_Eliminate_Overflows
7192 (Else_DE
, Rlo
, Rhi
, Top_Level
=> False);
7194 if Rlo
= No_Uint
then
7195 Bignum_Operands
:= True;
7197 Long_Long_Integer_Operands
:=
7198 Etype
(Then_DE
) = LLIB
or else Etype
(Else_DE
) = LLIB
;
7204 -- If at least one of our operands is now Bignum, we must rebuild
7205 -- the if expression to use Bignum operands. We will analyze the
7206 -- rebuilt if expression with overflow checks off, since once we
7207 -- are in bignum mode, we are all done with overflow checks.
7209 if Bignum_Operands
then
7211 Make_If_Expression
(Loc
,
7212 Expressions
=> New_List
(
7213 Remove_Head
(Expressions
(N
)),
7214 Convert_To_Bignum
(Then_DE
),
7215 Convert_To_Bignum
(Else_DE
)),
7216 Is_Elsif
=> Is_Elsif
(N
)));
7218 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
7220 -- If we have no Long_Long_Integer operands, then we are in result
7221 -- range, since it means that none of our operands felt the need
7222 -- to worry about overflow (otherwise it would have already been
7223 -- converted to long long integer or bignum). We reexpand to
7224 -- complete the expansion of the if expression (but we do not
7225 -- need to reanalyze).
7227 elsif not Long_Long_Integer_Operands
then
7228 Set_Do_Overflow_Check
(N
, False);
7231 -- Otherwise convert us to long long integer mode. Note that we
7232 -- don't need any further overflow checking at this level.
7235 Convert_To_And_Rewrite
(LLIB
, Then_DE
);
7236 Convert_To_And_Rewrite
(LLIB
, Else_DE
);
7237 Set_Etype
(N
, LLIB
);
7239 -- Now reanalyze with overflow checks off
7241 Set_Do_Overflow_Check
(N
, False);
7242 Reanalyze
(LLIB
, Suppress
=> True);
7248 -- Here for case expression
7250 elsif Nkind
(N
) = N_Case_Expression
then
7251 Bignum_Operands
:= False;
7252 Long_Long_Integer_Operands
:= False;
7258 -- Loop through expressions applying recursive call
7260 Alt
:= First
(Alternatives
(N
));
7261 while Present
(Alt
) loop
7263 Aexp
: constant Node_Id
:= Expression
(Alt
);
7266 Minimize_Eliminate_Overflows
7267 (Aexp
, Lo
, Hi
, Top_Level
=> False);
7269 if Lo
= No_Uint
then
7270 Bignum_Operands
:= True;
7271 elsif Etype
(Aexp
) = LLIB
then
7272 Long_Long_Integer_Operands
:= True;
7279 -- If we have no bignum or long long integer operands, it means
7280 -- that none of our dependent expressions could raise overflow.
7281 -- In this case, we simply return with no changes except for
7282 -- resetting the overflow flag, since we are done with overflow
7283 -- checks for this node. We will reexpand to get the needed
7284 -- expansion for the case expression, but we do not need to
7285 -- reanalyze, since nothing has changed.
7287 if not (Bignum_Operands
or Long_Long_Integer_Operands
) then
7288 Set_Do_Overflow_Check
(N
, False);
7289 Reexpand
(Suppress
=> True);
7291 -- Otherwise we are going to rebuild the case expression using
7292 -- either bignum or long long integer operands throughout.
7301 New_Alts
:= New_List
;
7302 Alt
:= First
(Alternatives
(N
));
7303 while Present
(Alt
) loop
7304 if Bignum_Operands
then
7305 New_Exp
:= Convert_To_Bignum
(Expression
(Alt
));
7306 Rtype
:= RTE
(RE_Bignum
);
7308 New_Exp
:= Convert_To
(LLIB
, Expression
(Alt
));
7312 Append_To
(New_Alts
,
7313 Make_Case_Expression_Alternative
(Sloc
(Alt
),
7315 Discrete_Choices
=> Discrete_Choices
(Alt
),
7316 Expression
=> New_Exp
));
7322 Make_Case_Expression
(Loc
,
7323 Expression
=> Expression
(N
),
7324 Alternatives
=> New_Alts
));
7326 Reanalyze
(Rtype
, Suppress
=> True);
7334 -- If we have an arithmetic operator we make recursive calls on the
7335 -- operands to get the ranges (and to properly process the subtree
7336 -- that lies below us).
7338 Minimize_Eliminate_Overflows
7339 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
7342 Minimize_Eliminate_Overflows
7343 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
7346 -- Record if we have Long_Long_Integer operands
7348 Long_Long_Integer_Operands
:=
7349 Etype
(Right_Opnd
(N
)) = LLIB
7350 or else (Binary
and then Etype
(Left_Opnd
(N
)) = LLIB
);
7352 -- If either operand is a bignum, then result will be a bignum and we
7353 -- don't need to do any range analysis. As previously discussed we could
7354 -- do range analysis in such cases, but it could mean working with giant
7355 -- numbers at compile time for very little gain (the number of cases
7356 -- in which we could slip back from bignum mode is small).
7358 if Rlo
= No_Uint
or else (Binary
and then Llo
= No_Uint
) then
7361 Bignum_Operands
:= True;
7363 -- Otherwise compute result range
7366 Bignum_Operands
:= False;
7374 Hi
:= UI_Max
(abs Rlo
, abs Rhi
);
7386 -- If the right operand can only be zero, set 0..0
7388 if Rlo
= 0 and then Rhi
= 0 then
7392 -- Possible bounds of division must come from dividing end
7393 -- values of the input ranges (four possibilities), provided
7394 -- zero is not included in the possible values of the right
7397 -- Otherwise, we just consider two intervals of values for
7398 -- the right operand: the interval of negative values (up to
7399 -- -1) and the interval of positive values (starting at 1).
7400 -- Since division by 1 is the identity, and division by -1
7401 -- is negation, we get all possible bounds of division in that
7402 -- case by considering:
7403 -- - all values from the division of end values of input
7405 -- - the end values of the left operand;
7406 -- - the negation of the end values of the left operand.
7410 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
7411 -- Mark so we can release the RR and Ev values
7419 -- Discard extreme values of zero for the divisor, since
7420 -- they will simply result in an exception in any case.
7428 -- Compute possible bounds coming from dividing end
7429 -- values of the input ranges.
7436 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
7437 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
7439 -- If the right operand can be both negative or positive,
7440 -- include the end values of the left operand in the
7441 -- extreme values, as well as their negation.
7443 if Rlo
< 0 and then Rhi
> 0 then
7450 UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
)));
7452 UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
)));
7455 -- Release the RR and Ev values
7457 Release_And_Save
(Mrk
, Lo
, Hi
);
7465 -- Discard negative values for the exponent, since they will
7466 -- simply result in an exception in any case.
7474 -- Estimate number of bits in result before we go computing
7475 -- giant useless bounds. Basically the number of bits in the
7476 -- result is the number of bits in the base multiplied by the
7477 -- value of the exponent. If this is big enough that the result
7478 -- definitely won't fit in Long_Long_Integer, switch to bignum
7479 -- mode immediately, and avoid computing giant bounds.
7481 -- The comparison here is approximate, but conservative, it
7482 -- only clicks on cases that are sure to exceed the bounds.
7484 if Num_Bits
(UI_Max
(abs Llo
, abs Lhi
)) * Rhi
+ 1 > 100 then
7488 -- If right operand is zero then result is 1
7495 -- High bound comes either from exponentiation of largest
7496 -- positive value to largest exponent value, or from
7497 -- the exponentiation of most negative value to an
7511 if Rhi
mod 2 = 0 then
7514 Hi2
:= Llo
** (Rhi
- 1);
7520 Hi
:= UI_Max
(Hi1
, Hi2
);
7523 -- Result can only be negative if base can be negative
7526 if Rhi
mod 2 = 0 then
7527 Lo
:= Llo
** (Rhi
- 1);
7532 -- Otherwise low bound is minimum ** minimum
7549 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
7550 -- This is the maximum absolute value of the result
7556 -- The result depends only on the sign and magnitude of
7557 -- the right operand, it does not depend on the sign or
7558 -- magnitude of the left operand.
7571 when N_Op_Multiply
=>
7573 -- Possible bounds of multiplication must come from multiplying
7574 -- end values of the input ranges (four possibilities).
7577 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
7578 -- Mark so we can release the Ev values
7580 Ev1
: constant Uint
:= Llo
* Rlo
;
7581 Ev2
: constant Uint
:= Llo
* Rhi
;
7582 Ev3
: constant Uint
:= Lhi
* Rlo
;
7583 Ev4
: constant Uint
:= Lhi
* Rhi
;
7586 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
7587 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
7589 -- Release the Ev values
7591 Release_And_Save
(Mrk
, Lo
, Hi
);
7594 -- Plus operator (affirmation)
7604 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
7605 -- This is the maximum absolute value of the result. Note
7606 -- that the result range does not depend on the sign of the
7613 -- Case of left operand negative, which results in a range
7614 -- of -Maxabs .. 0 for those negative values. If there are
7615 -- no negative values then Lo value of result is always 0.
7621 -- Case of left operand positive
7630 when N_Op_Subtract
=>
7634 -- Nothing else should be possible
7637 raise Program_Error
;
7641 -- Here for the case where we have not rewritten anything (no bignum
7642 -- operands or long long integer operands), and we know the result.
7643 -- If we know we are in the result range, and we do not have Bignum
7644 -- operands or Long_Long_Integer operands, we can just reexpand with
7645 -- overflow checks turned off (since we know we cannot have overflow).
7646 -- As always the reexpansion is required to complete expansion of the
7647 -- operator, but we do not need to reanalyze, and we prevent recursion
7648 -- by suppressing the check.
7650 if not (Bignum_Operands
or Long_Long_Integer_Operands
)
7651 and then In_Result_Range
7653 Set_Do_Overflow_Check
(N
, False);
7654 Reexpand
(Suppress
=> True);
7657 -- Here we know that we are not in the result range, and in the general
7658 -- case we will move into either the Bignum or Long_Long_Integer domain
7659 -- to compute the result. However, there is one exception. If we are
7660 -- at the top level, and we do not have Bignum or Long_Long_Integer
7661 -- operands, we will have to immediately convert the result back to
7662 -- the result type, so there is no point in Bignum/Long_Long_Integer
7666 and then not (Bignum_Operands
or Long_Long_Integer_Operands
)
7668 -- One further refinement. If we are at the top level, but our parent
7669 -- is a type conversion, then go into bignum or long long integer node
7670 -- since the result will be converted to that type directly without
7671 -- going through the result type, and we may avoid an overflow. This
7672 -- is the case for example of Long_Long_Integer (A ** 4), where A is
7673 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
7674 -- but does not fit in Integer.
7676 and then Nkind
(Parent
(N
)) /= N_Type_Conversion
7678 -- Here keep original types, but we need to complete analysis
7680 -- One subtlety. We can't just go ahead and do an analyze operation
7681 -- here because it will cause recursion into the whole MINIMIZED/
7682 -- ELIMINATED overflow processing which is not what we want. Here
7683 -- we are at the top level, and we need a check against the result
7684 -- mode (i.e. we want to use STRICT mode). So do exactly that.
7685 -- Also, we have not modified the node, so this is a case where
7686 -- we need to reexpand, but not reanalyze.
7691 -- Cases where we do the operation in Bignum mode. This happens either
7692 -- because one of our operands is in Bignum mode already, or because
7693 -- the computed bounds are outside the bounds of Long_Long_Integer,
7694 -- which in some cases can be indicated by Hi and Lo being No_Uint.
7696 -- Note: we could do better here and in some cases switch back from
7697 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
7698 -- 0 .. 1, but the cases are rare and it is not worth the effort.
7699 -- Failing to do this switching back is only an efficiency issue.
7701 elsif Lo
= No_Uint
or else Lo
< LLLo
or else Hi
> LLHi
then
7703 -- OK, we are definitely outside the range of Long_Long_Integer. The
7704 -- question is whether to move to Bignum mode, or stay in the domain
7705 -- of Long_Long_Integer, signalling that an overflow check is needed.
7707 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
7708 -- the Bignum business. In ELIMINATED mode, we will normally move
7709 -- into Bignum mode, but there is an exception if neither of our
7710 -- operands is Bignum now, and we are at the top level (Top_Level
7711 -- set True). In this case, there is no point in moving into Bignum
7712 -- mode to prevent overflow if the caller will immediately convert
7713 -- the Bignum value back to LLI with an overflow check. It's more
7714 -- efficient to stay in LLI mode with an overflow check (if needed)
7716 if Check_Mode
= Minimized
7717 or else (Top_Level
and not Bignum_Operands
)
7719 if Do_Overflow_Check
(N
) then
7720 Enable_Overflow_Check
(N
);
7723 -- The result now has to be in Long_Long_Integer mode, so adjust
7724 -- the possible range to reflect this. Note these calls also
7725 -- change No_Uint values from the top level case to LLI bounds.
7730 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
7733 pragma Assert
(Check_Mode
= Eliminated
);
7742 Fent
:= RTE
(RE_Big_Abs
);
7745 Fent
:= RTE
(RE_Big_Add
);
7748 Fent
:= RTE
(RE_Big_Div
);
7751 Fent
:= RTE
(RE_Big_Exp
);
7754 Fent
:= RTE
(RE_Big_Neg
);
7757 Fent
:= RTE
(RE_Big_Mod
);
7759 when N_Op_Multiply
=>
7760 Fent
:= RTE
(RE_Big_Mul
);
7763 Fent
:= RTE
(RE_Big_Rem
);
7765 when N_Op_Subtract
=>
7766 Fent
:= RTE
(RE_Big_Sub
);
7768 -- Anything else is an internal error, this includes the
7769 -- N_Op_Plus case, since how can plus cause the result
7770 -- to be out of range if the operand is in range?
7773 raise Program_Error
;
7776 -- Construct argument list for Bignum call, converting our
7777 -- operands to Bignum form if they are not already there.
7782 Append_To
(Args
, Convert_To_Bignum
(Left_Opnd
(N
)));
7785 Append_To
(Args
, Convert_To_Bignum
(Right_Opnd
(N
)));
7787 -- Now rewrite the arithmetic operator with a call to the
7788 -- corresponding bignum function.
7791 Make_Function_Call
(Loc
,
7792 Name
=> New_Occurrence_Of
(Fent
, Loc
),
7793 Parameter_Associations
=> Args
));
7794 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
7796 -- Indicate result is Bignum mode
7804 -- Otherwise we are in range of Long_Long_Integer, so no overflow
7805 -- check is required, at least not yet.
7808 Set_Do_Overflow_Check
(N
, False);
7811 -- Here we are not in Bignum territory, but we may have long long
7812 -- integer operands that need special handling. First a special check:
7813 -- If an exponentiation operator exponent is of type Long_Long_Integer,
7814 -- it means we converted it to prevent overflow, but exponentiation
7815 -- requires a Natural right operand, so convert it back to Natural.
7816 -- This conversion may raise an exception which is fine.
7818 if Nkind
(N
) = N_Op_Expon
and then Etype
(Right_Opnd
(N
)) = LLIB
then
7819 Convert_To_And_Rewrite
(Standard_Natural
, Right_Opnd
(N
));
7822 -- Here we will do the operation in Long_Long_Integer. We do this even
7823 -- if we know an overflow check is required, better to do this in long
7824 -- long integer mode, since we are less likely to overflow.
7826 -- Convert right or only operand to Long_Long_Integer, except that
7827 -- we do not touch the exponentiation right operand.
7829 if Nkind
(N
) /= N_Op_Expon
then
7830 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
7833 -- Convert left operand to Long_Long_Integer for binary case
7836 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
7839 -- Reset node to unanalyzed
7841 Set_Analyzed
(N
, False);
7842 Set_Etype
(N
, Empty
);
7843 Set_Entity
(N
, Empty
);
7845 -- Now analyze this new node. This reanalysis will complete processing
7846 -- for the node. In particular we will complete the expansion of an
7847 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
7848 -- we will complete any division checks (since we have not changed the
7849 -- setting of the Do_Division_Check flag).
7851 -- We do this reanalysis in STRICT mode to avoid recursion into the
7852 -- MINIMIZED/ELIMINATED handling, since we are now done with that.
7855 SG
: constant Overflow_Mode_Type
:=
7856 Scope_Suppress
.Overflow_Mode_General
;
7857 SA
: constant Overflow_Mode_Type
:=
7858 Scope_Suppress
.Overflow_Mode_Assertions
;
7861 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7862 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7864 if not Do_Overflow_Check
(N
) then
7865 Reanalyze
(LLIB
, Suppress
=> True);
7870 Scope_Suppress
.Overflow_Mode_General
:= SG
;
7871 Scope_Suppress
.Overflow_Mode_Assertions
:= SA
;
7873 end Minimize_Eliminate_Overflows
;
7875 -------------------------
7876 -- Overflow_Check_Mode --
7877 -------------------------
7879 function Overflow_Check_Mode
return Overflow_Mode_Type
is
7881 if In_Assertion_Expr
= 0 then
7882 return Scope_Suppress
.Overflow_Mode_General
;
7884 return Scope_Suppress
.Overflow_Mode_Assertions
;
7886 end Overflow_Check_Mode
;
7888 --------------------------------
7889 -- Overflow_Checks_Suppressed --
7890 --------------------------------
7892 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7894 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7895 return Is_Check_Suppressed
(E
, Overflow_Check
);
7897 return Scope_Suppress
.Suppress
(Overflow_Check
);
7899 end Overflow_Checks_Suppressed
;
7901 ---------------------------------
7902 -- Predicate_Checks_Suppressed --
7903 ---------------------------------
7905 function Predicate_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7907 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7908 return Is_Check_Suppressed
(E
, Predicate_Check
);
7910 return Scope_Suppress
.Suppress
(Predicate_Check
);
7912 end Predicate_Checks_Suppressed
;
7914 -----------------------------
7915 -- Range_Checks_Suppressed --
7916 -----------------------------
7918 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7922 -- Note: for now we always suppress range checks on Vax float types,
7923 -- since Gigi does not know how to generate these checks.
7925 if Vax_Float
(E
) then
7927 elsif Kill_Range_Checks
(E
) then
7929 elsif Checks_May_Be_Suppressed
(E
) then
7930 return Is_Check_Suppressed
(E
, Range_Check
);
7934 return Scope_Suppress
.Suppress
(Range_Check
);
7935 end Range_Checks_Suppressed
;
7937 -----------------------------------------
7938 -- Range_Or_Validity_Checks_Suppressed --
7939 -----------------------------------------
7941 -- Note: the coding would be simpler here if we simply made appropriate
7942 -- calls to Range/Validity_Checks_Suppressed, but that would result in
7943 -- duplicated checks which we prefer to avoid.
7945 function Range_Or_Validity_Checks_Suppressed
7946 (Expr
: Node_Id
) return Boolean
7949 -- Immediate return if scope checks suppressed for either check
7951 if Scope_Suppress
.Suppress
(Range_Check
)
7953 Scope_Suppress
.Suppress
(Validity_Check
)
7958 -- If no expression, that's odd, decide that checks are suppressed,
7959 -- since we don't want anyone trying to do checks in this case, which
7960 -- is most likely the result of some other error.
7966 -- Expression is present, so perform suppress checks on type
7969 Typ
: constant Entity_Id
:= Etype
(Expr
);
7971 if Vax_Float
(Typ
) then
7973 elsif Checks_May_Be_Suppressed
(Typ
)
7974 and then (Is_Check_Suppressed
(Typ
, Range_Check
)
7976 Is_Check_Suppressed
(Typ
, Validity_Check
))
7982 -- If expression is an entity name, perform checks on this entity
7984 if Is_Entity_Name
(Expr
) then
7986 Ent
: constant Entity_Id
:= Entity
(Expr
);
7988 if Checks_May_Be_Suppressed
(Ent
) then
7989 return Is_Check_Suppressed
(Ent
, Range_Check
)
7990 or else Is_Check_Suppressed
(Ent
, Validity_Check
);
7995 -- If we fall through, no checks suppressed
7998 end Range_Or_Validity_Checks_Suppressed
;
8004 procedure Remove_Checks
(Expr
: Node_Id
) is
8005 function Process
(N
: Node_Id
) return Traverse_Result
;
8006 -- Process a single node during the traversal
8008 procedure Traverse
is new Traverse_Proc
(Process
);
8009 -- The traversal procedure itself
8015 function Process
(N
: Node_Id
) return Traverse_Result
is
8017 if Nkind
(N
) not in N_Subexpr
then
8021 Set_Do_Range_Check
(N
, False);
8025 Traverse
(Left_Opnd
(N
));
8028 when N_Attribute_Reference
=>
8029 Set_Do_Overflow_Check
(N
, False);
8031 when N_Function_Call
=>
8032 Set_Do_Tag_Check
(N
, False);
8035 Set_Do_Overflow_Check
(N
, False);
8039 Set_Do_Division_Check
(N
, False);
8042 Set_Do_Length_Check
(N
, False);
8045 Set_Do_Division_Check
(N
, False);
8048 Set_Do_Length_Check
(N
, False);
8051 Set_Do_Division_Check
(N
, False);
8054 Set_Do_Length_Check
(N
, False);
8061 Traverse
(Left_Opnd
(N
));
8064 when N_Selected_Component
=>
8065 Set_Do_Discriminant_Check
(N
, False);
8067 when N_Type_Conversion
=>
8068 Set_Do_Length_Check
(N
, False);
8069 Set_Do_Tag_Check
(N
, False);
8070 Set_Do_Overflow_Check
(N
, False);
8079 -- Start of processing for Remove_Checks
8085 ----------------------------
8086 -- Selected_Length_Checks --
8087 ----------------------------
8089 function Selected_Length_Checks
8091 Target_Typ
: Entity_Id
;
8092 Source_Typ
: Entity_Id
;
8093 Warn_Node
: Node_Id
) return Check_Result
8095 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
8098 Expr_Actual
: Node_Id
;
8100 Cond
: Node_Id
:= Empty
;
8101 Do_Access
: Boolean := False;
8102 Wnode
: Node_Id
:= Warn_Node
;
8103 Ret_Result
: Check_Result
:= (Empty
, Empty
);
8104 Num_Checks
: Natural := 0;
8106 procedure Add_Check
(N
: Node_Id
);
8107 -- Adds the action given to Ret_Result if N is non-Empty
8109 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
8110 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8111 -- Comments required ???
8113 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
8114 -- True for equal literals and for nodes that denote the same constant
8115 -- entity, even if its value is not a static constant. This includes the
8116 -- case of a discriminal reference within an init proc. Removes some
8117 -- obviously superfluous checks.
8119 function Length_E_Cond
8120 (Exptyp
: Entity_Id
;
8122 Indx
: Nat
) return Node_Id
;
8123 -- Returns expression to compute:
8124 -- Typ'Length /= Exptyp'Length
8126 function Length_N_Cond
8129 Indx
: Nat
) return Node_Id
;
8130 -- Returns expression to compute:
8131 -- Typ'Length /= Expr'Length
8137 procedure Add_Check
(N
: Node_Id
) is
8141 -- For now, ignore attempt to place more than two checks ???
8142 -- This is really worrisome, are we really discarding checks ???
8144 if Num_Checks
= 2 then
8148 pragma Assert
(Num_Checks
<= 1);
8149 Num_Checks
:= Num_Checks
+ 1;
8150 Ret_Result
(Num_Checks
) := N
;
8158 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
8159 SE
: constant Entity_Id
:= Scope
(E
);
8161 E1
: Entity_Id
:= E
;
8164 if Ekind
(Scope
(E
)) = E_Record_Type
8165 and then Has_Discriminants
(Scope
(E
))
8167 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
8170 Insert_Action
(Ck_Node
, N
);
8171 E1
:= Defining_Identifier
(N
);
8175 if Ekind
(E1
) = E_String_Literal_Subtype
then
8177 Make_Integer_Literal
(Loc
,
8178 Intval
=> String_Literal_Length
(E1
));
8180 elsif SE
/= Standard_Standard
8181 and then Ekind
(Scope
(SE
)) = E_Protected_Type
8182 and then Has_Discriminants
(Scope
(SE
))
8183 and then Has_Completion
(Scope
(SE
))
8184 and then not Inside_Init_Proc
8186 -- If the type whose length is needed is a private component
8187 -- constrained by a discriminant, we must expand the 'Length
8188 -- attribute into an explicit computation, using the discriminal
8189 -- of the current protected operation. This is because the actual
8190 -- type of the prival is constructed after the protected opera-
8191 -- tion has been fully expanded.
8194 Indx_Type
: Node_Id
;
8197 Do_Expand
: Boolean := False;
8200 Indx_Type
:= First_Index
(E
);
8202 for J
in 1 .. Indx
- 1 loop
8203 Next_Index
(Indx_Type
);
8206 Get_Index_Bounds
(Indx_Type
, Lo
, Hi
);
8208 if Nkind
(Lo
) = N_Identifier
8209 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
8211 Lo
:= Get_Discriminal
(E
, Lo
);
8215 if Nkind
(Hi
) = N_Identifier
8216 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
8218 Hi
:= Get_Discriminal
(E
, Hi
);
8223 if not Is_Entity_Name
(Lo
) then
8224 Lo
:= Duplicate_Subexpr_No_Checks
(Lo
);
8227 if not Is_Entity_Name
(Hi
) then
8228 Lo
:= Duplicate_Subexpr_No_Checks
(Hi
);
8234 Make_Op_Subtract
(Loc
,
8238 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
8243 Make_Attribute_Reference
(Loc
,
8244 Attribute_Name
=> Name_Length
,
8246 New_Occurrence_Of
(E1
, Loc
));
8249 Set_Expressions
(N
, New_List
(
8250 Make_Integer_Literal
(Loc
, Indx
)));
8259 Make_Attribute_Reference
(Loc
,
8260 Attribute_Name
=> Name_Length
,
8262 New_Occurrence_Of
(E1
, Loc
));
8265 Set_Expressions
(N
, New_List
(
8266 Make_Integer_Literal
(Loc
, Indx
)));
8277 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8280 Make_Attribute_Reference
(Loc
,
8281 Attribute_Name
=> Name_Length
,
8283 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8284 Expressions
=> New_List
(
8285 Make_Integer_Literal
(Loc
, Indx
)));
8292 function Length_E_Cond
8293 (Exptyp
: Entity_Id
;
8295 Indx
: Nat
) return Node_Id
8300 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8301 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
8308 function Length_N_Cond
8311 Indx
: Nat
) return Node_Id
8316 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8317 Right_Opnd
=> Get_N_Length
(Expr
, Indx
));
8324 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
8327 (Nkind
(L
) = N_Integer_Literal
8328 and then Nkind
(R
) = N_Integer_Literal
8329 and then Intval
(L
) = Intval
(R
))
8333 and then Ekind
(Entity
(L
)) = E_Constant
8334 and then ((Is_Entity_Name
(R
)
8335 and then Entity
(L
) = Entity
(R
))
8337 (Nkind
(R
) = N_Type_Conversion
8338 and then Is_Entity_Name
(Expression
(R
))
8339 and then Entity
(L
) = Entity
(Expression
(R
)))))
8343 and then Ekind
(Entity
(R
)) = E_Constant
8344 and then Nkind
(L
) = N_Type_Conversion
8345 and then Is_Entity_Name
(Expression
(L
))
8346 and then Entity
(R
) = Entity
(Expression
(L
)))
8350 and then Is_Entity_Name
(R
)
8351 and then Entity
(L
) = Entity
(R
)
8352 and then Ekind
(Entity
(L
)) = E_In_Parameter
8353 and then Inside_Init_Proc
);
8356 -- Start of processing for Selected_Length_Checks
8359 if not Expander_Active
then
8363 if Target_Typ
= Any_Type
8364 or else Target_Typ
= Any_Composite
8365 or else Raises_Constraint_Error
(Ck_Node
)
8374 T_Typ
:= Target_Typ
;
8376 if No
(Source_Typ
) then
8377 S_Typ
:= Etype
(Ck_Node
);
8379 S_Typ
:= Source_Typ
;
8382 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
8386 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
8387 S_Typ
:= Designated_Type
(S_Typ
);
8388 T_Typ
:= Designated_Type
(T_Typ
);
8391 -- A simple optimization for the null case
8393 if Known_Null
(Ck_Node
) then
8398 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
8399 if Is_Constrained
(T_Typ
) then
8401 -- The checking code to be generated will freeze the corresponding
8402 -- array type. However, we must freeze the type now, so that the
8403 -- freeze node does not appear within the generated if expression,
8406 Freeze_Before
(Ck_Node
, T_Typ
);
8408 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
8409 Exptyp
:= Get_Actual_Subtype
(Ck_Node
);
8411 if Is_Access_Type
(Exptyp
) then
8412 Exptyp
:= Designated_Type
(Exptyp
);
8415 -- String_Literal case. This needs to be handled specially be-
8416 -- cause no index types are available for string literals. The
8417 -- condition is simply:
8419 -- T_Typ'Length = string-literal-length
8421 if Nkind
(Expr_Actual
) = N_String_Literal
8422 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
8426 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
8428 Make_Integer_Literal
(Loc
,
8430 String_Literal_Length
(Etype
(Expr_Actual
))));
8432 -- General array case. Here we have a usable actual subtype for
8433 -- the expression, and the condition is built from the two types
8436 -- T_Typ'Length /= Exptyp'Length or else
8437 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
8438 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
8441 elsif Is_Constrained
(Exptyp
) then
8443 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
8456 -- At the library level, we need to ensure that the type of
8457 -- the object is elaborated before the check itself is
8458 -- emitted. This is only done if the object is in the
8459 -- current compilation unit, otherwise the type is frozen
8460 -- and elaborated in its unit.
8462 if Is_Itype
(Exptyp
)
8464 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
8466 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
8467 and then In_Open_Scopes
(Scope
(Exptyp
))
8469 Ref_Node
:= Make_Itype_Reference
(Sloc
(Ck_Node
));
8470 Set_Itype
(Ref_Node
, Exptyp
);
8471 Insert_Action
(Ck_Node
, Ref_Node
);
8474 L_Index
:= First_Index
(T_Typ
);
8475 R_Index
:= First_Index
(Exptyp
);
8477 for Indx
in 1 .. Ndims
loop
8478 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
8480 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
8482 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
8483 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
8485 -- Deal with compile time length check. Note that we
8486 -- skip this in the access case, because the access
8487 -- value may be null, so we cannot know statically.
8490 and then Compile_Time_Known_Value
(L_Low
)
8491 and then Compile_Time_Known_Value
(L_High
)
8492 and then Compile_Time_Known_Value
(R_Low
)
8493 and then Compile_Time_Known_Value
(R_High
)
8495 if Expr_Value
(L_High
) >= Expr_Value
(L_Low
) then
8496 L_Length
:= Expr_Value
(L_High
) -
8497 Expr_Value
(L_Low
) + 1;
8499 L_Length
:= UI_From_Int
(0);
8502 if Expr_Value
(R_High
) >= Expr_Value
(R_Low
) then
8503 R_Length
:= Expr_Value
(R_High
) -
8504 Expr_Value
(R_Low
) + 1;
8506 R_Length
:= UI_From_Int
(0);
8509 if L_Length
> R_Length
then
8511 (Compile_Time_Constraint_Error
8512 (Wnode
, "too few elements for}??", T_Typ
));
8514 elsif L_Length
< R_Length
then
8516 (Compile_Time_Constraint_Error
8517 (Wnode
, "too many elements for}??", T_Typ
));
8520 -- The comparison for an individual index subtype
8521 -- is omitted if the corresponding index subtypes
8522 -- statically match, since the result is known to
8523 -- be true. Note that this test is worth while even
8524 -- though we do static evaluation, because non-static
8525 -- subtypes can statically match.
8528 Subtypes_Statically_Match
8529 (Etype
(L_Index
), Etype
(R_Index
))
8532 (Same_Bounds
(L_Low
, R_Low
)
8533 and then Same_Bounds
(L_High
, R_High
))
8536 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
8545 -- Handle cases where we do not get a usable actual subtype that
8546 -- is constrained. This happens for example in the function call
8547 -- and explicit dereference cases. In these cases, we have to get
8548 -- the length or range from the expression itself, making sure we
8549 -- do not evaluate it more than once.
8551 -- Here Ck_Node is the original expression, or more properly the
8552 -- result of applying Duplicate_Expr to the original tree, forcing
8553 -- the result to be a name.
8557 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
8560 -- Build the condition for the explicit dereference case
8562 for Indx
in 1 .. Ndims
loop
8564 (Cond
, Length_N_Cond
(Ck_Node
, T_Typ
, Indx
));
8571 -- Construct the test and insert into the tree
8573 if Present
(Cond
) then
8575 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
8579 (Make_Raise_Constraint_Error
(Loc
,
8581 Reason
=> CE_Length_Check_Failed
));
8585 end Selected_Length_Checks
;
8587 ---------------------------
8588 -- Selected_Range_Checks --
8589 ---------------------------
8591 function Selected_Range_Checks
8593 Target_Typ
: Entity_Id
;
8594 Source_Typ
: Entity_Id
;
8595 Warn_Node
: Node_Id
) return Check_Result
8597 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
8600 Expr_Actual
: Node_Id
;
8602 Cond
: Node_Id
:= Empty
;
8603 Do_Access
: Boolean := False;
8604 Wnode
: Node_Id
:= Warn_Node
;
8605 Ret_Result
: Check_Result
:= (Empty
, Empty
);
8606 Num_Checks
: Integer := 0;
8608 procedure Add_Check
(N
: Node_Id
);
8609 -- Adds the action given to Ret_Result if N is non-Empty
8611 function Discrete_Range_Cond
8613 Typ
: Entity_Id
) return Node_Id
;
8614 -- Returns expression to compute:
8615 -- Low_Bound (Expr) < Typ'First
8617 -- High_Bound (Expr) > Typ'Last
8619 function Discrete_Expr_Cond
8621 Typ
: Entity_Id
) return Node_Id
;
8622 -- Returns expression to compute:
8627 function Get_E_First_Or_Last
8631 Nam
: Name_Id
) return Node_Id
;
8632 -- Returns an attribute reference
8633 -- E'First or E'Last
8634 -- with a source location of Loc.
8636 -- Nam is Name_First or Name_Last, according to which attribute is
8637 -- desired. If Indx is non-zero, it is passed as a literal in the
8638 -- Expressions of the attribute reference (identifying the desired
8639 -- array dimension).
8641 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8642 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8643 -- Returns expression to compute:
8644 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
8646 function Range_E_Cond
8647 (Exptyp
: Entity_Id
;
8651 -- Returns expression to compute:
8652 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
8654 function Range_Equal_E_Cond
8655 (Exptyp
: Entity_Id
;
8657 Indx
: Nat
) return Node_Id
;
8658 -- Returns expression to compute:
8659 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
8661 function Range_N_Cond
8664 Indx
: Nat
) return Node_Id
;
8665 -- Return expression to compute:
8666 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
8672 procedure Add_Check
(N
: Node_Id
) is
8676 -- For now, ignore attempt to place more than 2 checks ???
8678 if Num_Checks
= 2 then
8682 pragma Assert
(Num_Checks
<= 1);
8683 Num_Checks
:= Num_Checks
+ 1;
8684 Ret_Result
(Num_Checks
) := N
;
8688 -------------------------
8689 -- Discrete_Expr_Cond --
8690 -------------------------
8692 function Discrete_Expr_Cond
8694 Typ
: Entity_Id
) return Node_Id
8702 Convert_To
(Base_Type
(Typ
),
8703 Duplicate_Subexpr_No_Checks
(Expr
)),
8705 Convert_To
(Base_Type
(Typ
),
8706 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
))),
8711 Convert_To
(Base_Type
(Typ
),
8712 Duplicate_Subexpr_No_Checks
(Expr
)),
8716 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
))));
8717 end Discrete_Expr_Cond
;
8719 -------------------------
8720 -- Discrete_Range_Cond --
8721 -------------------------
8723 function Discrete_Range_Cond
8725 Typ
: Entity_Id
) return Node_Id
8727 LB
: Node_Id
:= Low_Bound
(Expr
);
8728 HB
: Node_Id
:= High_Bound
(Expr
);
8730 Left_Opnd
: Node_Id
;
8731 Right_Opnd
: Node_Id
;
8734 if Nkind
(LB
) = N_Identifier
8735 and then Ekind
(Entity
(LB
)) = E_Discriminant
8737 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
8744 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
8749 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
)));
8751 if Nkind
(HB
) = N_Identifier
8752 and then Ekind
(Entity
(HB
)) = E_Discriminant
8754 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
8761 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
8766 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
)));
8768 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
8769 end Discrete_Range_Cond
;
8771 -------------------------
8772 -- Get_E_First_Or_Last --
8773 -------------------------
8775 function Get_E_First_Or_Last
8779 Nam
: Name_Id
) return Node_Id
8784 Exprs
:= New_List
(Make_Integer_Literal
(Loc
, UI_From_Int
(Indx
)));
8789 return Make_Attribute_Reference
(Loc
,
8790 Prefix
=> New_Occurrence_Of
(E
, Loc
),
8791 Attribute_Name
=> Nam
,
8792 Expressions
=> Exprs
);
8793 end Get_E_First_Or_Last
;
8799 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8802 Make_Attribute_Reference
(Loc
,
8803 Attribute_Name
=> Name_First
,
8805 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8806 Expressions
=> New_List
(
8807 Make_Integer_Literal
(Loc
, Indx
)));
8814 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8817 Make_Attribute_Reference
(Loc
,
8818 Attribute_Name
=> Name_Last
,
8820 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8821 Expressions
=> New_List
(
8822 Make_Integer_Literal
(Loc
, Indx
)));
8829 function Range_E_Cond
8830 (Exptyp
: Entity_Id
;
8832 Indx
: Nat
) return Node_Id
8840 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
8842 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8847 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
8849 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8852 ------------------------
8853 -- Range_Equal_E_Cond --
8854 ------------------------
8856 function Range_Equal_E_Cond
8857 (Exptyp
: Entity_Id
;
8859 Indx
: Nat
) return Node_Id
8867 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
8869 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8874 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
8876 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8877 end Range_Equal_E_Cond
;
8883 function Range_N_Cond
8886 Indx
: Nat
) return Node_Id
8894 Get_N_First
(Expr
, Indx
),
8896 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8901 Get_N_Last
(Expr
, Indx
),
8903 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8906 -- Start of processing for Selected_Range_Checks
8909 if not Expander_Active
then
8913 if Target_Typ
= Any_Type
8914 or else Target_Typ
= Any_Composite
8915 or else Raises_Constraint_Error
(Ck_Node
)
8924 T_Typ
:= Target_Typ
;
8926 if No
(Source_Typ
) then
8927 S_Typ
:= Etype
(Ck_Node
);
8929 S_Typ
:= Source_Typ
;
8932 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
8936 -- The order of evaluating T_Typ before S_Typ seems to be critical
8937 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
8938 -- in, and since Node can be an N_Range node, it might be invalid.
8939 -- Should there be an assert check somewhere for taking the Etype of
8940 -- an N_Range node ???
8942 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
8943 S_Typ
:= Designated_Type
(S_Typ
);
8944 T_Typ
:= Designated_Type
(T_Typ
);
8947 -- A simple optimization for the null case
8949 if Known_Null
(Ck_Node
) then
8954 -- For an N_Range Node, check for a null range and then if not
8955 -- null generate a range check action.
8957 if Nkind
(Ck_Node
) = N_Range
then
8959 -- There's no point in checking a range against itself
8961 if Ck_Node
= Scalar_Range
(T_Typ
) then
8966 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
8967 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
8968 Known_T_LB
: constant Boolean := Compile_Time_Known_Value
(T_LB
);
8969 Known_T_HB
: constant Boolean := Compile_Time_Known_Value
(T_HB
);
8971 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
8972 HB
: Node_Id
:= High_Bound
(Ck_Node
);
8976 Null_Range
: Boolean;
8977 Out_Of_Range_L
: Boolean;
8978 Out_Of_Range_H
: Boolean;
8981 -- Compute what is known at compile time
8983 if Known_T_LB
and Known_T_HB
then
8984 if Compile_Time_Known_Value
(LB
) then
8987 -- There's no point in checking that a bound is within its
8988 -- own range so pretend that it is known in this case. First
8989 -- deal with low bound.
8991 elsif Ekind
(Etype
(LB
)) = E_Signed_Integer_Subtype
8992 and then Scalar_Range
(Etype
(LB
)) = Scalar_Range
(T_Typ
)
9001 -- Likewise for the high bound
9003 if Compile_Time_Known_Value
(HB
) then
9006 elsif Ekind
(Etype
(HB
)) = E_Signed_Integer_Subtype
9007 and then Scalar_Range
(Etype
(HB
)) = Scalar_Range
(T_Typ
)
9016 -- Check for case where everything is static and we can do the
9017 -- check at compile time. This is skipped if we have an access
9018 -- type, since the access value may be null.
9020 -- ??? This code can be improved since you only need to know that
9021 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
9022 -- compile time to emit pertinent messages.
9024 if Known_T_LB
and Known_T_HB
and Known_LB
and Known_HB
9027 -- Floating-point case
9029 if Is_Floating_Point_Type
(S_Typ
) then
9030 Null_Range
:= Expr_Value_R
(HB
) < Expr_Value_R
(LB
);
9032 (Expr_Value_R
(LB
) < Expr_Value_R
(T_LB
))
9034 (Expr_Value_R
(LB
) > Expr_Value_R
(T_HB
));
9037 (Expr_Value_R
(HB
) > Expr_Value_R
(T_HB
))
9039 (Expr_Value_R
(HB
) < Expr_Value_R
(T_LB
));
9041 -- Fixed or discrete type case
9044 Null_Range
:= Expr_Value
(HB
) < Expr_Value
(LB
);
9046 (Expr_Value
(LB
) < Expr_Value
(T_LB
))
9048 (Expr_Value
(LB
) > Expr_Value
(T_HB
));
9051 (Expr_Value
(HB
) > Expr_Value
(T_HB
))
9053 (Expr_Value
(HB
) < Expr_Value
(T_LB
));
9056 if not Null_Range
then
9057 if Out_Of_Range_L
then
9058 if No
(Warn_Node
) then
9060 (Compile_Time_Constraint_Error
9061 (Low_Bound
(Ck_Node
),
9062 "static value out of range of}??", T_Typ
));
9066 (Compile_Time_Constraint_Error
9068 "static range out of bounds of}??", T_Typ
));
9072 if Out_Of_Range_H
then
9073 if No
(Warn_Node
) then
9075 (Compile_Time_Constraint_Error
9076 (High_Bound
(Ck_Node
),
9077 "static value out of range of}??", T_Typ
));
9081 (Compile_Time_Constraint_Error
9083 "static range out of bounds of}??", T_Typ
));
9090 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
9091 HB
: Node_Id
:= High_Bound
(Ck_Node
);
9094 -- If either bound is a discriminant and we are within the
9095 -- record declaration, it is a use of the discriminant in a
9096 -- constraint of a component, and nothing can be checked
9097 -- here. The check will be emitted within the init proc.
9098 -- Before then, the discriminal has no real meaning.
9099 -- Similarly, if the entity is a discriminal, there is no
9100 -- check to perform yet.
9102 -- The same holds within a discriminated synchronized type,
9103 -- where the discriminant may constrain a component or an
9106 if Nkind
(LB
) = N_Identifier
9107 and then Denotes_Discriminant
(LB
, True)
9109 if Current_Scope
= Scope
(Entity
(LB
))
9110 or else Is_Concurrent_Type
(Current_Scope
)
9111 or else Ekind
(Entity
(LB
)) /= E_Discriminant
9116 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
9120 if Nkind
(HB
) = N_Identifier
9121 and then Denotes_Discriminant
(HB
, True)
9123 if Current_Scope
= Scope
(Entity
(HB
))
9124 or else Is_Concurrent_Type
(Current_Scope
)
9125 or else Ekind
(Entity
(HB
)) /= E_Discriminant
9130 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
9134 Cond
:= Discrete_Range_Cond
(Ck_Node
, T_Typ
);
9135 Set_Paren_Count
(Cond
, 1);
9141 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(HB
),
9142 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(LB
)),
9143 Right_Opnd
=> Cond
);
9148 elsif Is_Scalar_Type
(S_Typ
) then
9150 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
9151 -- except the above simply sets a flag in the node and lets
9152 -- gigi generate the check base on the Etype of the expression.
9153 -- Sometimes, however we want to do a dynamic check against an
9154 -- arbitrary target type, so we do that here.
9156 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
9157 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9159 -- For literals, we can tell if the constraint error will be
9160 -- raised at compile time, so we never need a dynamic check, but
9161 -- if the exception will be raised, then post the usual warning,
9162 -- and replace the literal with a raise constraint error
9163 -- expression. As usual, skip this for access types
9165 elsif Compile_Time_Known_Value
(Ck_Node
) and then not Do_Access
then
9167 LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
9168 UB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
9170 Out_Of_Range
: Boolean;
9171 Static_Bounds
: constant Boolean :=
9172 Compile_Time_Known_Value
(LB
)
9173 and Compile_Time_Known_Value
(UB
);
9176 -- Following range tests should use Sem_Eval routine ???
9178 if Static_Bounds
then
9179 if Is_Floating_Point_Type
(S_Typ
) then
9181 (Expr_Value_R
(Ck_Node
) < Expr_Value_R
(LB
))
9183 (Expr_Value_R
(Ck_Node
) > Expr_Value_R
(UB
));
9185 -- Fixed or discrete type
9189 Expr_Value
(Ck_Node
) < Expr_Value
(LB
)
9191 Expr_Value
(Ck_Node
) > Expr_Value
(UB
);
9194 -- Bounds of the type are static and the literal is out of
9195 -- range so output a warning message.
9197 if Out_Of_Range
then
9198 if No
(Warn_Node
) then
9200 (Compile_Time_Constraint_Error
9202 "static value out of range of}??", T_Typ
));
9206 (Compile_Time_Constraint_Error
9208 "static value out of range of}??", T_Typ
));
9213 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9217 -- Here for the case of a non-static expression, we need a runtime
9218 -- check unless the source type range is guaranteed to be in the
9219 -- range of the target type.
9222 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
9223 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9228 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
9229 if Is_Constrained
(T_Typ
) then
9231 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
9232 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
9234 if Is_Access_Type
(Exptyp
) then
9235 Exptyp
:= Designated_Type
(Exptyp
);
9238 -- String_Literal case. This needs to be handled specially be-
9239 -- cause no index types are available for string literals. The
9240 -- condition is simply:
9242 -- T_Typ'Length = string-literal-length
9244 if Nkind
(Expr_Actual
) = N_String_Literal
then
9247 -- General array case. Here we have a usable actual subtype for
9248 -- the expression, and the condition is built from the two types
9250 -- T_Typ'First < Exptyp'First or else
9251 -- T_Typ'Last > Exptyp'Last or else
9252 -- T_Typ'First(1) < Exptyp'First(1) or else
9253 -- T_Typ'Last(1) > Exptyp'Last(1) or else
9256 elsif Is_Constrained
(Exptyp
) then
9258 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9264 L_Index
:= First_Index
(T_Typ
);
9265 R_Index
:= First_Index
(Exptyp
);
9267 for Indx
in 1 .. Ndims
loop
9268 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
9270 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
9272 -- Deal with compile time length check. Note that we
9273 -- skip this in the access case, because the access
9274 -- value may be null, so we cannot know statically.
9277 Subtypes_Statically_Match
9278 (Etype
(L_Index
), Etype
(R_Index
))
9280 -- If the target type is constrained then we
9281 -- have to check for exact equality of bounds
9282 -- (required for qualified expressions).
9284 if Is_Constrained
(T_Typ
) then
9287 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
9290 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
9300 -- Handle cases where we do not get a usable actual subtype that
9301 -- is constrained. This happens for example in the function call
9302 -- and explicit dereference cases. In these cases, we have to get
9303 -- the length or range from the expression itself, making sure we
9304 -- do not evaluate it more than once.
9306 -- Here Ck_Node is the original expression, or more properly the
9307 -- result of applying Duplicate_Expr to the original tree,
9308 -- forcing the result to be a name.
9312 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9315 -- Build the condition for the explicit dereference case
9317 for Indx
in 1 .. Ndims
loop
9319 (Cond
, Range_N_Cond
(Ck_Node
, T_Typ
, Indx
));
9325 -- For a conversion to an unconstrained array type, generate an
9326 -- Action to check that the bounds of the source value are within
9327 -- the constraints imposed by the target type (RM 4.6(38)). No
9328 -- check is needed for a conversion to an access to unconstrained
9329 -- array type, as 4.6(24.15/2) requires the designated subtypes
9330 -- of the two access types to statically match.
9332 if Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
9333 and then not Do_Access
9336 Opnd_Index
: Node_Id
;
9337 Targ_Index
: Node_Id
;
9338 Opnd_Range
: Node_Id
;
9341 Opnd_Index
:= First_Index
(Get_Actual_Subtype
(Ck_Node
));
9342 Targ_Index
:= First_Index
(T_Typ
);
9343 while Present
(Opnd_Index
) loop
9345 -- If the index is a range, use its bounds. If it is an
9346 -- entity (as will be the case if it is a named subtype
9347 -- or an itype created for a slice) retrieve its range.
9349 if Is_Entity_Name
(Opnd_Index
)
9350 and then Is_Type
(Entity
(Opnd_Index
))
9352 Opnd_Range
:= Scalar_Range
(Entity
(Opnd_Index
));
9354 Opnd_Range
:= Opnd_Index
;
9357 if Nkind
(Opnd_Range
) = N_Range
then
9359 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9360 Assume_Valid
=> True)
9363 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9364 Assume_Valid
=> True)
9368 -- If null range, no check needed
9371 Compile_Time_Known_Value
(High_Bound
(Opnd_Range
))
9373 Compile_Time_Known_Value
(Low_Bound
(Opnd_Range
))
9375 Expr_Value
(High_Bound
(Opnd_Range
)) <
9376 Expr_Value
(Low_Bound
(Opnd_Range
))
9380 elsif Is_Out_Of_Range
9381 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9382 Assume_Valid
=> True)
9385 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9386 Assume_Valid
=> True)
9389 (Compile_Time_Constraint_Error
9390 (Wnode
, "value out of range of}??", T_Typ
));
9396 (Opnd_Range
, Etype
(Targ_Index
)));
9400 Next_Index
(Opnd_Index
);
9401 Next_Index
(Targ_Index
);
9408 -- Construct the test and insert into the tree
9410 if Present
(Cond
) then
9412 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
9416 (Make_Raise_Constraint_Error
(Loc
,
9418 Reason
=> CE_Range_Check_Failed
));
9422 end Selected_Range_Checks
;
9424 -------------------------------
9425 -- Storage_Checks_Suppressed --
9426 -------------------------------
9428 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9430 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9431 return Is_Check_Suppressed
(E
, Storage_Check
);
9433 return Scope_Suppress
.Suppress
(Storage_Check
);
9435 end Storage_Checks_Suppressed
;
9437 ---------------------------
9438 -- Tag_Checks_Suppressed --
9439 ---------------------------
9441 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9444 and then Checks_May_Be_Suppressed
(E
)
9446 return Is_Check_Suppressed
(E
, Tag_Check
);
9448 return Scope_Suppress
.Suppress
(Tag_Check
);
9450 end Tag_Checks_Suppressed
;
9452 --------------------------
9453 -- Validity_Check_Range --
9454 --------------------------
9456 procedure Validity_Check_Range
(N
: Node_Id
) is
9458 if Validity_Checks_On
and Validity_Check_Operands
then
9459 if Nkind
(N
) = N_Range
then
9460 Ensure_Valid
(Low_Bound
(N
));
9461 Ensure_Valid
(High_Bound
(N
));
9464 end Validity_Check_Range
;
9466 --------------------------------
9467 -- Validity_Checks_Suppressed --
9468 --------------------------------
9470 function Validity_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9472 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9473 return Is_Check_Suppressed
(E
, Validity_Check
);
9475 return Scope_Suppress
.Suppress
(Validity_Check
);
9477 end Validity_Checks_Suppressed
;