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 Debug
; use Debug
;
28 with Einfo
; use Einfo
;
29 with Errout
; use Errout
;
30 with Exp_Ch2
; use Exp_Ch2
;
31 with Exp_Ch4
; use Exp_Ch4
;
32 with Exp_Ch11
; use Exp_Ch11
;
33 with Exp_Pakd
; use Exp_Pakd
;
34 with Exp_Tss
; use Exp_Tss
;
35 with Exp_Util
; use Exp_Util
;
36 with Elists
; use Elists
;
37 with Expander
; use Expander
;
38 with Eval_Fat
; use Eval_Fat
;
39 with Freeze
; use Freeze
;
41 with Nlists
; use Nlists
;
42 with Nmake
; use Nmake
;
44 with Output
; use Output
;
45 with Restrict
; use Restrict
;
46 with Rident
; use Rident
;
47 with Rtsfind
; use Rtsfind
;
49 with Sem_Aux
; use Sem_Aux
;
50 with Sem_Eval
; use Sem_Eval
;
51 with Sem_Ch3
; use Sem_Ch3
;
52 with Sem_Ch8
; use Sem_Ch8
;
53 with Sem_Res
; use Sem_Res
;
54 with Sem_Util
; use Sem_Util
;
55 with Sem_Warn
; use Sem_Warn
;
56 with Sinfo
; use Sinfo
;
57 with Sinput
; use Sinput
;
58 with Snames
; use Snames
;
59 with Sprint
; use Sprint
;
60 with Stand
; use Stand
;
61 with Stringt
; use Stringt
;
62 with Targparm
; use Targparm
;
63 with Tbuild
; use Tbuild
;
64 with Ttypes
; use Ttypes
;
65 with Urealp
; use Urealp
;
66 with Validsw
; use Validsw
;
68 package body Checks
is
70 -- General note: many of these routines are concerned with generating
71 -- checking code to make sure that constraint error is raised at runtime.
72 -- Clearly this code is only needed if the expander is active, since
73 -- otherwise we will not be generating code or going into the runtime
76 -- We therefore disconnect most of these checks if the expander is
77 -- inactive. This has the additional benefit that we do not need to
78 -- worry about the tree being messed up by previous errors (since errors
79 -- turn off expansion anyway).
81 -- There are a few exceptions to the above rule. For instance routines
82 -- such as Apply_Scalar_Range_Check that do not insert any code can be
83 -- safely called even when the Expander is inactive (but Errors_Detected
84 -- is 0). The benefit of executing this code when expansion is off, is
85 -- the ability to emit constraint error warning for static expressions
86 -- even when we are not generating code.
88 -------------------------------------
89 -- Suppression of Redundant Checks --
90 -------------------------------------
92 -- This unit implements a limited circuit for removal of redundant
93 -- checks. The processing is based on a tracing of simple sequential
94 -- flow. For any sequence of statements, we save expressions that are
95 -- marked to be checked, and then if the same expression appears later
96 -- with the same check, then under certain circumstances, the second
97 -- check can be suppressed.
99 -- Basically, we can suppress the check if we know for certain that
100 -- the previous expression has been elaborated (together with its
101 -- check), and we know that the exception frame is the same, and that
102 -- nothing has happened to change the result of the exception.
104 -- Let us examine each of these three conditions in turn to describe
105 -- how we ensure that this condition is met.
107 -- First, we need to know for certain that the previous expression has
108 -- been executed. This is done principally by the mechanism of calling
109 -- Conditional_Statements_Begin at the start of any statement sequence
110 -- and Conditional_Statements_End at the end. The End call causes all
111 -- checks remembered since the Begin call to be discarded. This does
112 -- miss a few cases, notably the case of a nested BEGIN-END block with
113 -- no exception handlers. But the important thing is to be conservative.
114 -- The other protection is that all checks are discarded if a label
115 -- is encountered, since then the assumption of sequential execution
116 -- is violated, and we don't know enough about the flow.
118 -- Second, we need to know that the exception frame is the same. We
119 -- do this by killing all remembered checks when we enter a new frame.
120 -- Again, that's over-conservative, but generally the cases we can help
121 -- with are pretty local anyway (like the body of a loop for example).
123 -- Third, we must be sure to forget any checks which are no longer valid.
124 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
125 -- used to note any changes to local variables. We only attempt to deal
126 -- with checks involving local variables, so we do not need to worry
127 -- about global variables. Second, a call to any non-global procedure
128 -- causes us to abandon all stored checks, since such a all may affect
129 -- the values of any local variables.
131 -- The following define the data structures used to deal with remembering
132 -- checks so that redundant checks can be eliminated as described above.
134 -- Right now, the only expressions that we deal with are of the form of
135 -- simple local objects (either declared locally, or IN parameters) or
136 -- such objects plus/minus a compile time known constant. We can do
137 -- more later on if it seems worthwhile, but this catches many simple
138 -- cases in practice.
140 -- The following record type reflects a single saved check. An entry
141 -- is made in the stack of saved checks if and only if the expression
142 -- has been elaborated with the indicated checks.
144 type Saved_Check
is record
146 -- Set True if entry is killed by Kill_Checks
149 -- The entity involved in the expression that is checked
152 -- A compile time value indicating the result of adding or
153 -- subtracting a compile time value. This value is to be
154 -- added to the value of the Entity. A value of zero is
155 -- used for the case of a simple entity reference.
157 Check_Type
: Character;
158 -- This is set to 'R' for a range check (in which case Target_Type
159 -- is set to the target type for the range check) or to 'O' for an
160 -- overflow check (in which case Target_Type is set to Empty).
162 Target_Type
: Entity_Id
;
163 -- Used only if Do_Range_Check is set. Records the target type for
164 -- the check. We need this, because a check is a duplicate only if
165 -- it has the same target type (or more accurately one with a
166 -- range that is smaller or equal to the stored target type of a
170 -- The following table keeps track of saved checks. Rather than use an
171 -- extensible table. We just use a table of fixed size, and we discard
172 -- any saved checks that do not fit. That's very unlikely to happen and
173 -- this is only an optimization in any case.
175 Saved_Checks
: array (Int
range 1 .. 200) of Saved_Check
;
176 -- Array of saved checks
178 Num_Saved_Checks
: Nat
:= 0;
179 -- Number of saved checks
181 -- The following stack keeps track of statement ranges. It is treated
182 -- as a stack. When Conditional_Statements_Begin is called, an entry
183 -- is pushed onto this stack containing the value of Num_Saved_Checks
184 -- at the time of the call. Then when Conditional_Statements_End is
185 -- called, this value is popped off and used to reset Num_Saved_Checks.
187 -- Note: again, this is a fixed length stack with a size that should
188 -- always be fine. If the value of the stack pointer goes above the
189 -- limit, then we just forget all saved checks.
191 Saved_Checks_Stack
: array (Int
range 1 .. 100) of Nat
;
192 Saved_Checks_TOS
: Nat
:= 0;
194 -----------------------
195 -- Local Subprograms --
196 -----------------------
198 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
);
199 -- Used to apply arithmetic overflow checks for all cases except operators
200 -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we
201 -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a
202 -- signed integer arithmetic operator (but not an if or case expression).
203 -- It is also called for types other than signed integers.
205 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
);
206 -- Used to apply arithmetic overflow checks for the case where the overflow
207 -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer
208 -- arithmetic op (which includes the case of if and case expressions). Note
209 -- that Do_Overflow_Check may or may not be set for node Op. In these modes
210 -- we have work to do even if overflow checking is suppressed.
212 procedure Apply_Division_Check
217 -- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies
218 -- division checks as required if the Do_Division_Check flag is set.
219 -- Rlo and Rhi give the possible range of the right operand, these values
220 -- can be referenced and trusted only if ROK is set True.
222 procedure Apply_Float_Conversion_Check
224 Target_Typ
: Entity_Id
);
225 -- The checks on a conversion from a floating-point type to an integer
226 -- type are delicate. They have to be performed before conversion, they
227 -- have to raise an exception when the operand is a NaN, and rounding must
228 -- be taken into account to determine the safe bounds of the operand.
230 procedure Apply_Selected_Length_Checks
232 Target_Typ
: Entity_Id
;
233 Source_Typ
: Entity_Id
;
234 Do_Static
: Boolean);
235 -- This is the subprogram that does all the work for Apply_Length_Check
236 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
237 -- described for the above routines. The Do_Static flag indicates that
238 -- only a static check is to be done.
240 procedure Apply_Selected_Range_Checks
242 Target_Typ
: Entity_Id
;
243 Source_Typ
: Entity_Id
;
244 Do_Static
: Boolean);
245 -- This is the subprogram that does all the work for Apply_Range_Check.
246 -- Expr, Target_Typ and Source_Typ are as described for the above
247 -- routine. The Do_Static flag indicates that only a static check is
250 type Check_Type
is new Check_Id
range Access_Check
.. Division_Check
;
251 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean;
252 -- This function is used to see if an access or division by zero check is
253 -- needed. The check is to be applied to a single variable appearing in the
254 -- source, and N is the node for the reference. If N is not of this form,
255 -- True is returned with no further processing. If N is of the right form,
256 -- then further processing determines if the given Check is needed.
258 -- The particular circuit is to see if we have the case of a check that is
259 -- not needed because it appears in the right operand of a short circuited
260 -- conditional where the left operand guards the check. For example:
262 -- if Var = 0 or else Q / Var > 12 then
266 -- In this example, the division check is not required. At the same time
267 -- we can issue warnings for suspicious use of non-short-circuited forms,
270 -- if Var = 0 or Q / Var > 12 then
276 Check_Type
: Character;
277 Target_Type
: Entity_Id
;
278 Entry_OK
: out Boolean;
282 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
283 -- to see if a check is of the form for optimization, and if so, to see
284 -- if it has already been performed. Expr is the expression to check,
285 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
286 -- Target_Type is the target type for a range check, and Empty for an
287 -- overflow check. If the entry is not of the form for optimization,
288 -- then Entry_OK is set to False, and the remaining out parameters
289 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
290 -- entity and offset from the expression. Check_Num is the number of
291 -- a matching saved entry in Saved_Checks, or zero if no such entry
294 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
;
295 -- If a discriminal is used in constraining a prival, Return reference
296 -- to the discriminal of the protected body (which renames the parameter
297 -- of the enclosing protected operation). This clumsy transformation is
298 -- needed because privals are created too late and their actual subtypes
299 -- are not available when analysing the bodies of the protected operations.
300 -- This function is called whenever the bound is an entity and the scope
301 -- indicates a protected operation. If the bound is an in-parameter of
302 -- a protected operation that is not a prival, the function returns the
304 -- To be cleaned up???
306 function Guard_Access
309 Ck_Node
: Node_Id
) return Node_Id
;
310 -- In the access type case, guard the test with a test to ensure
311 -- that the access value is non-null, since the checks do not
312 -- not apply to null access values.
314 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
);
315 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
316 -- Constraint_Error node.
318 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean;
319 -- Returns True if node N is for an arithmetic operation with signed
320 -- integer operands. This includes unary and binary operators, and also
321 -- if and case expression nodes where the dependent expressions are of
322 -- a signed integer type. These are the kinds of nodes for which special
323 -- handling applies in MINIMIZED or ELIMINATED overflow checking mode.
325 function Range_Or_Validity_Checks_Suppressed
326 (Expr
: Node_Id
) return Boolean;
327 -- Returns True if either range or validity checks or both are suppressed
328 -- for the type of the given expression, or, if the expression is the name
329 -- of an entity, if these checks are suppressed for the entity.
331 function Selected_Length_Checks
333 Target_Typ
: Entity_Id
;
334 Source_Typ
: Entity_Id
;
335 Warn_Node
: Node_Id
) return Check_Result
;
336 -- Like Apply_Selected_Length_Checks, except it doesn't modify
337 -- anything, just returns a list of nodes as described in the spec of
338 -- this package for the Range_Check function.
340 function Selected_Range_Checks
342 Target_Typ
: Entity_Id
;
343 Source_Typ
: Entity_Id
;
344 Warn_Node
: Node_Id
) return Check_Result
;
345 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
346 -- just returns a list of nodes as described in the spec of this package
347 -- for the Range_Check function.
349 ------------------------------
350 -- Access_Checks_Suppressed --
351 ------------------------------
353 function Access_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
355 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
356 return Is_Check_Suppressed
(E
, Access_Check
);
358 return Scope_Suppress
.Suppress
(Access_Check
);
360 end Access_Checks_Suppressed
;
362 -------------------------------------
363 -- Accessibility_Checks_Suppressed --
364 -------------------------------------
366 function Accessibility_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
368 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
369 return Is_Check_Suppressed
(E
, Accessibility_Check
);
371 return Scope_Suppress
.Suppress
(Accessibility_Check
);
373 end Accessibility_Checks_Suppressed
;
375 -----------------------------
376 -- Activate_Division_Check --
377 -----------------------------
379 procedure Activate_Division_Check
(N
: Node_Id
) is
381 Set_Do_Division_Check
(N
, True);
382 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
383 end Activate_Division_Check
;
385 -----------------------------
386 -- Activate_Overflow_Check --
387 -----------------------------
389 procedure Activate_Overflow_Check
(N
: Node_Id
) is
391 if not Nkind_In
(N
, N_Op_Rem
, N_Op_Mod
, N_Op_Plus
) then
392 Set_Do_Overflow_Check
(N
, True);
393 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
395 end Activate_Overflow_Check
;
397 --------------------------
398 -- Activate_Range_Check --
399 --------------------------
401 procedure Activate_Range_Check
(N
: Node_Id
) is
403 Set_Do_Range_Check
(N
, True);
404 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
405 end Activate_Range_Check
;
407 ---------------------------------
408 -- Alignment_Checks_Suppressed --
409 ---------------------------------
411 function Alignment_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
413 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
414 return Is_Check_Suppressed
(E
, Alignment_Check
);
416 return Scope_Suppress
.Suppress
(Alignment_Check
);
418 end Alignment_Checks_Suppressed
;
420 -------------------------
421 -- Append_Range_Checks --
422 -------------------------
424 procedure Append_Range_Checks
425 (Checks
: Check_Result
;
427 Suppress_Typ
: Entity_Id
;
428 Static_Sloc
: Source_Ptr
;
431 Internal_Flag_Node
: constant Node_Id
:= Flag_Node
;
432 Internal_Static_Sloc
: constant Source_Ptr
:= Static_Sloc
;
434 Checks_On
: constant Boolean :=
435 (not Index_Checks_Suppressed
(Suppress_Typ
))
436 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
439 -- For now we just return if Checks_On is false, however this should
440 -- be enhanced to check for an always True value in the condition
441 -- and to generate a compilation warning???
443 if not Checks_On
then
448 exit when No
(Checks
(J
));
450 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
451 and then Present
(Condition
(Checks
(J
)))
453 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
454 Append_To
(Stmts
, Checks
(J
));
455 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
461 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
462 Reason
=> CE_Range_Check_Failed
));
465 end Append_Range_Checks
;
467 ------------------------
468 -- Apply_Access_Check --
469 ------------------------
471 procedure Apply_Access_Check
(N
: Node_Id
) is
472 P
: constant Node_Id
:= Prefix
(N
);
475 -- We do not need checks if we are not generating code (i.e. the
476 -- expander is not active). This is not just an optimization, there
477 -- are cases (e.g. with pragma Debug) where generating the checks
478 -- can cause real trouble).
480 if not Full_Expander_Active
then
484 -- No check if short circuiting makes check unnecessary
486 if not Check_Needed
(P
, Access_Check
) then
490 -- No check if accessing the Offset_To_Top component of a dispatch
491 -- table. They are safe by construction.
493 if Tagged_Type_Expansion
494 and then Present
(Etype
(P
))
495 and then RTU_Loaded
(Ada_Tags
)
496 and then RTE_Available
(RE_Offset_To_Top_Ptr
)
497 and then Etype
(P
) = RTE
(RE_Offset_To_Top_Ptr
)
502 -- Otherwise go ahead and install the check
504 Install_Null_Excluding_Check
(P
);
505 end Apply_Access_Check
;
507 -------------------------------
508 -- Apply_Accessibility_Check --
509 -------------------------------
511 procedure Apply_Accessibility_Check
514 Insert_Node
: Node_Id
)
516 Loc
: constant Source_Ptr
:= Sloc
(N
);
517 Param_Ent
: Entity_Id
:= Param_Entity
(N
);
518 Param_Level
: Node_Id
;
519 Type_Level
: Node_Id
;
522 if Ada_Version
>= Ada_2012
523 and then not Present
(Param_Ent
)
524 and then Is_Entity_Name
(N
)
525 and then Ekind_In
(Entity
(N
), E_Constant
, E_Variable
)
526 and then Present
(Effective_Extra_Accessibility
(Entity
(N
)))
528 Param_Ent
:= Entity
(N
);
529 while Present
(Renamed_Object
(Param_Ent
)) loop
531 -- Renamed_Object must return an Entity_Name here
532 -- because of preceding "Present (E_E_A (...))" test.
534 Param_Ent
:= Entity
(Renamed_Object
(Param_Ent
));
538 if Inside_A_Generic
then
541 -- Only apply the run-time check if the access parameter has an
542 -- associated extra access level parameter and when the level of the
543 -- type is less deep than the level of the access parameter, and
544 -- accessibility checks are not suppressed.
546 elsif Present
(Param_Ent
)
547 and then Present
(Extra_Accessibility
(Param_Ent
))
548 and then UI_Gt
(Object_Access_Level
(N
),
549 Deepest_Type_Access_Level
(Typ
))
550 and then not Accessibility_Checks_Suppressed
(Param_Ent
)
551 and then not Accessibility_Checks_Suppressed
(Typ
)
554 New_Occurrence_Of
(Extra_Accessibility
(Param_Ent
), Loc
);
557 Make_Integer_Literal
(Loc
, Deepest_Type_Access_Level
(Typ
));
559 -- Raise Program_Error if the accessibility level of the access
560 -- parameter is deeper than the level of the target access type.
562 Insert_Action
(Insert_Node
,
563 Make_Raise_Program_Error
(Loc
,
566 Left_Opnd
=> Param_Level
,
567 Right_Opnd
=> Type_Level
),
568 Reason
=> PE_Accessibility_Check_Failed
));
570 Analyze_And_Resolve
(N
);
572 end Apply_Accessibility_Check
;
574 --------------------------------
575 -- Apply_Address_Clause_Check --
576 --------------------------------
578 procedure Apply_Address_Clause_Check
(E
: Entity_Id
; N
: Node_Id
) is
579 pragma Assert
(Nkind
(N
) = N_Freeze_Entity
);
581 AC
: constant Node_Id
:= Address_Clause
(E
);
582 Loc
: constant Source_Ptr
:= Sloc
(AC
);
583 Typ
: constant Entity_Id
:= Etype
(E
);
584 Aexp
: constant Node_Id
:= Expression
(AC
);
587 -- Address expression (not necessarily the same as Aexp, for example
588 -- when Aexp is a reference to a constant, in which case Expr gets
589 -- reset to reference the value expression of the constant.
591 procedure Compile_Time_Bad_Alignment
;
592 -- Post error warnings when alignment is known to be incompatible. Note
593 -- that we do not go as far as inserting a raise of Program_Error since
594 -- this is an erroneous case, and it may happen that we are lucky and an
595 -- underaligned address turns out to be OK after all.
597 --------------------------------
598 -- Compile_Time_Bad_Alignment --
599 --------------------------------
601 procedure Compile_Time_Bad_Alignment
is
603 if Address_Clause_Overlay_Warnings
then
605 ("?o?specified address for& may be inconsistent with alignment",
608 ("\?o?program execution may be erroneous (RM 13.3(27))",
610 Set_Address_Warning_Posted
(AC
);
612 end Compile_Time_Bad_Alignment
;
614 -- Start of processing for Apply_Address_Clause_Check
617 -- See if alignment check needed. Note that we never need a check if the
618 -- maximum alignment is one, since the check will always succeed.
620 -- Note: we do not check for checks suppressed here, since that check
621 -- was done in Sem_Ch13 when the address clause was processed. We are
622 -- only called if checks were not suppressed. The reason for this is
623 -- that we have to delay the call to Apply_Alignment_Check till freeze
624 -- time (so that all types etc are elaborated), but we have to check
625 -- the status of check suppressing at the point of the address clause.
628 or else not Check_Address_Alignment
(AC
)
629 or else Maximum_Alignment
= 1
634 -- Obtain expression from address clause
636 Expr
:= Expression
(AC
);
638 -- The following loop digs for the real expression to use in the check
641 -- For constant, get constant expression
643 if Is_Entity_Name
(Expr
)
644 and then Ekind
(Entity
(Expr
)) = E_Constant
646 Expr
:= Constant_Value
(Entity
(Expr
));
648 -- For unchecked conversion, get result to convert
650 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
651 Expr
:= Expression
(Expr
);
653 -- For (common case) of To_Address call, get argument
655 elsif Nkind
(Expr
) = N_Function_Call
656 and then Is_Entity_Name
(Name
(Expr
))
657 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
659 Expr
:= First
(Parameter_Associations
(Expr
));
661 if Nkind
(Expr
) = N_Parameter_Association
then
662 Expr
:= Explicit_Actual_Parameter
(Expr
);
665 -- We finally have the real expression
672 -- See if we know that Expr has a bad alignment at compile time
674 if Compile_Time_Known_Value
(Expr
)
675 and then (Known_Alignment
(E
) or else Known_Alignment
(Typ
))
678 AL
: Uint
:= Alignment
(Typ
);
681 -- The object alignment might be more restrictive than the
684 if Known_Alignment
(E
) then
688 if Expr_Value
(Expr
) mod AL
/= 0 then
689 Compile_Time_Bad_Alignment
;
695 -- If the expression has the form X'Address, then we can find out if
696 -- the object X has an alignment that is compatible with the object E.
697 -- If it hasn't or we don't know, we defer issuing the warning until
698 -- the end of the compilation to take into account back end annotations.
700 elsif Nkind
(Expr
) = N_Attribute_Reference
701 and then Attribute_Name
(Expr
) = Name_Address
702 and then Has_Compatible_Alignment
(E
, Prefix
(Expr
)) = Known_Compatible
707 -- Here we do not know if the value is acceptable. Strictly we don't
708 -- have to do anything, since if the alignment is bad, we have an
709 -- erroneous program. However we are allowed to check for erroneous
710 -- conditions and we decide to do this by default if the check is not
713 -- However, don't do the check if elaboration code is unwanted
715 if Restriction_Active
(No_Elaboration_Code
) then
718 -- Generate a check to raise PE if alignment may be inappropriate
721 -- If the original expression is a non-static constant, use the
722 -- name of the constant itself rather than duplicating its
723 -- defining expression, which was extracted above.
725 -- Note: Expr is empty if the address-clause is applied to in-mode
726 -- actuals (allowed by 13.1(22)).
728 if not Present
(Expr
)
730 (Is_Entity_Name
(Expression
(AC
))
731 and then Ekind
(Entity
(Expression
(AC
))) = E_Constant
732 and then Nkind
(Parent
(Entity
(Expression
(AC
))))
733 = N_Object_Declaration
)
735 Expr
:= New_Copy_Tree
(Expression
(AC
));
737 Remove_Side_Effects
(Expr
);
740 if No
(Actions
(N
)) then
741 Set_Actions
(N
, New_List
);
744 Prepend_To
(Actions
(N
),
745 Make_Raise_Program_Error
(Loc
,
752 (RTE
(RE_Integer_Address
), Expr
),
754 Make_Attribute_Reference
(Loc
,
755 Prefix
=> New_Occurrence_Of
(E
, Loc
),
756 Attribute_Name
=> Name_Alignment
)),
757 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
758 Reason
=> PE_Misaligned_Address_Value
));
759 Analyze
(First
(Actions
(N
)), Suppress
=> All_Checks
);
764 -- If we have some missing run time component in configurable run time
765 -- mode then just skip the check (it is not required in any case).
767 when RE_Not_Available
=>
769 end Apply_Address_Clause_Check
;
771 -------------------------------------
772 -- Apply_Arithmetic_Overflow_Check --
773 -------------------------------------
775 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
777 -- Use old routine in almost all cases (the only case we are treating
778 -- specially is the case of a signed integer arithmetic op with the
779 -- overflow checking mode set to MINIMIZED or ELIMINATED).
781 if Overflow_Check_Mode
= Strict
782 or else not Is_Signed_Integer_Arithmetic_Op
(N
)
784 Apply_Arithmetic_Overflow_Strict
(N
);
786 -- Otherwise use the new routine for the case of a signed integer
787 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
788 -- mode is MINIMIZED or ELIMINATED.
791 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
793 end Apply_Arithmetic_Overflow_Check
;
795 --------------------------------------
796 -- Apply_Arithmetic_Overflow_Strict --
797 --------------------------------------
799 -- This routine is called only if the type is an integer type, and a
800 -- software arithmetic overflow check may be needed for op (add, subtract,
801 -- or multiply). This check is performed only if Software_Overflow_Checking
802 -- is enabled and Do_Overflow_Check is set. In this case we expand the
803 -- operation into a more complex sequence of tests that ensures that
804 -- overflow is properly caught.
806 -- This is used in CHECKED modes. It is identical to the code for this
807 -- cases before the big overflow earthquake, thus ensuring that in this
808 -- modes we have compatible behavior (and reliability) to what was there
809 -- before. It is also called for types other than signed integers, and if
810 -- the Do_Overflow_Check flag is off.
812 -- Note: we also call this routine if we decide in the MINIMIZED case
813 -- to give up and just generate an overflow check without any fuss.
815 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
) is
816 Loc
: constant Source_Ptr
:= Sloc
(N
);
817 Typ
: constant Entity_Id
:= Etype
(N
);
818 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
821 -- Nothing to do if Do_Overflow_Check not set or overflow checks
824 if not Do_Overflow_Check
(N
) then
828 -- An interesting special case. If the arithmetic operation appears as
829 -- the operand of a type conversion:
833 -- and all the following conditions apply:
835 -- arithmetic operation is for a signed integer type
836 -- target type type1 is a static integer subtype
837 -- range of x and y are both included in the range of type1
838 -- range of x op y is included in the range of type1
839 -- size of type1 is at least twice the result size of op
841 -- then we don't do an overflow check in any case, instead we transform
842 -- the operation so that we end up with:
844 -- type1 (type1 (x) op type1 (y))
846 -- This avoids intermediate overflow before the conversion. It is
847 -- explicitly permitted by RM 3.5.4(24):
849 -- For the execution of a predefined operation of a signed integer
850 -- type, the implementation need not raise Constraint_Error if the
851 -- result is outside the base range of the type, so long as the
852 -- correct result is produced.
854 -- It's hard to imagine that any programmer counts on the exception
855 -- being raised in this case, and in any case it's wrong coding to
856 -- have this expectation, given the RM permission. Furthermore, other
857 -- Ada compilers do allow such out of range results.
859 -- Note that we do this transformation even if overflow checking is
860 -- off, since this is precisely about giving the "right" result and
861 -- avoiding the need for an overflow check.
863 -- Note: this circuit is partially redundant with respect to the similar
864 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
865 -- with cases that do not come through here. We still need the following
866 -- processing even with the Exp_Ch4 code in place, since we want to be
867 -- sure not to generate the arithmetic overflow check in these cases
868 -- (Exp_Ch4 would have a hard time removing them once generated).
870 if Is_Signed_Integer_Type
(Typ
)
871 and then Nkind
(Parent
(N
)) = N_Type_Conversion
873 Conversion_Optimization
: declare
874 Target_Type
: constant Entity_Id
:=
875 Base_Type
(Entity
(Subtype_Mark
(Parent
(N
))));
889 if Is_Integer_Type
(Target_Type
)
890 and then RM_Size
(Root_Type
(Target_Type
)) >= 2 * RM_Size
(Rtyp
)
892 Tlo
:= Expr_Value
(Type_Low_Bound
(Target_Type
));
893 Thi
:= Expr_Value
(Type_High_Bound
(Target_Type
));
896 (Left_Opnd
(N
), LOK
, Llo
, Lhi
, Assume_Valid
=> True);
898 (Right_Opnd
(N
), ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
901 and then Tlo
<= Llo
and then Lhi
<= Thi
902 and then Tlo
<= Rlo
and then Rhi
<= Thi
904 Determine_Range
(N
, VOK
, Vlo
, Vhi
, Assume_Valid
=> True);
906 if VOK
and then Tlo
<= Vlo
and then Vhi
<= Thi
then
907 Rewrite
(Left_Opnd
(N
),
908 Make_Type_Conversion
(Loc
,
909 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
910 Expression
=> Relocate_Node
(Left_Opnd
(N
))));
912 Rewrite
(Right_Opnd
(N
),
913 Make_Type_Conversion
(Loc
,
914 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
915 Expression
=> Relocate_Node
(Right_Opnd
(N
))));
917 -- Rewrite the conversion operand so that the original
918 -- node is retained, in order to avoid the warning for
919 -- redundant conversions in Resolve_Type_Conversion.
921 Rewrite
(N
, Relocate_Node
(N
));
923 Set_Etype
(N
, Target_Type
);
925 Analyze_And_Resolve
(Left_Opnd
(N
), Target_Type
);
926 Analyze_And_Resolve
(Right_Opnd
(N
), Target_Type
);
928 -- Given that the target type is twice the size of the
929 -- source type, overflow is now impossible, so we can
930 -- safely kill the overflow check and return.
932 Set_Do_Overflow_Check
(N
, False);
937 end Conversion_Optimization
;
940 -- Now see if an overflow check is required
943 Siz
: constant Int
:= UI_To_Int
(Esize
(Rtyp
));
944 Dsiz
: constant Int
:= Siz
* 2;
951 -- Skip check if back end does overflow checks, or the overflow flag
952 -- is not set anyway, or we are not doing code expansion, or the
953 -- parent node is a type conversion whose operand is an arithmetic
954 -- operation on signed integers on which the expander can promote
955 -- later the operands to type Integer (see Expand_N_Type_Conversion).
957 -- Special case CLI target, where arithmetic overflow checks can be
958 -- performed for integer and long_integer
960 if Backend_Overflow_Checks_On_Target
961 or else not Do_Overflow_Check
(N
)
962 or else not Full_Expander_Active
963 or else (Present
(Parent
(N
))
964 and then Nkind
(Parent
(N
)) = N_Type_Conversion
965 and then Integer_Promotion_Possible
(Parent
(N
)))
967 (VM_Target
= CLI_Target
and then Siz
>= Standard_Integer_Size
)
972 -- Otherwise, generate the full general code for front end overflow
973 -- detection, which works by doing arithmetic in a larger type:
979 -- Typ (Checktyp (x) op Checktyp (y));
981 -- where Typ is the type of the original expression, and Checktyp is
982 -- an integer type of sufficient length to hold the largest possible
985 -- If the size of check type exceeds the size of Long_Long_Integer,
986 -- we use a different approach, expanding to:
988 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
990 -- where xxx is Add, Multiply or Subtract as appropriate
992 -- Find check type if one exists
994 if Dsiz
<= Standard_Integer_Size
then
995 Ctyp
:= Standard_Integer
;
997 elsif Dsiz
<= Standard_Long_Long_Integer_Size
then
998 Ctyp
:= Standard_Long_Long_Integer
;
1000 -- No check type exists, use runtime call
1003 if Nkind
(N
) = N_Op_Add
then
1004 Cent
:= RE_Add_With_Ovflo_Check
;
1006 elsif Nkind
(N
) = N_Op_Multiply
then
1007 Cent
:= RE_Multiply_With_Ovflo_Check
;
1010 pragma Assert
(Nkind
(N
) = N_Op_Subtract
);
1011 Cent
:= RE_Subtract_With_Ovflo_Check
;
1016 Make_Function_Call
(Loc
,
1017 Name
=> New_Reference_To
(RTE
(Cent
), Loc
),
1018 Parameter_Associations
=> New_List
(
1019 OK_Convert_To
(RTE
(RE_Integer_64
), Left_Opnd
(N
)),
1020 OK_Convert_To
(RTE
(RE_Integer_64
), Right_Opnd
(N
))))));
1022 Analyze_And_Resolve
(N
, Typ
);
1026 -- If we fall through, we have the case where we do the arithmetic
1027 -- in the next higher type and get the check by conversion. In these
1028 -- cases Ctyp is set to the type to be used as the check type.
1030 Opnod
:= Relocate_Node
(N
);
1032 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
1035 Set_Etype
(Opnd
, Ctyp
);
1036 Set_Analyzed
(Opnd
, True);
1037 Set_Left_Opnd
(Opnod
, Opnd
);
1039 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
1042 Set_Etype
(Opnd
, Ctyp
);
1043 Set_Analyzed
(Opnd
, True);
1044 Set_Right_Opnd
(Opnod
, Opnd
);
1046 -- The type of the operation changes to the base type of the check
1047 -- type, and we reset the overflow check indication, since clearly no
1048 -- overflow is possible now that we are using a double length type.
1049 -- We also set the Analyzed flag to avoid a recursive attempt to
1052 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
1053 Set_Do_Overflow_Check
(Opnod
, False);
1054 Set_Analyzed
(Opnod
, True);
1056 -- Now build the outer conversion
1058 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
1060 Set_Etype
(Opnd
, Typ
);
1062 -- In the discrete type case, we directly generate the range check
1063 -- for the outer operand. This range check will implement the
1064 -- required overflow check.
1066 if Is_Discrete_Type
(Typ
) then
1068 Generate_Range_Check
1069 (Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
1071 -- For other types, we enable overflow checking on the conversion,
1072 -- after setting the node as analyzed to prevent recursive attempts
1073 -- to expand the conversion node.
1076 Set_Analyzed
(Opnd
, True);
1077 Enable_Overflow_Check
(Opnd
);
1082 when RE_Not_Available
=>
1085 end Apply_Arithmetic_Overflow_Strict
;
1087 ----------------------------------------------------
1088 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1089 ----------------------------------------------------
1091 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
) is
1092 pragma Assert
(Is_Signed_Integer_Arithmetic_Op
(Op
));
1094 Loc
: constant Source_Ptr
:= Sloc
(Op
);
1095 P
: constant Node_Id
:= Parent
(Op
);
1097 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
1098 -- Operands and results are of this type when we convert
1100 Result_Type
: constant Entity_Id
:= Etype
(Op
);
1101 -- Original result type
1103 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1104 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
1107 -- Ranges of values for result
1110 -- Nothing to do if our parent is one of the following:
1112 -- Another signed integer arithmetic op
1113 -- A membership operation
1114 -- A comparison operation
1116 -- In all these cases, we will process at the higher level (and then
1117 -- this node will be processed during the downwards recursion that
1118 -- is part of the processing in Minimize_Eliminate_Overflows).
1120 if Is_Signed_Integer_Arithmetic_Op
(P
)
1121 or else Nkind
(P
) in N_Membership_Test
1122 or else Nkind
(P
) in N_Op_Compare
1124 -- This is also true for an alternative in a case expression
1126 or else Nkind
(P
) = N_Case_Expression_Alternative
1128 -- This is also true for a range operand in a membership test
1130 or else (Nkind
(P
) = N_Range
1131 and then Nkind
(Parent
(P
)) in N_Membership_Test
)
1136 -- Otherwise, we have a top level arithmetic operation node, and this
1137 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1138 -- modes. This is the case where we tell the machinery not to move into
1139 -- Bignum mode at this top level (of course the top level operation
1140 -- will still be in Bignum mode if either of its operands are of type
1143 Minimize_Eliminate_Overflows
(Op
, Lo
, Hi
, Top_Level
=> True);
1145 -- That call may but does not necessarily change the result type of Op.
1146 -- It is the job of this routine to undo such changes, so that at the
1147 -- top level, we have the proper type. This "undoing" is a point at
1148 -- which a final overflow check may be applied.
1150 -- If the result type was not fiddled we are all set. We go to base
1151 -- types here because things may have been rewritten to generate the
1152 -- base type of the operand types.
1154 if Base_Type
(Etype
(Op
)) = Base_Type
(Result_Type
) then
1159 elsif Is_RTE
(Etype
(Op
), RE_Bignum
) then
1161 -- We need a sequence that looks like:
1163 -- Rnn : Result_Type;
1166 -- M : Mark_Id := SS_Mark;
1168 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1172 -- This block is inserted (using Insert_Actions), and then the node
1173 -- is replaced with a reference to Rnn.
1175 -- A special case arises if our parent is a conversion node. In this
1176 -- case no point in generating a conversion to Result_Type, we will
1177 -- let the parent handle this. Note that this special case is not
1178 -- just about optimization. Consider
1182 -- X := Long_Long_Integer'Base (A * (B ** C));
1184 -- Now the product may fit in Long_Long_Integer but not in Integer.
1185 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1186 -- overflow exception for this intermediate value.
1189 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
1190 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R', Op
);
1196 RHS
:= Convert_From_Bignum
(Op
);
1198 if Nkind
(P
) /= N_Type_Conversion
then
1199 Convert_To_And_Rewrite
(Result_Type
, RHS
);
1200 Rtype
:= Result_Type
;
1202 -- Interesting question, do we need a check on that conversion
1203 -- operation. Answer, not if we know the result is in range.
1204 -- At the moment we are not taking advantage of this. To be
1205 -- looked at later ???
1212 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
1213 Make_Assignment_Statement
(Loc
,
1214 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
1215 Expression
=> RHS
));
1217 Insert_Actions
(Op
, New_List
(
1218 Make_Object_Declaration
(Loc
,
1219 Defining_Identifier
=> Rnn
,
1220 Object_Definition
=> New_Occurrence_Of
(Rtype
, Loc
)),
1223 Rewrite
(Op
, New_Occurrence_Of
(Rnn
, Loc
));
1224 Analyze_And_Resolve
(Op
);
1227 -- Here we know the result is Long_Long_Integer'Base, of that it has
1228 -- been rewritten because the parent operation is a conversion. See
1229 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1233 (Etype
(Op
) = LLIB
or else Nkind
(Parent
(Op
)) = N_Type_Conversion
);
1235 -- All we need to do here is to convert the result to the proper
1236 -- result type. As explained above for the Bignum case, we can
1237 -- omit this if our parent is a type conversion.
1239 if Nkind
(P
) /= N_Type_Conversion
then
1240 Convert_To_And_Rewrite
(Result_Type
, Op
);
1243 Analyze_And_Resolve
(Op
);
1245 end Apply_Arithmetic_Overflow_Minimized_Eliminated
;
1247 ----------------------------
1248 -- Apply_Constraint_Check --
1249 ----------------------------
1251 procedure Apply_Constraint_Check
1254 No_Sliding
: Boolean := False)
1256 Desig_Typ
: Entity_Id
;
1259 -- No checks inside a generic (check the instantiations)
1261 if Inside_A_Generic
then
1265 -- Apply required constraint checks
1267 if Is_Scalar_Type
(Typ
) then
1268 Apply_Scalar_Range_Check
(N
, Typ
);
1270 elsif Is_Array_Type
(Typ
) then
1272 -- A useful optimization: an aggregate with only an others clause
1273 -- always has the right bounds.
1275 if Nkind
(N
) = N_Aggregate
1276 and then No
(Expressions
(N
))
1278 (First
(Choices
(First
(Component_Associations
(N
)))))
1284 if Is_Constrained
(Typ
) then
1285 Apply_Length_Check
(N
, Typ
);
1288 Apply_Range_Check
(N
, Typ
);
1291 Apply_Range_Check
(N
, Typ
);
1294 elsif (Is_Record_Type
(Typ
) or else Is_Private_Type
(Typ
))
1295 and then Has_Discriminants
(Base_Type
(Typ
))
1296 and then Is_Constrained
(Typ
)
1298 Apply_Discriminant_Check
(N
, Typ
);
1300 elsif Is_Access_Type
(Typ
) then
1302 Desig_Typ
:= Designated_Type
(Typ
);
1304 -- No checks necessary if expression statically null
1306 if Known_Null
(N
) then
1307 if Can_Never_Be_Null
(Typ
) then
1308 Install_Null_Excluding_Check
(N
);
1311 -- No sliding possible on access to arrays
1313 elsif Is_Array_Type
(Desig_Typ
) then
1314 if Is_Constrained
(Desig_Typ
) then
1315 Apply_Length_Check
(N
, Typ
);
1318 Apply_Range_Check
(N
, Typ
);
1320 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
1321 and then Is_Constrained
(Desig_Typ
)
1323 Apply_Discriminant_Check
(N
, Typ
);
1326 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1327 -- this check if the constraint node is illegal, as shown by having
1328 -- an error posted. This additional guard prevents cascaded errors
1329 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1331 if Can_Never_Be_Null
(Typ
)
1332 and then not Can_Never_Be_Null
(Etype
(N
))
1333 and then not Error_Posted
(N
)
1335 Install_Null_Excluding_Check
(N
);
1338 end Apply_Constraint_Check
;
1340 ------------------------------
1341 -- Apply_Discriminant_Check --
1342 ------------------------------
1344 procedure Apply_Discriminant_Check
1347 Lhs
: Node_Id
:= Empty
)
1349 Loc
: constant Source_Ptr
:= Sloc
(N
);
1350 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1351 S_Typ
: Entity_Id
:= Etype
(N
);
1355 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean;
1356 -- A heap object with an indefinite subtype is constrained by its
1357 -- initial value, and assigning to it requires a constraint_check.
1358 -- The target may be an explicit dereference, or a renaming of one.
1360 function Is_Aliased_Unconstrained_Component
return Boolean;
1361 -- It is possible for an aliased component to have a nominal
1362 -- unconstrained subtype (through instantiation). If this is a
1363 -- discriminated component assigned in the expansion of an aggregate
1364 -- in an initialization, the check must be suppressed. This unusual
1365 -- situation requires a predicate of its own.
1367 ----------------------------------
1368 -- Denotes_Explicit_Dereference --
1369 ----------------------------------
1371 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean is
1374 Nkind
(Obj
) = N_Explicit_Dereference
1376 (Is_Entity_Name
(Obj
)
1377 and then Present
(Renamed_Object
(Entity
(Obj
)))
1378 and then Nkind
(Renamed_Object
(Entity
(Obj
))) =
1379 N_Explicit_Dereference
);
1380 end Denotes_Explicit_Dereference
;
1382 ----------------------------------------
1383 -- Is_Aliased_Unconstrained_Component --
1384 ----------------------------------------
1386 function Is_Aliased_Unconstrained_Component
return Boolean is
1391 if Nkind
(Lhs
) /= N_Selected_Component
then
1394 Comp
:= Entity
(Selector_Name
(Lhs
));
1395 Pref
:= Prefix
(Lhs
);
1398 if Ekind
(Comp
) /= E_Component
1399 or else not Is_Aliased
(Comp
)
1404 return not Comes_From_Source
(Pref
)
1405 and then In_Instance
1406 and then not Is_Constrained
(Etype
(Comp
));
1407 end Is_Aliased_Unconstrained_Component
;
1409 -- Start of processing for Apply_Discriminant_Check
1413 T_Typ
:= Designated_Type
(Typ
);
1418 -- Nothing to do if discriminant checks are suppressed or else no code
1419 -- is to be generated
1421 if not Full_Expander_Active
1422 or else Discriminant_Checks_Suppressed
(T_Typ
)
1427 -- No discriminant checks necessary for an access when expression is
1428 -- statically Null. This is not only an optimization, it is fundamental
1429 -- because otherwise discriminant checks may be generated in init procs
1430 -- for types containing an access to a not-yet-frozen record, causing a
1431 -- deadly forward reference.
1433 -- Also, if the expression is of an access type whose designated type is
1434 -- incomplete, then the access value must be null and we suppress the
1437 if Known_Null
(N
) then
1440 elsif Is_Access_Type
(S_Typ
) then
1441 S_Typ
:= Designated_Type
(S_Typ
);
1443 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1448 -- If an assignment target is present, then we need to generate the
1449 -- actual subtype if the target is a parameter or aliased object with
1450 -- an unconstrained nominal subtype.
1452 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1453 -- subtype to the parameter and dereference cases, since other aliased
1454 -- objects are unconstrained (unless the nominal subtype is explicitly
1458 and then (Present
(Param_Entity
(Lhs
))
1459 or else (Ada_Version
< Ada_2005
1460 and then not Is_Constrained
(T_Typ
)
1461 and then Is_Aliased_View
(Lhs
)
1462 and then not Is_Aliased_Unconstrained_Component
)
1463 or else (Ada_Version
>= Ada_2005
1464 and then not Is_Constrained
(T_Typ
)
1465 and then Denotes_Explicit_Dereference
(Lhs
)
1466 and then Nkind
(Original_Node
(Lhs
)) /=
1469 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1472 -- Nothing to do if the type is unconstrained (this is the case where
1473 -- the actual subtype in the RM sense of N is unconstrained and no check
1476 if not Is_Constrained
(T_Typ
) then
1479 -- Ada 2005: nothing to do if the type is one for which there is a
1480 -- partial view that is constrained.
1482 elsif Ada_Version
>= Ada_2005
1483 and then Object_Type_Has_Constrained_Partial_View
1484 (Typ
=> Base_Type
(T_Typ
),
1485 Scop
=> Current_Scope
)
1490 -- Nothing to do if the type is an Unchecked_Union
1492 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
1496 -- Suppress checks if the subtypes are the same. the check must be
1497 -- preserved in an assignment to a formal, because the constraint is
1498 -- given by the actual.
1500 if Nkind
(Original_Node
(N
)) /= N_Allocator
1502 or else not Is_Entity_Name
(Lhs
)
1503 or else No
(Param_Entity
(Lhs
)))
1506 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1507 and then not Is_Aliased_View
(Lhs
)
1512 -- We can also eliminate checks on allocators with a subtype mark that
1513 -- coincides with the context type. The context type may be a subtype
1514 -- without a constraint (common case, a generic actual).
1516 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1517 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1520 Alloc_Typ
: constant Entity_Id
:=
1521 Entity
(Expression
(Original_Node
(N
)));
1524 if Alloc_Typ
= T_Typ
1525 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1526 and then Is_Entity_Name
(
1527 Subtype_Indication
(Parent
(T_Typ
)))
1528 and then Alloc_Typ
= Base_Type
(T_Typ
))
1536 -- See if we have a case where the types are both constrained, and all
1537 -- the constraints are constants. In this case, we can do the check
1538 -- successfully at compile time.
1540 -- We skip this check for the case where the node is rewritten`as
1541 -- an allocator, because it already carries the context subtype,
1542 -- and extracting the discriminants from the aggregate is messy.
1544 if Is_Constrained
(S_Typ
)
1545 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1555 -- S_Typ may not have discriminants in the case where it is a
1556 -- private type completed by a default discriminated type. In that
1557 -- case, we need to get the constraints from the underlying_type.
1558 -- If the underlying type is unconstrained (i.e. has no default
1559 -- discriminants) no check is needed.
1561 if Has_Discriminants
(S_Typ
) then
1562 Discr
:= First_Discriminant
(S_Typ
);
1563 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1566 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1569 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1575 -- A further optimization: if T_Typ is derived from S_Typ
1576 -- without imposing a constraint, no check is needed.
1578 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1579 N_Full_Type_Declaration
1582 Type_Def
: constant Node_Id
:=
1583 Type_Definition
(Original_Node
(Parent
(T_Typ
)));
1585 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1586 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1587 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1595 -- Constraint may appear in full view of type
1597 if Ekind
(T_Typ
) = E_Private_Subtype
1598 and then Present
(Full_View
(T_Typ
))
1601 First_Elmt
(Discriminant_Constraint
(Full_View
(T_Typ
)));
1604 First_Elmt
(Discriminant_Constraint
(T_Typ
));
1607 while Present
(Discr
) loop
1608 ItemS
:= Node
(DconS
);
1609 ItemT
:= Node
(DconT
);
1611 -- For a discriminated component type constrained by the
1612 -- current instance of an enclosing type, there is no
1613 -- applicable discriminant check.
1615 if Nkind
(ItemT
) = N_Attribute_Reference
1616 and then Is_Access_Type
(Etype
(ItemT
))
1617 and then Is_Entity_Name
(Prefix
(ItemT
))
1618 and then Is_Type
(Entity
(Prefix
(ItemT
)))
1623 -- If the expressions for the discriminants are identical
1624 -- and it is side-effect free (for now just an entity),
1625 -- this may be a shared constraint, e.g. from a subtype
1626 -- without a constraint introduced as a generic actual.
1627 -- Examine other discriminants if any.
1630 and then Is_Entity_Name
(ItemS
)
1634 elsif not Is_OK_Static_Expression
(ItemS
)
1635 or else not Is_OK_Static_Expression
(ItemT
)
1639 elsif Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1640 if Do_Access
then -- needs run-time check.
1643 Apply_Compile_Time_Constraint_Error
1644 (N
, "incorrect value for discriminant&??",
1645 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1652 Next_Discriminant
(Discr
);
1661 -- Here we need a discriminant check. First build the expression
1662 -- for the comparisons of the discriminants:
1664 -- (n.disc1 /= typ.disc1) or else
1665 -- (n.disc2 /= typ.disc2) or else
1667 -- (n.discn /= typ.discn)
1669 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1671 -- If Lhs is set and is a parameter, then the condition is guarded by:
1672 -- lhs'constrained and then (condition built above)
1674 if Present
(Param_Entity
(Lhs
)) then
1678 Make_Attribute_Reference
(Loc
,
1679 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1680 Attribute_Name
=> Name_Constrained
),
1681 Right_Opnd
=> Cond
);
1685 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1689 Make_Raise_Constraint_Error
(Loc
,
1691 Reason
=> CE_Discriminant_Check_Failed
));
1692 end Apply_Discriminant_Check
;
1694 -------------------------
1695 -- Apply_Divide_Checks --
1696 -------------------------
1698 procedure Apply_Divide_Checks
(N
: Node_Id
) is
1699 Loc
: constant Source_Ptr
:= Sloc
(N
);
1700 Typ
: constant Entity_Id
:= Etype
(N
);
1701 Left
: constant Node_Id
:= Left_Opnd
(N
);
1702 Right
: constant Node_Id
:= Right_Opnd
(N
);
1704 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1705 -- Current overflow checking mode
1715 pragma Warnings
(Off
, Lhi
);
1716 -- Don't actually use this value
1719 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1720 -- operating on signed integer types, then the only thing this routine
1721 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1722 -- procedure will (possibly later on during recursive downward calls),
1723 -- ensure that any needed overflow/division checks are properly applied.
1725 if Mode
in Minimized_Or_Eliminated
1726 and then Is_Signed_Integer_Type
(Typ
)
1728 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
1732 -- Proceed here in SUPPRESSED or CHECKED modes
1734 if Full_Expander_Active
1735 and then not Backend_Divide_Checks_On_Target
1736 and then Check_Needed
(Right
, Division_Check
)
1738 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
1740 -- Deal with division check
1742 if Do_Division_Check
(N
)
1743 and then not Division_Checks_Suppressed
(Typ
)
1745 Apply_Division_Check
(N
, Rlo
, Rhi
, ROK
);
1748 -- Deal with overflow check
1750 if Do_Overflow_Check
(N
)
1751 and then not Overflow_Checks_Suppressed
(Etype
(N
))
1754 -- Test for extremely annoying case of xxx'First divided by -1
1755 -- for division of signed integer types (only overflow case).
1757 if Nkind
(N
) = N_Op_Divide
1758 and then Is_Signed_Integer_Type
(Typ
)
1760 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
1761 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1763 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1765 ((not LOK
) or else (Llo
= LLB
))
1768 Make_Raise_Constraint_Error
(Loc
,
1774 Duplicate_Subexpr_Move_Checks
(Left
),
1775 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1779 Left_Opnd
=> Duplicate_Subexpr
(Right
),
1780 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1))),
1782 Reason
=> CE_Overflow_Check_Failed
));
1787 end Apply_Divide_Checks
;
1789 --------------------------
1790 -- Apply_Division_Check --
1791 --------------------------
1793 procedure Apply_Division_Check
1799 pragma Assert
(Do_Division_Check
(N
));
1801 Loc
: constant Source_Ptr
:= Sloc
(N
);
1802 Right
: constant Node_Id
:= Right_Opnd
(N
);
1805 if Full_Expander_Active
1806 and then not Backend_Divide_Checks_On_Target
1807 and then Check_Needed
(Right
, Division_Check
)
1809 -- See if division by zero possible, and if so generate test. This
1810 -- part of the test is not controlled by the -gnato switch, since
1811 -- it is a Division_Check and not an Overflow_Check.
1813 if Do_Division_Check
(N
) then
1814 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1816 Make_Raise_Constraint_Error
(Loc
,
1819 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1820 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1821 Reason
=> CE_Divide_By_Zero
));
1825 end Apply_Division_Check
;
1827 ----------------------------------
1828 -- Apply_Float_Conversion_Check --
1829 ----------------------------------
1831 -- Let F and I be the source and target types of the conversion. The RM
1832 -- specifies that a floating-point value X is rounded to the nearest
1833 -- integer, with halfway cases being rounded away from zero. The rounded
1834 -- value of X is checked against I'Range.
1836 -- The catch in the above paragraph is that there is no good way to know
1837 -- whether the round-to-integer operation resulted in overflow. A remedy is
1838 -- to perform a range check in the floating-point domain instead, however:
1840 -- (1) The bounds may not be known at compile time
1841 -- (2) The check must take into account rounding or truncation.
1842 -- (3) The range of type I may not be exactly representable in F.
1843 -- (4) For the rounding case, The end-points I'First - 0.5 and
1844 -- I'Last + 0.5 may or may not be in range, depending on the
1845 -- sign of I'First and I'Last.
1846 -- (5) X may be a NaN, which will fail any comparison
1848 -- The following steps correctly convert X with rounding:
1850 -- (1) If either I'First or I'Last is not known at compile time, use
1851 -- I'Base instead of I in the next three steps and perform a
1852 -- regular range check against I'Range after conversion.
1853 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1854 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1855 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1856 -- In other words, take one of the closest floating-point numbers
1857 -- (which is an integer value) to I'First, and see if it is in
1859 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1860 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1861 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1862 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1863 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1865 -- For the truncating case, replace steps (2) and (3) as follows:
1866 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1867 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1869 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1870 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1873 procedure Apply_Float_Conversion_Check
1875 Target_Typ
: Entity_Id
)
1877 LB
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1878 HB
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1879 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1880 Expr_Type
: constant Entity_Id
:= Base_Type
(Etype
(Ck_Node
));
1881 Target_Base
: constant Entity_Id
:=
1882 Implementation_Base_Type
(Target_Typ
);
1884 Par
: constant Node_Id
:= Parent
(Ck_Node
);
1885 pragma Assert
(Nkind
(Par
) = N_Type_Conversion
);
1886 -- Parent of check node, must be a type conversion
1888 Truncate
: constant Boolean := Float_Truncate
(Par
);
1889 Max_Bound
: constant Uint
:=
1891 (Machine_Radix_Value
(Expr_Type
),
1892 Machine_Mantissa_Value
(Expr_Type
) - 1) - 1;
1894 -- Largest bound, so bound plus or minus half is a machine number of F
1896 Ifirst
, Ilast
: Uint
;
1897 -- Bounds of integer type
1900 -- Bounds to check in floating-point domain
1902 Lo_OK
, Hi_OK
: Boolean;
1903 -- True iff Lo resp. Hi belongs to I'Range
1905 Lo_Chk
, Hi_Chk
: Node_Id
;
1906 -- Expressions that are False iff check fails
1908 Reason
: RT_Exception_Code
;
1911 -- We do not need checks if we are not generating code (i.e. the full
1912 -- expander is not active). In SPARK mode, we specifically don't want
1913 -- the frontend to expand these checks, which are dealt with directly
1914 -- in the formal verification backend.
1916 if not Full_Expander_Active
then
1920 if not Compile_Time_Known_Value
(LB
)
1921 or not Compile_Time_Known_Value
(HB
)
1924 -- First check that the value falls in the range of the base type,
1925 -- to prevent overflow during conversion and then perform a
1926 -- regular range check against the (dynamic) bounds.
1928 pragma Assert
(Target_Base
/= Target_Typ
);
1930 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Par
);
1933 Apply_Float_Conversion_Check
(Ck_Node
, Target_Base
);
1934 Set_Etype
(Temp
, Target_Base
);
1936 Insert_Action
(Parent
(Par
),
1937 Make_Object_Declaration
(Loc
,
1938 Defining_Identifier
=> Temp
,
1939 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
),
1940 Expression
=> New_Copy_Tree
(Par
)),
1941 Suppress
=> All_Checks
);
1944 Make_Raise_Constraint_Error
(Loc
,
1947 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
1948 Right_Opnd
=> New_Occurrence_Of
(Target_Typ
, Loc
)),
1949 Reason
=> CE_Range_Check_Failed
));
1950 Rewrite
(Par
, New_Occurrence_Of
(Temp
, Loc
));
1956 -- Get the (static) bounds of the target type
1958 Ifirst
:= Expr_Value
(LB
);
1959 Ilast
:= Expr_Value
(HB
);
1961 -- A simple optimization: if the expression is a universal literal,
1962 -- we can do the comparison with the bounds and the conversion to
1963 -- an integer type statically. The range checks are unchanged.
1965 if Nkind
(Ck_Node
) = N_Real_Literal
1966 and then Etype
(Ck_Node
) = Universal_Real
1967 and then Is_Integer_Type
(Target_Typ
)
1968 and then Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
1971 Int_Val
: constant Uint
:= UR_To_Uint
(Realval
(Ck_Node
));
1974 if Int_Val
<= Ilast
and then Int_Val
>= Ifirst
then
1976 -- Conversion is safe
1978 Rewrite
(Parent
(Ck_Node
),
1979 Make_Integer_Literal
(Loc
, UI_To_Int
(Int_Val
)));
1980 Analyze_And_Resolve
(Parent
(Ck_Node
), Target_Typ
);
1986 -- Check against lower bound
1988 if Truncate
and then Ifirst
> 0 then
1989 Lo
:= Pred
(Expr_Type
, UR_From_Uint
(Ifirst
));
1993 Lo
:= Succ
(Expr_Type
, UR_From_Uint
(Ifirst
- 1));
1996 elsif abs (Ifirst
) < Max_Bound
then
1997 Lo
:= UR_From_Uint
(Ifirst
) - Ureal_Half
;
1998 Lo_OK
:= (Ifirst
> 0);
2001 Lo
:= Machine
(Expr_Type
, UR_From_Uint
(Ifirst
), Round_Even
, Ck_Node
);
2002 Lo_OK
:= (Lo
>= UR_From_Uint
(Ifirst
));
2007 -- Lo_Chk := (X >= Lo)
2009 Lo_Chk
:= Make_Op_Ge
(Loc
,
2010 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2011 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2014 -- Lo_Chk := (X > Lo)
2016 Lo_Chk
:= Make_Op_Gt
(Loc
,
2017 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2018 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2021 -- Check against higher bound
2023 if Truncate
and then Ilast
< 0 then
2024 Hi
:= Succ
(Expr_Type
, UR_From_Uint
(Ilast
));
2028 Hi
:= Pred
(Expr_Type
, UR_From_Uint
(Ilast
+ 1));
2031 elsif abs (Ilast
) < Max_Bound
then
2032 Hi
:= UR_From_Uint
(Ilast
) + Ureal_Half
;
2033 Hi_OK
:= (Ilast
< 0);
2035 Hi
:= Machine
(Expr_Type
, UR_From_Uint
(Ilast
), Round_Even
, Ck_Node
);
2036 Hi_OK
:= (Hi
<= UR_From_Uint
(Ilast
));
2041 -- Hi_Chk := (X <= Hi)
2043 Hi_Chk
:= Make_Op_Le
(Loc
,
2044 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2045 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2048 -- Hi_Chk := (X < Hi)
2050 Hi_Chk
:= Make_Op_Lt
(Loc
,
2051 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2052 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2055 -- If the bounds of the target type are the same as those of the base
2056 -- type, the check is an overflow check as a range check is not
2057 -- performed in these cases.
2059 if Expr_Value
(Type_Low_Bound
(Target_Base
)) = Ifirst
2060 and then Expr_Value
(Type_High_Bound
(Target_Base
)) = Ilast
2062 Reason
:= CE_Overflow_Check_Failed
;
2064 Reason
:= CE_Range_Check_Failed
;
2067 -- Raise CE if either conditions does not hold
2069 Insert_Action
(Ck_Node
,
2070 Make_Raise_Constraint_Error
(Loc
,
2071 Condition
=> Make_Op_Not
(Loc
, Make_And_Then
(Loc
, Lo_Chk
, Hi_Chk
)),
2073 end Apply_Float_Conversion_Check
;
2075 ------------------------
2076 -- Apply_Length_Check --
2077 ------------------------
2079 procedure Apply_Length_Check
2081 Target_Typ
: Entity_Id
;
2082 Source_Typ
: Entity_Id
:= Empty
)
2085 Apply_Selected_Length_Checks
2086 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2087 end Apply_Length_Check
;
2089 -------------------------------------
2090 -- Apply_Parameter_Aliasing_Checks --
2091 -------------------------------------
2093 procedure Apply_Parameter_Aliasing_Checks
2097 Loc
: constant Source_Ptr
:= Sloc
(Call
);
2099 function May_Cause_Aliasing
2100 (Formal_1
: Entity_Id
;
2101 Formal_2
: Entity_Id
) return Boolean;
2102 -- Determine whether two formal parameters can alias each other
2103 -- depending on their modes.
2105 function Original_Actual
(N
: Node_Id
) return Node_Id
;
2106 -- The expander may replace an actual with a temporary for the sake of
2107 -- side effect removal. The temporary may hide a potential aliasing as
2108 -- it does not share the address of the actual. This routine attempts
2109 -- to retrieve the original actual.
2111 procedure Overlap_Check
2112 (Actual_1
: Node_Id
;
2114 Formal_1
: Entity_Id
;
2115 Formal_2
: Entity_Id
;
2116 Check
: in out Node_Id
);
2117 -- Create a check to determine whether Actual_1 overlaps with Actual_2.
2118 -- If detailed exception messages are enabled, the check is augmented to
2119 -- provide information about the names of the corresponding formals. See
2120 -- the body for details. Actual_1 and Actual_2 denote the two actuals to
2121 -- be tested. Formal_1 and Formal_2 denote the corresponding formals.
2122 -- Check contains all and-ed simple tests generated so far or remains
2123 -- unchanged in the case of detailed exception messaged.
2125 ------------------------
2126 -- May_Cause_Aliasing --
2127 ------------------------
2129 function May_Cause_Aliasing
2130 (Formal_1
: Entity_Id
;
2131 Formal_2
: Entity_Id
) return Boolean
2134 -- The following combination cannot lead to aliasing
2136 -- Formal 1 Formal 2
2139 if Ekind
(Formal_1
) = E_In_Parameter
2141 Ekind
(Formal_2
) = E_In_Parameter
2145 -- The following combinations may lead to aliasing
2147 -- Formal 1 Formal 2
2157 end May_Cause_Aliasing
;
2159 ---------------------
2160 -- Original_Actual --
2161 ---------------------
2163 function Original_Actual
(N
: Node_Id
) return Node_Id
is
2165 if Nkind
(N
) = N_Type_Conversion
then
2166 return Expression
(N
);
2168 -- The expander created a temporary to capture the result of a type
2169 -- conversion where the expression is the real actual.
2171 elsif Nkind
(N
) = N_Identifier
2172 and then Present
(Original_Node
(N
))
2173 and then Nkind
(Original_Node
(N
)) = N_Type_Conversion
2175 return Expression
(Original_Node
(N
));
2179 end Original_Actual
;
2185 procedure Overlap_Check
2186 (Actual_1
: Node_Id
;
2188 Formal_1
: Entity_Id
;
2189 Formal_2
: Entity_Id
;
2190 Check
: in out Node_Id
)
2196 -- Actual_1'Overlaps_Storage (Actual_2)
2199 Make_Attribute_Reference
(Loc
,
2200 Prefix
=> New_Copy_Tree
(Original_Actual
(Actual_1
)),
2201 Attribute_Name
=> Name_Overlaps_Storage
,
2203 New_List
(New_Copy_Tree
(Original_Actual
(Actual_2
))));
2205 -- Generate the following check when detailed exception messages are
2208 -- if Actual_1'Overlaps_Storage (Actual_2) then
2209 -- raise Program_Error with <detailed message>;
2212 if Exception_Extra_Info
then
2215 -- Do not generate location information for internal calls
2217 if Comes_From_Source
(Call
) then
2218 Store_String_Chars
(Build_Location_String
(Loc
));
2219 Store_String_Char
(' ');
2222 Store_String_Chars
("aliased parameters, actuals for """);
2223 Store_String_Chars
(Get_Name_String
(Chars
(Formal_1
)));
2224 Store_String_Chars
(""" and """);
2225 Store_String_Chars
(Get_Name_String
(Chars
(Formal_2
)));
2226 Store_String_Chars
(""" overlap");
2228 Insert_Action
(Call
,
2229 Make_If_Statement
(Loc
,
2231 Then_Statements
=> New_List
(
2232 Make_Raise_Statement
(Loc
,
2234 New_Reference_To
(Standard_Program_Error
, Loc
),
2235 Expression
=> Make_String_Literal
(Loc
, End_String
)))));
2237 -- Create a sequence of overlapping checks by and-ing them all
2247 Right_Opnd
=> Cond
);
2257 Formal_1
: Entity_Id
;
2258 Formal_2
: Entity_Id
;
2260 -- Start of processing for Apply_Parameter_Aliasing_Checks
2265 Actual_1
:= First_Actual
(Call
);
2266 Formal_1
:= First_Formal
(Subp
);
2267 while Present
(Actual_1
) and then Present
(Formal_1
) loop
2269 -- Ensure that the actual is an object that is not passed by value.
2270 -- Elementary types are always passed by value, therefore actuals of
2271 -- such types cannot lead to aliasing.
2273 if Is_Object_Reference
(Original_Actual
(Actual_1
))
2274 and then not Is_Elementary_Type
(Etype
(Original_Actual
(Actual_1
)))
2276 Actual_2
:= Next_Actual
(Actual_1
);
2277 Formal_2
:= Next_Formal
(Formal_1
);
2278 while Present
(Actual_2
) and then Present
(Formal_2
) loop
2280 -- The other actual we are testing against must also denote
2281 -- a non pass-by-value object. Generate the check only when
2282 -- the mode of the two formals may lead to aliasing.
2284 if Is_Object_Reference
(Original_Actual
(Actual_2
))
2286 Is_Elementary_Type
(Etype
(Original_Actual
(Actual_2
)))
2287 and then May_Cause_Aliasing
(Formal_1
, Formal_2
)
2290 (Actual_1
=> Actual_1
,
2291 Actual_2
=> Actual_2
,
2292 Formal_1
=> Formal_1
,
2293 Formal_2
=> Formal_2
,
2297 Next_Actual
(Actual_2
);
2298 Next_Formal
(Formal_2
);
2302 Next_Actual
(Actual_1
);
2303 Next_Formal
(Formal_1
);
2306 -- Place a simple check right before the call
2308 if Present
(Check
) and then not Exception_Extra_Info
then
2309 Insert_Action
(Call
,
2310 Make_Raise_Program_Error
(Loc
,
2312 Reason
=> PE_Aliased_Parameters
));
2314 end Apply_Parameter_Aliasing_Checks
;
2316 -------------------------------------
2317 -- Apply_Parameter_Validity_Checks --
2318 -------------------------------------
2320 procedure Apply_Parameter_Validity_Checks
(Subp
: Entity_Id
) is
2321 Subp_Decl
: Node_Id
;
2323 procedure Add_Validity_Check
2324 (Context
: Entity_Id
;
2326 For_Result
: Boolean := False);
2327 -- Add a single 'Valid[_Scalar] check which verifies the initialization
2328 -- of Context. PPC_Nam denotes the pre or post condition pragma name.
2329 -- Set flag For_Result when to verify the result of a function.
2331 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
);
2332 -- Create a pre or post condition pragma with name PPC_Nam which
2333 -- tests expression Check.
2335 ------------------------
2336 -- Add_Validity_Check --
2337 ------------------------
2339 procedure Add_Validity_Check
2340 (Context
: Entity_Id
;
2342 For_Result
: Boolean := False)
2344 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2345 Typ
: constant Entity_Id
:= Etype
(Context
);
2350 -- Pick the proper version of 'Valid depending on the type of the
2351 -- context. If the context is not eligible for such a check, return.
2353 if Is_Scalar_Type
(Typ
) then
2355 elsif not No_Scalar_Parts
(Typ
) then
2356 Nam
:= Name_Valid_Scalars
;
2361 -- Step 1: Create the expression to verify the validity of the
2364 Check
:= New_Reference_To
(Context
, Loc
);
2366 -- When processing a function result, use 'Result. Generate
2371 Make_Attribute_Reference
(Loc
,
2373 Attribute_Name
=> Name_Result
);
2377 -- Context['Result]'Valid[_Scalars]
2380 Make_Attribute_Reference
(Loc
,
2382 Attribute_Name
=> Nam
);
2384 -- Step 2: Create a pre or post condition pragma
2386 Build_PPC_Pragma
(PPC_Nam
, Check
);
2387 end Add_Validity_Check
;
2389 ----------------------
2390 -- Build_PPC_Pragma --
2391 ----------------------
2393 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
) is
2394 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2401 Pragma_Identifier
=> Make_Identifier
(Loc
, PPC_Nam
),
2402 Pragma_Argument_Associations
=> New_List
(
2403 Make_Pragma_Argument_Association
(Loc
,
2404 Chars
=> Name_Check
,
2405 Expression
=> Check
)));
2407 -- Add a message unless exception messages are suppressed
2409 if not Exception_Locations_Suppressed
then
2410 Append_To
(Pragma_Argument_Associations
(Prag
),
2411 Make_Pragma_Argument_Association
(Loc
,
2412 Chars
=> Name_Message
,
2414 Make_String_Literal
(Loc
,
2415 Strval
=> "failed " & Get_Name_String
(PPC_Nam
) &
2416 " from " & Build_Location_String
(Loc
))));
2419 -- Insert the pragma in the tree
2421 if Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
then
2422 Add_Global_Declaration
(Prag
);
2425 -- PPC pragmas associated with subprogram bodies must be inserted in
2426 -- the declarative part of the body.
2428 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
then
2429 Decls
:= Declarations
(Subp_Decl
);
2433 Set_Declarations
(Subp_Decl
, Decls
);
2436 Prepend_To
(Decls
, Prag
);
2438 -- Ensure the proper visibility of the subprogram body and its
2445 -- For subprogram declarations insert the PPC pragma right after the
2446 -- declarative node.
2449 Insert_After_And_Analyze
(Subp_Decl
, Prag
);
2451 end Build_PPC_Pragma
;
2456 Subp_Spec
: Node_Id
;
2458 -- Start of processing for Apply_Parameter_Validity_Checks
2461 -- Extract the subprogram specification and declaration nodes
2463 Subp_Spec
:= Parent
(Subp
);
2465 if Nkind
(Subp_Spec
) = N_Defining_Program_Unit_Name
then
2466 Subp_Spec
:= Parent
(Subp_Spec
);
2469 Subp_Decl
:= Parent
(Subp_Spec
);
2471 if not Comes_From_Source
(Subp
)
2473 -- Do not process formal subprograms because the corresponding actual
2474 -- will receive the proper checks when the instance is analyzed.
2476 or else Is_Formal_Subprogram
(Subp
)
2478 -- Do not process imported subprograms since pre and post conditions
2479 -- are never verified on routines coming from a different language.
2481 or else Is_Imported
(Subp
)
2482 or else Is_Intrinsic_Subprogram
(Subp
)
2484 -- The PPC pragmas generated by this routine do not correspond to
2485 -- source aspects, therefore they cannot be applied to abstract
2488 or else Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
2490 -- Do not consider subprogram renaminds because the renamed entity
2491 -- already has the proper PPC pragmas.
2493 or else Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
2495 -- Do not process null procedures because there is no benefit of
2496 -- adding the checks to a no action routine.
2498 or else (Nkind
(Subp_Spec
) = N_Procedure_Specification
2499 and then Null_Present
(Subp_Spec
))
2504 -- Inspect all the formals applying aliasing and scalar initialization
2505 -- checks where applicable.
2507 Formal
:= First_Formal
(Subp
);
2508 while Present
(Formal
) loop
2510 -- Generate the following scalar initialization checks for each
2511 -- formal parameter:
2513 -- mode IN - Pre => Formal'Valid[_Scalars]
2514 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2515 -- mode OUT - Post => Formal'Valid[_Scalars]
2517 if Check_Validity_Of_Parameters
then
2518 if Ekind_In
(Formal
, E_In_Parameter
, E_In_Out_Parameter
) then
2519 Add_Validity_Check
(Formal
, Name_Precondition
, False);
2522 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
2523 Add_Validity_Check
(Formal
, Name_Postcondition
, False);
2527 Next_Formal
(Formal
);
2530 -- Generate following scalar initialization check for function result:
2532 -- Post => Subp'Result'Valid[_Scalars]
2534 if Check_Validity_Of_Parameters
and then Ekind
(Subp
) = E_Function
then
2535 Add_Validity_Check
(Subp
, Name_Postcondition
, True);
2537 end Apply_Parameter_Validity_Checks
;
2539 ---------------------------
2540 -- Apply_Predicate_Check --
2541 ---------------------------
2543 procedure Apply_Predicate_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
2547 if Present
(Predicate_Function
(Typ
)) then
2549 -- A predicate check does not apply within internally generated
2550 -- subprograms, such as TSS functions.
2553 while Present
(S
) and then not Is_Subprogram
(S
) loop
2557 if Present
(S
) and then Get_TSS_Name
(S
) /= TSS_Null
then
2560 -- If the check appears within the predicate function itself, it
2561 -- means that the user specified a check whose formal is the
2562 -- predicated subtype itself, rather than some covering type. This
2563 -- is likely to be a common error, and thus deserves a warning.
2565 elsif S
= Predicate_Function
(Typ
) then
2567 ("predicate check includes a function call that "
2568 & "requires a predicate check??", Parent
(N
));
2570 ("\this will result in infinite recursion??", Parent
(N
));
2572 Make_Raise_Storage_Error
(Sloc
(N
),
2573 Reason
=> SE_Infinite_Recursion
));
2575 -- Here for normal case of predicate active
2578 -- If the type has a static predicate and the expression is known
2579 -- at compile time, see if the expression satisfies the predicate.
2581 Check_Expression_Against_Static_Predicate
(N
, Typ
);
2584 Make_Predicate_Check
(Typ
, Duplicate_Subexpr
(N
)));
2587 end Apply_Predicate_Check
;
2589 -----------------------
2590 -- Apply_Range_Check --
2591 -----------------------
2593 procedure Apply_Range_Check
2595 Target_Typ
: Entity_Id
;
2596 Source_Typ
: Entity_Id
:= Empty
)
2599 Apply_Selected_Range_Checks
2600 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2601 end Apply_Range_Check
;
2603 ------------------------------
2604 -- Apply_Scalar_Range_Check --
2605 ------------------------------
2607 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
2608 -- off if it is already set on.
2610 procedure Apply_Scalar_Range_Check
2612 Target_Typ
: Entity_Id
;
2613 Source_Typ
: Entity_Id
:= Empty
;
2614 Fixed_Int
: Boolean := False)
2616 Parnt
: constant Node_Id
:= Parent
(Expr
);
2618 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
2619 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
2622 Is_Subscr_Ref
: Boolean;
2623 -- Set true if Expr is a subscript
2625 Is_Unconstrained_Subscr_Ref
: Boolean;
2626 -- Set true if Expr is a subscript of an unconstrained array. In this
2627 -- case we do not attempt to do an analysis of the value against the
2628 -- range of the subscript, since we don't know the actual subtype.
2631 -- Set to True if Expr should be regarded as a real value even though
2632 -- the type of Expr might be discrete.
2634 procedure Bad_Value
;
2635 -- Procedure called if value is determined to be out of range
2641 procedure Bad_Value
is
2643 Apply_Compile_Time_Constraint_Error
2644 (Expr
, "value not in range of}??", CE_Range_Check_Failed
,
2649 -- Start of processing for Apply_Scalar_Range_Check
2652 -- Return if check obviously not needed
2655 -- Not needed inside generic
2659 -- Not needed if previous error
2661 or else Target_Typ
= Any_Type
2662 or else Nkind
(Expr
) = N_Error
2664 -- Not needed for non-scalar type
2666 or else not Is_Scalar_Type
(Target_Typ
)
2668 -- Not needed if we know node raises CE already
2670 or else Raises_Constraint_Error
(Expr
)
2675 -- Now, see if checks are suppressed
2678 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
2680 if Is_Subscr_Ref
then
2681 Arr
:= Prefix
(Parnt
);
2682 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
2684 if Is_Access_Type
(Arr_Typ
) then
2685 Arr_Typ
:= Designated_Type
(Arr_Typ
);
2689 if not Do_Range_Check
(Expr
) then
2691 -- Subscript reference. Check for Index_Checks suppressed
2693 if Is_Subscr_Ref
then
2695 -- Check array type and its base type
2697 if Index_Checks_Suppressed
(Arr_Typ
)
2698 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
2702 -- Check array itself if it is an entity name
2704 elsif Is_Entity_Name
(Arr
)
2705 and then Index_Checks_Suppressed
(Entity
(Arr
))
2709 -- Check expression itself if it is an entity name
2711 elsif Is_Entity_Name
(Expr
)
2712 and then Index_Checks_Suppressed
(Entity
(Expr
))
2717 -- All other cases, check for Range_Checks suppressed
2720 -- Check target type and its base type
2722 if Range_Checks_Suppressed
(Target_Typ
)
2723 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
2727 -- Check expression itself if it is an entity name
2729 elsif Is_Entity_Name
(Expr
)
2730 and then Range_Checks_Suppressed
(Entity
(Expr
))
2734 -- If Expr is part of an assignment statement, then check left
2735 -- side of assignment if it is an entity name.
2737 elsif Nkind
(Parnt
) = N_Assignment_Statement
2738 and then Is_Entity_Name
(Name
(Parnt
))
2739 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
2746 -- Do not set range checks if they are killed
2748 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
2749 and then Kill_Range_Check
(Expr
)
2754 -- Do not set range checks for any values from System.Scalar_Values
2755 -- since the whole idea of such values is to avoid checking them!
2757 if Is_Entity_Name
(Expr
)
2758 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
2763 -- Now see if we need a check
2765 if No
(Source_Typ
) then
2766 S_Typ
:= Etype
(Expr
);
2768 S_Typ
:= Source_Typ
;
2771 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
2775 Is_Unconstrained_Subscr_Ref
:=
2776 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
2778 -- Special checks for floating-point type
2780 if Is_Floating_Point_Type
(S_Typ
) then
2782 -- Always do a range check if the source type includes infinities and
2783 -- the target type does not include infinities. We do not do this if
2784 -- range checks are killed.
2786 if Has_Infinities
(S_Typ
)
2787 and then not Has_Infinities
(Target_Typ
)
2789 Enable_Range_Check
(Expr
);
2791 -- Always do a range check for operators if option set
2793 elsif Check_Float_Overflow
and then Nkind
(Expr
) in N_Op
then
2794 Enable_Range_Check
(Expr
);
2798 -- Return if we know expression is definitely in the range of the target
2799 -- type as determined by Determine_Range. Right now we only do this for
2800 -- discrete types, and not fixed-point or floating-point types.
2802 -- The additional less-precise tests below catch these cases
2804 -- Note: skip this if we are given a source_typ, since the point of
2805 -- supplying a Source_Typ is to stop us looking at the expression.
2806 -- We could sharpen this test to be out parameters only ???
2808 if Is_Discrete_Type
(Target_Typ
)
2809 and then Is_Discrete_Type
(Etype
(Expr
))
2810 and then not Is_Unconstrained_Subscr_Ref
2811 and then No
(Source_Typ
)
2814 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
2815 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
2820 if Compile_Time_Known_Value
(Tlo
)
2821 and then Compile_Time_Known_Value
(Thi
)
2824 Lov
: constant Uint
:= Expr_Value
(Tlo
);
2825 Hiv
: constant Uint
:= Expr_Value
(Thi
);
2828 -- If range is null, we for sure have a constraint error
2829 -- (we don't even need to look at the value involved,
2830 -- since all possible values will raise CE).
2837 -- Otherwise determine range of value
2839 Determine_Range
(Expr
, OK
, Lo
, Hi
, Assume_Valid
=> True);
2843 -- If definitely in range, all OK
2845 if Lo
>= Lov
and then Hi
<= Hiv
then
2848 -- If definitely not in range, warn
2850 elsif Lov
> Hi
or else Hiv
< Lo
then
2854 -- Otherwise we don't know
2866 Is_Floating_Point_Type
(S_Typ
)
2867 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
2869 -- Check if we can determine at compile time whether Expr is in the
2870 -- range of the target type. Note that if S_Typ is within the bounds
2871 -- of Target_Typ then this must be the case. This check is meaningful
2872 -- only if this is not a conversion between integer and real types.
2874 if not Is_Unconstrained_Subscr_Ref
2875 and then Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
2877 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
2879 Is_In_Range
(Expr
, Target_Typ
,
2880 Assume_Valid
=> True,
2881 Fixed_Int
=> Fixed_Int
,
2882 Int_Real
=> Int_Real
))
2886 elsif Is_Out_Of_Range
(Expr
, Target_Typ
,
2887 Assume_Valid
=> True,
2888 Fixed_Int
=> Fixed_Int
,
2889 Int_Real
=> Int_Real
)
2894 -- Floating-point case
2895 -- In the floating-point case, we only do range checks if the type is
2896 -- constrained. We definitely do NOT want range checks for unconstrained
2897 -- types, since we want to have infinities
2899 elsif Is_Floating_Point_Type
(S_Typ
) then
2901 -- Normally, we only do range checks if the type is constrained. We do
2902 -- NOT want range checks for unconstrained types, since we want to have
2903 -- infinities. Override this decision in Check_Float_Overflow mode.
2905 if Is_Constrained
(S_Typ
) or else Check_Float_Overflow
then
2906 Enable_Range_Check
(Expr
);
2909 -- For all other cases we enable a range check unconditionally
2912 Enable_Range_Check
(Expr
);
2915 end Apply_Scalar_Range_Check
;
2917 ----------------------------------
2918 -- Apply_Selected_Length_Checks --
2919 ----------------------------------
2921 procedure Apply_Selected_Length_Checks
2923 Target_Typ
: Entity_Id
;
2924 Source_Typ
: Entity_Id
;
2925 Do_Static
: Boolean)
2928 R_Result
: Check_Result
;
2931 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
2932 Checks_On
: constant Boolean :=
2933 (not Index_Checks_Suppressed
(Target_Typ
))
2934 or else (not Length_Checks_Suppressed
(Target_Typ
));
2937 if not Full_Expander_Active
then
2942 Selected_Length_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
2944 for J
in 1 .. 2 loop
2945 R_Cno
:= R_Result
(J
);
2946 exit when No
(R_Cno
);
2948 -- A length check may mention an Itype which is attached to a
2949 -- subsequent node. At the top level in a package this can cause
2950 -- an order-of-elaboration problem, so we make sure that the itype
2951 -- is referenced now.
2953 if Ekind
(Current_Scope
) = E_Package
2954 and then Is_Compilation_Unit
(Current_Scope
)
2956 Ensure_Defined
(Target_Typ
, Ck_Node
);
2958 if Present
(Source_Typ
) then
2959 Ensure_Defined
(Source_Typ
, Ck_Node
);
2961 elsif Is_Itype
(Etype
(Ck_Node
)) then
2962 Ensure_Defined
(Etype
(Ck_Node
), Ck_Node
);
2966 -- If the item is a conditional raise of constraint error, then have
2967 -- a look at what check is being performed and ???
2969 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
2970 and then Present
(Condition
(R_Cno
))
2972 Cond
:= Condition
(R_Cno
);
2974 -- Case where node does not now have a dynamic check
2976 if not Has_Dynamic_Length_Check
(Ck_Node
) then
2978 -- If checks are on, just insert the check
2981 Insert_Action
(Ck_Node
, R_Cno
);
2983 if not Do_Static
then
2984 Set_Has_Dynamic_Length_Check
(Ck_Node
);
2987 -- If checks are off, then analyze the length check after
2988 -- temporarily attaching it to the tree in case the relevant
2989 -- condition can be evaluated at compile time. We still want a
2990 -- compile time warning in this case.
2993 Set_Parent
(R_Cno
, Ck_Node
);
2998 -- Output a warning if the condition is known to be True
3000 if Is_Entity_Name
(Cond
)
3001 and then Entity
(Cond
) = Standard_True
3003 Apply_Compile_Time_Constraint_Error
3004 (Ck_Node
, "wrong length for array of}??",
3005 CE_Length_Check_Failed
,
3009 -- If we were only doing a static check, or if checks are not
3010 -- on, then we want to delete the check, since it is not needed.
3011 -- We do this by replacing the if statement by a null statement
3013 elsif Do_Static
or else not Checks_On
then
3014 Remove_Warning_Messages
(R_Cno
);
3015 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3019 Install_Static_Check
(R_Cno
, Loc
);
3022 end Apply_Selected_Length_Checks
;
3024 ---------------------------------
3025 -- Apply_Selected_Range_Checks --
3026 ---------------------------------
3028 procedure Apply_Selected_Range_Checks
3030 Target_Typ
: Entity_Id
;
3031 Source_Typ
: Entity_Id
;
3032 Do_Static
: Boolean)
3035 R_Result
: Check_Result
;
3038 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
3039 Checks_On
: constant Boolean :=
3040 (not Index_Checks_Suppressed
(Target_Typ
))
3041 or else (not Range_Checks_Suppressed
(Target_Typ
));
3044 if not Full_Expander_Active
or else not Checks_On
then
3049 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
3051 for J
in 1 .. 2 loop
3053 R_Cno
:= R_Result
(J
);
3054 exit when No
(R_Cno
);
3056 -- If the item is a conditional raise of constraint error, then have
3057 -- a look at what check is being performed and ???
3059 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
3060 and then Present
(Condition
(R_Cno
))
3062 Cond
:= Condition
(R_Cno
);
3064 if not Has_Dynamic_Range_Check
(Ck_Node
) then
3065 Insert_Action
(Ck_Node
, R_Cno
);
3067 if not Do_Static
then
3068 Set_Has_Dynamic_Range_Check
(Ck_Node
);
3072 -- Output a warning if the condition is known to be True
3074 if Is_Entity_Name
(Cond
)
3075 and then Entity
(Cond
) = Standard_True
3077 -- Since an N_Range is technically not an expression, we have
3078 -- to set one of the bounds to C_E and then just flag the
3079 -- N_Range. The warning message will point to the lower bound
3080 -- and complain about a range, which seems OK.
3082 if Nkind
(Ck_Node
) = N_Range
then
3083 Apply_Compile_Time_Constraint_Error
3084 (Low_Bound
(Ck_Node
), "static range out of bounds of}??",
3085 CE_Range_Check_Failed
,
3089 Set_Raises_Constraint_Error
(Ck_Node
);
3092 Apply_Compile_Time_Constraint_Error
3093 (Ck_Node
, "static value out of range of}?",
3094 CE_Range_Check_Failed
,
3099 -- If we were only doing a static check, or if checks are not
3100 -- on, then we want to delete the check, since it is not needed.
3101 -- We do this by replacing the if statement by a null statement
3103 elsif Do_Static
or else not Checks_On
then
3104 Remove_Warning_Messages
(R_Cno
);
3105 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3109 Install_Static_Check
(R_Cno
, Loc
);
3112 end Apply_Selected_Range_Checks
;
3114 -------------------------------
3115 -- Apply_Static_Length_Check --
3116 -------------------------------
3118 procedure Apply_Static_Length_Check
3120 Target_Typ
: Entity_Id
;
3121 Source_Typ
: Entity_Id
:= Empty
)
3124 Apply_Selected_Length_Checks
3125 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
3126 end Apply_Static_Length_Check
;
3128 -------------------------------------
3129 -- Apply_Subscript_Validity_Checks --
3130 -------------------------------------
3132 procedure Apply_Subscript_Validity_Checks
(Expr
: Node_Id
) is
3136 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
3138 -- Loop through subscripts
3140 Sub
:= First
(Expressions
(Expr
));
3141 while Present
(Sub
) loop
3143 -- Check one subscript. Note that we do not worry about enumeration
3144 -- type with holes, since we will convert the value to a Pos value
3145 -- for the subscript, and that convert will do the necessary validity
3148 Ensure_Valid
(Sub
, Holes_OK
=> True);
3150 -- Move to next subscript
3154 end Apply_Subscript_Validity_Checks
;
3156 ----------------------------------
3157 -- Apply_Type_Conversion_Checks --
3158 ----------------------------------
3160 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
3161 Target_Type
: constant Entity_Id
:= Etype
(N
);
3162 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
3163 Expr
: constant Node_Id
:= Expression
(N
);
3165 Expr_Type
: constant Entity_Id
:= Underlying_Type
(Etype
(Expr
));
3166 -- Note: if Etype (Expr) is a private type without discriminants, its
3167 -- full view might have discriminants with defaults, so we need the
3168 -- full view here to retrieve the constraints.
3171 if Inside_A_Generic
then
3174 -- Skip these checks if serious errors detected, there are some nasty
3175 -- situations of incomplete trees that blow things up.
3177 elsif Serious_Errors_Detected
> 0 then
3180 -- Scalar type conversions of the form Target_Type (Expr) require a
3181 -- range check if we cannot be sure that Expr is in the base type of
3182 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3183 -- are not quite the same condition from an implementation point of
3184 -- view, but clearly the second includes the first.
3186 elsif Is_Scalar_Type
(Target_Type
) then
3188 Conv_OK
: constant Boolean := Conversion_OK
(N
);
3189 -- If the Conversion_OK flag on the type conversion is set and no
3190 -- floating point type is involved in the type conversion then
3191 -- fixed point values must be read as integral values.
3193 Float_To_Int
: constant Boolean :=
3194 Is_Floating_Point_Type
(Expr_Type
)
3195 and then Is_Integer_Type
(Target_Type
);
3198 if not Overflow_Checks_Suppressed
(Target_Base
)
3199 and then not Overflow_Checks_Suppressed
(Target_Type
)
3201 In_Subrange_Of
(Expr_Type
, Target_Base
, Fixed_Int
=> Conv_OK
)
3202 and then not Float_To_Int
3204 Activate_Overflow_Check
(N
);
3207 if not Range_Checks_Suppressed
(Target_Type
)
3208 and then not Range_Checks_Suppressed
(Expr_Type
)
3210 if Float_To_Int
then
3211 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
3213 Apply_Scalar_Range_Check
3214 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
3216 -- If the target type has predicates, we need to indicate
3217 -- the need for a check, even if Determine_Range finds
3218 -- that the value is within bounds. This may be the case
3219 -- e.g for a division with a constant denominator.
3221 if Has_Predicates
(Target_Type
) then
3222 Enable_Range_Check
(Expr
);
3228 elsif Comes_From_Source
(N
)
3229 and then not Discriminant_Checks_Suppressed
(Target_Type
)
3230 and then Is_Record_Type
(Target_Type
)
3231 and then Is_Derived_Type
(Target_Type
)
3232 and then not Is_Tagged_Type
(Target_Type
)
3233 and then not Is_Constrained
(Target_Type
)
3234 and then Present
(Stored_Constraint
(Target_Type
))
3236 -- An unconstrained derived type may have inherited discriminant.
3237 -- Build an actual discriminant constraint list using the stored
3238 -- constraint, to verify that the expression of the parent type
3239 -- satisfies the constraints imposed by the (unconstrained!)
3240 -- derived type. This applies to value conversions, not to view
3241 -- conversions of tagged types.
3244 Loc
: constant Source_Ptr
:= Sloc
(N
);
3246 Constraint
: Elmt_Id
;
3247 Discr_Value
: Node_Id
;
3250 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
3251 Old_Constraints
: constant Elist_Id
:=
3252 Discriminant_Constraint
(Expr_Type
);
3255 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
3256 while Present
(Constraint
) loop
3257 Discr_Value
:= Node
(Constraint
);
3259 if Is_Entity_Name
(Discr_Value
)
3260 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
3262 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
3265 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
3267 -- Parent is constrained by new discriminant. Obtain
3268 -- Value of original discriminant in expression. If the
3269 -- new discriminant has been used to constrain more than
3270 -- one of the stored discriminants, this will provide the
3271 -- required consistency check.
3274 (Make_Selected_Component
(Loc
,
3276 Duplicate_Subexpr_No_Checks
3277 (Expr
, Name_Req
=> True),
3279 Make_Identifier
(Loc
, Chars
(Discr
))),
3283 -- Discriminant of more remote ancestor ???
3288 -- Derived type definition has an explicit value for this
3289 -- stored discriminant.
3293 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
3297 Next_Elmt
(Constraint
);
3300 -- Use the unconstrained expression type to retrieve the
3301 -- discriminants of the parent, and apply momentarily the
3302 -- discriminant constraint synthesized above.
3304 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
3305 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
3306 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
3309 Make_Raise_Constraint_Error
(Loc
,
3311 Reason
=> CE_Discriminant_Check_Failed
));
3314 -- For arrays, checks are set now, but conversions are applied during
3315 -- expansion, to take into accounts changes of representation. The
3316 -- checks become range checks on the base type or length checks on the
3317 -- subtype, depending on whether the target type is unconstrained or
3318 -- constrained. Note that the range check is put on the expression of a
3319 -- type conversion, while the length check is put on the type conversion
3322 elsif Is_Array_Type
(Target_Type
) then
3323 if Is_Constrained
(Target_Type
) then
3324 Set_Do_Length_Check
(N
);
3326 Set_Do_Range_Check
(Expr
);
3329 end Apply_Type_Conversion_Checks
;
3331 ----------------------------------------------
3332 -- Apply_Universal_Integer_Attribute_Checks --
3333 ----------------------------------------------
3335 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
3336 Loc
: constant Source_Ptr
:= Sloc
(N
);
3337 Typ
: constant Entity_Id
:= Etype
(N
);
3340 if Inside_A_Generic
then
3343 -- Nothing to do if checks are suppressed
3345 elsif Range_Checks_Suppressed
(Typ
)
3346 and then Overflow_Checks_Suppressed
(Typ
)
3350 -- Nothing to do if the attribute does not come from source. The
3351 -- internal attributes we generate of this type do not need checks,
3352 -- and furthermore the attempt to check them causes some circular
3353 -- elaboration orders when dealing with packed types.
3355 elsif not Comes_From_Source
(N
) then
3358 -- If the prefix is a selected component that depends on a discriminant
3359 -- the check may improperly expose a discriminant instead of using
3360 -- the bounds of the object itself. Set the type of the attribute to
3361 -- the base type of the context, so that a check will be imposed when
3362 -- needed (e.g. if the node appears as an index).
3364 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
3365 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
3366 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
3368 Set_Etype
(N
, Base_Type
(Typ
));
3370 -- Otherwise, replace the attribute node with a type conversion node
3371 -- whose expression is the attribute, retyped to universal integer, and
3372 -- whose subtype mark is the target type. The call to analyze this
3373 -- conversion will set range and overflow checks as required for proper
3374 -- detection of an out of range value.
3377 Set_Etype
(N
, Universal_Integer
);
3378 Set_Analyzed
(N
, True);
3381 Make_Type_Conversion
(Loc
,
3382 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
3383 Expression
=> Relocate_Node
(N
)));
3385 Analyze_And_Resolve
(N
, Typ
);
3388 end Apply_Universal_Integer_Attribute_Checks
;
3390 -------------------------------------
3391 -- Atomic_Synchronization_Disabled --
3392 -------------------------------------
3394 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3395 -- using a bogus check called Atomic_Synchronization. This is to make it
3396 -- more convenient to get exactly the same semantics as [Un]Suppress.
3398 function Atomic_Synchronization_Disabled
(E
: Entity_Id
) return Boolean is
3400 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3401 -- looks enabled, since it is never disabled.
3403 if Debug_Flag_Dot_E
then
3406 -- If debug flag d.d is set then always return True, i.e. all atomic
3407 -- sync looks disabled, since it always tests True.
3409 elsif Debug_Flag_Dot_D
then
3412 -- If entity present, then check result for that entity
3414 elsif Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3415 return Is_Check_Suppressed
(E
, Atomic_Synchronization
);
3417 -- Otherwise result depends on current scope setting
3420 return Scope_Suppress
.Suppress
(Atomic_Synchronization
);
3422 end Atomic_Synchronization_Disabled
;
3424 -------------------------------
3425 -- Build_Discriminant_Checks --
3426 -------------------------------
3428 function Build_Discriminant_Checks
3430 T_Typ
: Entity_Id
) return Node_Id
3432 Loc
: constant Source_Ptr
:= Sloc
(N
);
3435 Disc_Ent
: Entity_Id
;
3439 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
;
3441 ----------------------------------
3442 -- Aggregate_Discriminant_Value --
3443 ----------------------------------
3445 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
is
3449 -- The aggregate has been normalized with named associations. We use
3450 -- the Chars field to locate the discriminant to take into account
3451 -- discriminants in derived types, which carry the same name as those
3454 Assoc
:= First
(Component_Associations
(N
));
3455 while Present
(Assoc
) loop
3456 if Chars
(First
(Choices
(Assoc
))) = Chars
(Disc
) then
3457 return Expression
(Assoc
);
3463 -- Discriminant must have been found in the loop above
3465 raise Program_Error
;
3466 end Aggregate_Discriminant_Val
;
3468 -- Start of processing for Build_Discriminant_Checks
3471 -- Loop through discriminants evolving the condition
3474 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
3476 -- For a fully private type, use the discriminants of the parent type
3478 if Is_Private_Type
(T_Typ
)
3479 and then No
(Full_View
(T_Typ
))
3481 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
3483 Disc_Ent
:= First_Discriminant
(T_Typ
);
3486 while Present
(Disc
) loop
3487 Dval
:= Node
(Disc
);
3489 if Nkind
(Dval
) = N_Identifier
3490 and then Ekind
(Entity
(Dval
)) = E_Discriminant
3492 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
3494 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
3497 -- If we have an Unchecked_Union node, we can infer the discriminants
3500 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
3502 Get_Discriminant_Value
(
3503 First_Discriminant
(T_Typ
),
3505 Stored_Constraint
(T_Typ
)));
3507 elsif Nkind
(N
) = N_Aggregate
then
3509 Duplicate_Subexpr_No_Checks
3510 (Aggregate_Discriminant_Val
(Disc_Ent
));
3514 Make_Selected_Component
(Loc
,
3516 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
3518 Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
3520 Set_Is_In_Discriminant_Check
(Dref
);
3523 Evolve_Or_Else
(Cond
,
3526 Right_Opnd
=> Dval
));
3529 Next_Discriminant
(Disc_Ent
);
3533 end Build_Discriminant_Checks
;
3539 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
3547 -- Always check if not simple entity
3549 if Nkind
(Nod
) not in N_Has_Entity
3550 or else not Comes_From_Source
(Nod
)
3555 -- Look up tree for short circuit
3562 -- Done if out of subexpression (note that we allow generated stuff
3563 -- such as itype declarations in this context, to keep the loop going
3564 -- since we may well have generated such stuff in complex situations.
3565 -- Also done if no parent (probably an error condition, but no point
3566 -- in behaving nasty if we find it!)
3569 or else (K
not in N_Subexpr
and then Comes_From_Source
(P
))
3573 -- Or/Or Else case, where test is part of the right operand, or is
3574 -- part of one of the actions associated with the right operand, and
3575 -- the left operand is an equality test.
3577 elsif K
= N_Op_Or
then
3578 exit when N
= Right_Opnd
(P
)
3579 and then Nkind
(Left_Opnd
(P
)) = N_Op_Eq
;
3581 elsif K
= N_Or_Else
then
3582 exit when (N
= Right_Opnd
(P
)
3585 and then List_Containing
(N
) = Actions
(P
)))
3586 and then Nkind
(Left_Opnd
(P
)) = N_Op_Eq
;
3588 -- Similar test for the And/And then case, where the left operand
3589 -- is an inequality test.
3591 elsif K
= N_Op_And
then
3592 exit when N
= Right_Opnd
(P
)
3593 and then Nkind
(Left_Opnd
(P
)) = N_Op_Ne
;
3595 elsif K
= N_And_Then
then
3596 exit when (N
= Right_Opnd
(P
)
3599 and then List_Containing
(N
) = Actions
(P
)))
3600 and then Nkind
(Left_Opnd
(P
)) = N_Op_Ne
;
3606 -- If we fall through the loop, then we have a conditional with an
3607 -- appropriate test as its left operand. So test further.
3610 R
:= Right_Opnd
(L
);
3613 -- Left operand of test must match original variable
3615 if Nkind
(L
) not in N_Has_Entity
3616 or else Entity
(L
) /= Entity
(Nod
)
3621 -- Right operand of test must be key value (zero or null)
3624 when Access_Check
=>
3625 if not Known_Null
(R
) then
3629 when Division_Check
=>
3630 if not Compile_Time_Known_Value
(R
)
3631 or else Expr_Value
(R
) /= Uint_0
3637 raise Program_Error
;
3640 -- Here we have the optimizable case, warn if not short-circuited
3642 if K
= N_Op_And
or else K
= N_Op_Or
then
3644 when Access_Check
=>
3646 ("Constraint_Error may be raised (access check)??",
3648 when Division_Check
=>
3650 ("Constraint_Error may be raised (zero divide)??",
3654 raise Program_Error
;
3657 if K
= N_Op_And
then
3658 Error_Msg_N
-- CODEFIX
3659 ("use `AND THEN` instead of AND??", P
);
3661 Error_Msg_N
-- CODEFIX
3662 ("use `OR ELSE` instead of OR??", P
);
3665 -- If not short-circuited, we need the check
3669 -- If short-circuited, we can omit the check
3676 -----------------------------------
3677 -- Check_Valid_Lvalue_Subscripts --
3678 -----------------------------------
3680 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
3682 -- Skip this if range checks are suppressed
3684 if Range_Checks_Suppressed
(Etype
(Expr
)) then
3687 -- Only do this check for expressions that come from source. We assume
3688 -- that expander generated assignments explicitly include any necessary
3689 -- checks. Note that this is not just an optimization, it avoids
3690 -- infinite recursions!
3692 elsif not Comes_From_Source
(Expr
) then
3695 -- For a selected component, check the prefix
3697 elsif Nkind
(Expr
) = N_Selected_Component
then
3698 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3701 -- Case of indexed component
3703 elsif Nkind
(Expr
) = N_Indexed_Component
then
3704 Apply_Subscript_Validity_Checks
(Expr
);
3706 -- Prefix may itself be or contain an indexed component, and these
3707 -- subscripts need checking as well.
3709 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3711 end Check_Valid_Lvalue_Subscripts
;
3713 ----------------------------------
3714 -- Null_Exclusion_Static_Checks --
3715 ----------------------------------
3717 procedure Null_Exclusion_Static_Checks
(N
: Node_Id
) is
3718 Error_Node
: Node_Id
;
3720 Has_Null
: constant Boolean := Has_Null_Exclusion
(N
);
3721 K
: constant Node_Kind
:= Nkind
(N
);
3726 (K
= N_Component_Declaration
3727 or else K
= N_Discriminant_Specification
3728 or else K
= N_Function_Specification
3729 or else K
= N_Object_Declaration
3730 or else K
= N_Parameter_Specification
);
3732 if K
= N_Function_Specification
then
3733 Typ
:= Etype
(Defining_Entity
(N
));
3735 Typ
:= Etype
(Defining_Identifier
(N
));
3739 when N_Component_Declaration
=>
3740 if Present
(Access_Definition
(Component_Definition
(N
))) then
3741 Error_Node
:= Component_Definition
(N
);
3743 Error_Node
:= Subtype_Indication
(Component_Definition
(N
));
3746 when N_Discriminant_Specification
=>
3747 Error_Node
:= Discriminant_Type
(N
);
3749 when N_Function_Specification
=>
3750 Error_Node
:= Result_Definition
(N
);
3752 when N_Object_Declaration
=>
3753 Error_Node
:= Object_Definition
(N
);
3755 when N_Parameter_Specification
=>
3756 Error_Node
:= Parameter_Type
(N
);
3759 raise Program_Error
;
3764 -- Enforce legality rule 3.10 (13): A null exclusion can only be
3765 -- applied to an access [sub]type.
3767 if not Is_Access_Type
(Typ
) then
3769 ("`NOT NULL` allowed only for an access type", Error_Node
);
3771 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
3772 -- be applied to a [sub]type that does not exclude null already.
3774 elsif Can_Never_Be_Null
(Typ
)
3775 and then Comes_From_Source
(Typ
)
3778 ("`NOT NULL` not allowed (& already excludes null)",
3783 -- Check that null-excluding objects are always initialized, except for
3784 -- deferred constants, for which the expression will appear in the full
3787 if K
= N_Object_Declaration
3788 and then No
(Expression
(N
))
3789 and then not Constant_Present
(N
)
3790 and then not No_Initialization
(N
)
3792 -- Add an expression that assigns null. This node is needed by
3793 -- Apply_Compile_Time_Constraint_Error, which will replace this with
3794 -- a Constraint_Error node.
3796 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
3797 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
3799 Apply_Compile_Time_Constraint_Error
3800 (N
=> Expression
(N
),
3802 "(Ada 2005) null-excluding objects must be initialized??",
3803 Reason
=> CE_Null_Not_Allowed
);
3806 -- Check that a null-excluding component, formal or object is not being
3807 -- assigned a null value. Otherwise generate a warning message and
3808 -- replace Expression (N) by an N_Constraint_Error node.
3810 if K
/= N_Function_Specification
then
3811 Expr
:= Expression
(N
);
3813 if Present
(Expr
) and then Known_Null
(Expr
) then
3815 when N_Component_Declaration |
3816 N_Discriminant_Specification
=>
3817 Apply_Compile_Time_Constraint_Error
3819 Msg
=> "(Ada 2005) null not allowed " &
3820 "in null-excluding components??",
3821 Reason
=> CE_Null_Not_Allowed
);
3823 when N_Object_Declaration
=>
3824 Apply_Compile_Time_Constraint_Error
3826 Msg
=> "(Ada 2005) null not allowed " &
3827 "in null-excluding objects?",
3828 Reason
=> CE_Null_Not_Allowed
);
3830 when N_Parameter_Specification
=>
3831 Apply_Compile_Time_Constraint_Error
3833 Msg
=> "(Ada 2005) null not allowed " &
3834 "in null-excluding formals??",
3835 Reason
=> CE_Null_Not_Allowed
);
3842 end Null_Exclusion_Static_Checks
;
3844 ----------------------------------
3845 -- Conditional_Statements_Begin --
3846 ----------------------------------
3848 procedure Conditional_Statements_Begin
is
3850 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
3852 -- If stack overflows, kill all checks, that way we know to simply reset
3853 -- the number of saved checks to zero on return. This should never occur
3856 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
3859 -- In the normal case, we just make a new stack entry saving the current
3860 -- number of saved checks for a later restore.
3863 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
3865 if Debug_Flag_CC
then
3866 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
3870 end Conditional_Statements_Begin
;
3872 --------------------------------
3873 -- Conditional_Statements_End --
3874 --------------------------------
3876 procedure Conditional_Statements_End
is
3878 pragma Assert
(Saved_Checks_TOS
> 0);
3880 -- If the saved checks stack overflowed, then we killed all checks, so
3881 -- setting the number of saved checks back to zero is correct. This
3882 -- should never occur in practice.
3884 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
3885 Num_Saved_Checks
:= 0;
3887 -- In the normal case, restore the number of saved checks from the top
3891 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
3892 if Debug_Flag_CC
then
3893 w
("Conditional_Statements_End: Num_Saved_Checks = ",
3898 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
3899 end Conditional_Statements_End
;
3901 -------------------------
3902 -- Convert_From_Bignum --
3903 -------------------------
3905 function Convert_From_Bignum
(N
: Node_Id
) return Node_Id
is
3906 Loc
: constant Source_Ptr
:= Sloc
(N
);
3909 pragma Assert
(Is_RTE
(Etype
(N
), RE_Bignum
));
3911 -- Construct call From Bignum
3914 Make_Function_Call
(Loc
,
3916 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3917 Parameter_Associations
=> New_List
(Relocate_Node
(N
)));
3918 end Convert_From_Bignum
;
3920 -----------------------
3921 -- Convert_To_Bignum --
3922 -----------------------
3924 function Convert_To_Bignum
(N
: Node_Id
) return Node_Id
is
3925 Loc
: constant Source_Ptr
:= Sloc
(N
);
3928 -- Nothing to do if Bignum already except call Relocate_Node
3930 if Is_RTE
(Etype
(N
), RE_Bignum
) then
3931 return Relocate_Node
(N
);
3933 -- Otherwise construct call to To_Bignum, converting the operand to the
3934 -- required Long_Long_Integer form.
3937 pragma Assert
(Is_Signed_Integer_Type
(Etype
(N
)));
3939 Make_Function_Call
(Loc
,
3941 New_Occurrence_Of
(RTE
(RE_To_Bignum
), Loc
),
3942 Parameter_Associations
=> New_List
(
3943 Convert_To
(Standard_Long_Long_Integer
, Relocate_Node
(N
))));
3945 end Convert_To_Bignum
;
3947 ---------------------
3948 -- Determine_Range --
3949 ---------------------
3951 Cache_Size
: constant := 2 ** 10;
3952 type Cache_Index
is range 0 .. Cache_Size
- 1;
3953 -- Determine size of below cache (power of 2 is more efficient!)
3955 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
3956 Determine_Range_Cache_V
: array (Cache_Index
) of Boolean;
3957 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
3958 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
3959 -- The above arrays are used to implement a small direct cache for
3960 -- Determine_Range calls. Because of the way Determine_Range recursively
3961 -- traces subexpressions, and because overflow checking calls the routine
3962 -- on the way up the tree, a quadratic behavior can otherwise be
3963 -- encountered in large expressions. The cache entry for node N is stored
3964 -- in the (N mod Cache_Size) entry, and can be validated by checking the
3965 -- actual node value stored there. The Range_Cache_V array records the
3966 -- setting of Assume_Valid for the cache entry.
3968 procedure Determine_Range
3973 Assume_Valid
: Boolean := False)
3975 Typ
: Entity_Id
:= Etype
(N
);
3976 -- Type to use, may get reset to base type for possibly invalid entity
3980 -- Lo and Hi bounds of left operand
3984 -- Lo and Hi bounds of right (or only) operand
3987 -- Temp variable used to hold a bound node
3990 -- High bound of base type of expression
3994 -- Refined values for low and high bounds, after tightening
3997 -- Used in lower level calls to indicate if call succeeded
3999 Cindex
: Cache_Index
;
4000 -- Used to search cache
4005 function OK_Operands
return Boolean;
4006 -- Used for binary operators. Determines the ranges of the left and
4007 -- right operands, and if they are both OK, returns True, and puts
4008 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4014 function OK_Operands
return Boolean is
4017 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
4024 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4028 -- Start of processing for Determine_Range
4031 -- For temporary constants internally generated to remove side effects
4032 -- we must use the corresponding expression to determine the range of
4035 if Is_Entity_Name
(N
)
4036 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
4037 and then Ekind
(Entity
(N
)) = E_Constant
4038 and then Is_Internal_Name
(Chars
(Entity
(N
)))
4041 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
4045 -- Prevent junk warnings by initializing range variables
4052 -- If type is not defined, we can't determine its range
4056 -- We don't deal with anything except discrete types
4058 or else not Is_Discrete_Type
(Typ
)
4060 -- Ignore type for which an error has been posted, since range in
4061 -- this case may well be a bogosity deriving from the error. Also
4062 -- ignore if error posted on the reference node.
4064 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
4070 -- For all other cases, we can determine the range
4074 -- If value is compile time known, then the possible range is the one
4075 -- value that we know this expression definitely has!
4077 if Compile_Time_Known_Value
(N
) then
4078 Lo
:= Expr_Value
(N
);
4083 -- Return if already in the cache
4085 Cindex
:= Cache_Index
(N
mod Cache_Size
);
4087 if Determine_Range_Cache_N
(Cindex
) = N
4089 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
4091 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
4092 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
4096 -- Otherwise, start by finding the bounds of the type of the expression,
4097 -- the value cannot be outside this range (if it is, then we have an
4098 -- overflow situation, which is a separate check, we are talking here
4099 -- only about the expression value).
4101 -- First a check, never try to find the bounds of a generic type, since
4102 -- these bounds are always junk values, and it is only valid to look at
4103 -- the bounds in an instance.
4105 if Is_Generic_Type
(Typ
) then
4110 -- First step, change to use base type unless we know the value is valid
4112 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
4113 or else Assume_No_Invalid_Values
4114 or else Assume_Valid
4118 Typ
:= Underlying_Type
(Base_Type
(Typ
));
4121 -- Retrieve the base type. Handle the case where the base type is a
4122 -- private enumeration type.
4124 Btyp
:= Base_Type
(Typ
);
4126 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
4127 Btyp
:= Full_View
(Btyp
);
4130 -- We use the actual bound unless it is dynamic, in which case use the
4131 -- corresponding base type bound if possible. If we can't get a bound
4132 -- then we figure we can't determine the range (a peculiar case, that
4133 -- perhaps cannot happen, but there is no point in bombing in this
4134 -- optimization circuit.
4136 -- First the low bound
4138 Bound
:= Type_Low_Bound
(Typ
);
4140 if Compile_Time_Known_Value
(Bound
) then
4141 Lo
:= Expr_Value
(Bound
);
4143 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
4144 Lo
:= Expr_Value
(Type_Low_Bound
(Btyp
));
4151 -- Now the high bound
4153 Bound
:= Type_High_Bound
(Typ
);
4155 -- We need the high bound of the base type later on, and this should
4156 -- always be compile time known. Again, it is not clear that this
4157 -- can ever be false, but no point in bombing.
4159 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
4160 Hbound
:= Expr_Value
(Type_High_Bound
(Btyp
));
4168 -- If we have a static subtype, then that may have a tighter bound so
4169 -- use the upper bound of the subtype instead in this case.
4171 if Compile_Time_Known_Value
(Bound
) then
4172 Hi
:= Expr_Value
(Bound
);
4175 -- We may be able to refine this value in certain situations. If any
4176 -- refinement is possible, then Lor and Hir are set to possibly tighter
4177 -- bounds, and OK1 is set to True.
4181 -- For unary plus, result is limited by range of operand
4185 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4187 -- For unary minus, determine range of operand, and negate it
4191 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4198 -- For binary addition, get range of each operand and do the
4199 -- addition to get the result range.
4203 Lor
:= Lo_Left
+ Lo_Right
;
4204 Hir
:= Hi_Left
+ Hi_Right
;
4207 -- Division is tricky. The only case we consider is where the right
4208 -- operand is a positive constant, and in this case we simply divide
4209 -- the bounds of the left operand
4213 if Lo_Right
= Hi_Right
4214 and then Lo_Right
> 0
4216 Lor
:= Lo_Left
/ Lo_Right
;
4217 Hir
:= Hi_Left
/ Lo_Right
;
4224 -- For binary subtraction, get range of each operand and do the worst
4225 -- case subtraction to get the result range.
4227 when N_Op_Subtract
=>
4229 Lor
:= Lo_Left
- Hi_Right
;
4230 Hir
:= Hi_Left
- Lo_Right
;
4233 -- For MOD, if right operand is a positive constant, then result must
4234 -- be in the allowable range of mod results.
4238 if Lo_Right
= Hi_Right
4239 and then Lo_Right
/= 0
4241 if Lo_Right
> 0 then
4243 Hir
:= Lo_Right
- 1;
4245 else -- Lo_Right < 0
4246 Lor
:= Lo_Right
+ 1;
4255 -- For REM, if right operand is a positive constant, then result must
4256 -- be in the allowable range of mod results.
4260 if Lo_Right
= Hi_Right
4261 and then Lo_Right
/= 0
4264 Dval
: constant Uint
:= (abs Lo_Right
) - 1;
4267 -- The sign of the result depends on the sign of the
4268 -- dividend (but not on the sign of the divisor, hence
4269 -- the abs operation above).
4289 -- Attribute reference cases
4291 when N_Attribute_Reference
=>
4292 case Attribute_Name
(N
) is
4294 -- For Pos/Val attributes, we can refine the range using the
4295 -- possible range of values of the attribute expression.
4297 when Name_Pos | Name_Val
=>
4299 (First
(Expressions
(N
)), OK1
, Lor
, Hir
, Assume_Valid
);
4301 -- For Length attribute, use the bounds of the corresponding
4302 -- index type to refine the range.
4306 Atyp
: Entity_Id
:= Etype
(Prefix
(N
));
4314 if Is_Access_Type
(Atyp
) then
4315 Atyp
:= Designated_Type
(Atyp
);
4318 -- For string literal, we know exact value
4320 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
4322 Lo
:= String_Literal_Length
(Atyp
);
4323 Hi
:= String_Literal_Length
(Atyp
);
4327 -- Otherwise check for expression given
4329 if No
(Expressions
(N
)) then
4333 UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
4336 Indx
:= First_Index
(Atyp
);
4337 for J
in 2 .. Inum
loop
4338 Indx
:= Next_Index
(Indx
);
4341 -- If the index type is a formal type or derived from
4342 -- one, the bounds are not static.
4344 if Is_Generic_Type
(Root_Type
(Etype
(Indx
))) then
4350 (Type_Low_Bound
(Etype
(Indx
)), OK1
, LL
, LU
,
4355 (Type_High_Bound
(Etype
(Indx
)), OK1
, UL
, UU
,
4360 -- The maximum value for Length is the biggest
4361 -- possible gap between the values of the bounds.
4362 -- But of course, this value cannot be negative.
4364 Hir
:= UI_Max
(Uint_0
, UU
- LL
+ 1);
4366 -- For constrained arrays, the minimum value for
4367 -- Length is taken from the actual value of the
4368 -- bounds, since the index will be exactly of this
4371 if Is_Constrained
(Atyp
) then
4372 Lor
:= UI_Max
(Uint_0
, UL
- LU
+ 1);
4374 -- For an unconstrained array, the minimum value
4375 -- for length is always zero.
4384 -- No special handling for other attributes
4385 -- Probably more opportunities exist here???
4392 -- For type conversion from one discrete type to another, we can
4393 -- refine the range using the converted value.
4395 when N_Type_Conversion
=>
4396 Determine_Range
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4398 -- Nothing special to do for all other expression kinds
4406 -- At this stage, if OK1 is true, then we know that the actual result of
4407 -- the computed expression is in the range Lor .. Hir. We can use this
4408 -- to restrict the possible range of results.
4412 -- If the refined value of the low bound is greater than the type
4413 -- high bound, then reset it to the more restrictive value. However,
4414 -- we do NOT do this for the case of a modular type where the
4415 -- possible upper bound on the value is above the base type high
4416 -- bound, because that means the result could wrap.
4419 and then not (Is_Modular_Integer_Type
(Typ
) and then Hir
> Hbound
)
4424 -- Similarly, if the refined value of the high bound is less than the
4425 -- value so far, then reset it to the more restrictive value. Again,
4426 -- we do not do this if the refined low bound is negative for a
4427 -- modular type, since this would wrap.
4430 and then not (Is_Modular_Integer_Type
(Typ
) and then Lor
< Uint_0
)
4436 -- Set cache entry for future call and we are all done
4438 Determine_Range_Cache_N
(Cindex
) := N
;
4439 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
4440 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
4441 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
4444 -- If any exception occurs, it means that we have some bug in the compiler,
4445 -- possibly triggered by a previous error, or by some unforeseen peculiar
4446 -- occurrence. However, this is only an optimization attempt, so there is
4447 -- really no point in crashing the compiler. Instead we just decide, too
4448 -- bad, we can't figure out a range in this case after all.
4453 -- Debug flag K disables this behavior (useful for debugging)
4455 if Debug_Flag_K
then
4463 end Determine_Range
;
4465 ------------------------------------
4466 -- Discriminant_Checks_Suppressed --
4467 ------------------------------------
4469 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4472 if Is_Unchecked_Union
(E
) then
4474 elsif Checks_May_Be_Suppressed
(E
) then
4475 return Is_Check_Suppressed
(E
, Discriminant_Check
);
4479 return Scope_Suppress
.Suppress
(Discriminant_Check
);
4480 end Discriminant_Checks_Suppressed
;
4482 --------------------------------
4483 -- Division_Checks_Suppressed --
4484 --------------------------------
4486 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4488 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4489 return Is_Check_Suppressed
(E
, Division_Check
);
4491 return Scope_Suppress
.Suppress
(Division_Check
);
4493 end Division_Checks_Suppressed
;
4495 -----------------------------------
4496 -- Elaboration_Checks_Suppressed --
4497 -----------------------------------
4499 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4501 -- The complication in this routine is that if we are in the dynamic
4502 -- model of elaboration, we also check All_Checks, since All_Checks
4503 -- does not set Elaboration_Check explicitly.
4506 if Kill_Elaboration_Checks
(E
) then
4509 elsif Checks_May_Be_Suppressed
(E
) then
4510 if Is_Check_Suppressed
(E
, Elaboration_Check
) then
4512 elsif Dynamic_Elaboration_Checks
then
4513 return Is_Check_Suppressed
(E
, All_Checks
);
4520 if Scope_Suppress
.Suppress
(Elaboration_Check
) then
4522 elsif Dynamic_Elaboration_Checks
then
4523 return Scope_Suppress
.Suppress
(All_Checks
);
4527 end Elaboration_Checks_Suppressed
;
4529 ---------------------------
4530 -- Enable_Overflow_Check --
4531 ---------------------------
4533 procedure Enable_Overflow_Check
(N
: Node_Id
) is
4534 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
4535 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
4544 if Debug_Flag_CC
then
4545 w
("Enable_Overflow_Check for node ", Int
(N
));
4546 Write_Str
(" Source location = ");
4551 -- No check if overflow checks suppressed for type of node
4553 if Overflow_Checks_Suppressed
(Etype
(N
)) then
4556 -- Nothing to do for unsigned integer types, which do not overflow
4558 elsif Is_Modular_Integer_Type
(Typ
) then
4562 -- This is the point at which processing for STRICT mode diverges
4563 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
4564 -- probably more extreme that it needs to be, but what is going on here
4565 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
4566 -- to leave the processing for STRICT mode untouched. There were
4567 -- two reasons for this. First it avoided any incompatible change of
4568 -- behavior. Second, it guaranteed that STRICT mode continued to be
4571 -- The big difference is that in STRICT mode there is a fair amount of
4572 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
4573 -- know that no check is needed. We skip all that in the two new modes,
4574 -- since really overflow checking happens over a whole subtree, and we
4575 -- do the corresponding optimizations later on when applying the checks.
4577 if Mode
in Minimized_Or_Eliminated
then
4578 if not (Overflow_Checks_Suppressed
(Etype
(N
)))
4579 and then not (Is_Entity_Name
(N
)
4580 and then Overflow_Checks_Suppressed
(Entity
(N
)))
4582 Activate_Overflow_Check
(N
);
4585 if Debug_Flag_CC
then
4586 w
("Minimized/Eliminated mode");
4592 -- Remainder of processing is for STRICT case, and is unchanged from
4593 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
4595 -- Nothing to do if the range of the result is known OK. We skip this
4596 -- for conversions, since the caller already did the check, and in any
4597 -- case the condition for deleting the check for a type conversion is
4600 if Nkind
(N
) /= N_Type_Conversion
then
4601 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
4603 -- Note in the test below that we assume that the range is not OK
4604 -- if a bound of the range is equal to that of the type. That's not
4605 -- quite accurate but we do this for the following reasons:
4607 -- a) The way that Determine_Range works, it will typically report
4608 -- the bounds of the value as being equal to the bounds of the
4609 -- type, because it either can't tell anything more precise, or
4610 -- does not think it is worth the effort to be more precise.
4612 -- b) It is very unusual to have a situation in which this would
4613 -- generate an unnecessary overflow check (an example would be
4614 -- a subtype with a range 0 .. Integer'Last - 1 to which the
4615 -- literal value one is added).
4617 -- c) The alternative is a lot of special casing in this routine
4618 -- which would partially duplicate Determine_Range processing.
4621 and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
4622 and then Hi
< Expr_Value
(Type_High_Bound
(Typ
))
4624 if Debug_Flag_CC
then
4625 w
("No overflow check required");
4632 -- If not in optimizing mode, set flag and we are done. We are also done
4633 -- (and just set the flag) if the type is not a discrete type, since it
4634 -- is not worth the effort to eliminate checks for other than discrete
4635 -- types. In addition, we take this same path if we have stored the
4636 -- maximum number of checks possible already (a very unlikely situation,
4637 -- but we do not want to blow up!)
4639 if Optimization_Level
= 0
4640 or else not Is_Discrete_Type
(Etype
(N
))
4641 or else Num_Saved_Checks
= Saved_Checks
'Last
4643 Activate_Overflow_Check
(N
);
4645 if Debug_Flag_CC
then
4646 w
("Optimization off");
4652 -- Otherwise evaluate and check the expression
4657 Target_Type
=> Empty
,
4663 if Debug_Flag_CC
then
4664 w
("Called Find_Check");
4668 w
(" Check_Num = ", Chk
);
4669 w
(" Ent = ", Int
(Ent
));
4670 Write_Str
(" Ofs = ");
4675 -- If check is not of form to optimize, then set flag and we are done
4678 Activate_Overflow_Check
(N
);
4682 -- If check is already performed, then return without setting flag
4685 if Debug_Flag_CC
then
4686 w
("Check suppressed!");
4692 -- Here we will make a new entry for the new check
4694 Activate_Overflow_Check
(N
);
4695 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
4696 Saved_Checks
(Num_Saved_Checks
) :=
4701 Target_Type
=> Empty
);
4703 if Debug_Flag_CC
then
4704 w
("Make new entry, check number = ", Num_Saved_Checks
);
4705 w
(" Entity = ", Int
(Ent
));
4706 Write_Str
(" Offset = ");
4708 w
(" Check_Type = O");
4709 w
(" Target_Type = Empty");
4712 -- If we get an exception, then something went wrong, probably because of
4713 -- an error in the structure of the tree due to an incorrect program. Or it
4714 -- may be a bug in the optimization circuit. In either case the safest
4715 -- thing is simply to set the check flag unconditionally.
4719 Activate_Overflow_Check
(N
);
4721 if Debug_Flag_CC
then
4722 w
(" exception occurred, overflow flag set");
4726 end Enable_Overflow_Check
;
4728 ------------------------
4729 -- Enable_Range_Check --
4730 ------------------------
4732 procedure Enable_Range_Check
(N
: Node_Id
) is
4741 -- Return if unchecked type conversion with range check killed. In this
4742 -- case we never set the flag (that's what Kill_Range_Check is about!)
4744 if Nkind
(N
) = N_Unchecked_Type_Conversion
4745 and then Kill_Range_Check
(N
)
4750 -- Do not set range check flag if parent is assignment statement or
4751 -- object declaration with Suppress_Assignment_Checks flag set
4753 if Nkind_In
(Parent
(N
), N_Assignment_Statement
, N_Object_Declaration
)
4754 and then Suppress_Assignment_Checks
(Parent
(N
))
4759 -- Check for various cases where we should suppress the range check
4761 -- No check if range checks suppressed for type of node
4763 if Present
(Etype
(N
))
4764 and then Range_Checks_Suppressed
(Etype
(N
))
4768 -- No check if node is an entity name, and range checks are suppressed
4769 -- for this entity, or for the type of this entity.
4771 elsif Is_Entity_Name
(N
)
4772 and then (Range_Checks_Suppressed
(Entity
(N
))
4773 or else Range_Checks_Suppressed
(Etype
(Entity
(N
))))
4777 -- No checks if index of array, and index checks are suppressed for
4778 -- the array object or the type of the array.
4780 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
then
4782 Pref
: constant Node_Id
:= Prefix
(Parent
(N
));
4784 if Is_Entity_Name
(Pref
)
4785 and then Index_Checks_Suppressed
(Entity
(Pref
))
4788 elsif Index_Checks_Suppressed
(Etype
(Pref
)) then
4794 -- Debug trace output
4796 if Debug_Flag_CC
then
4797 w
("Enable_Range_Check for node ", Int
(N
));
4798 Write_Str
(" Source location = ");
4803 -- If not in optimizing mode, set flag and we are done. We are also done
4804 -- (and just set the flag) if the type is not a discrete type, since it
4805 -- is not worth the effort to eliminate checks for other than discrete
4806 -- types. In addition, we take this same path if we have stored the
4807 -- maximum number of checks possible already (a very unlikely situation,
4808 -- but we do not want to blow up!)
4810 if Optimization_Level
= 0
4811 or else No
(Etype
(N
))
4812 or else not Is_Discrete_Type
(Etype
(N
))
4813 or else Num_Saved_Checks
= Saved_Checks
'Last
4815 Activate_Range_Check
(N
);
4817 if Debug_Flag_CC
then
4818 w
("Optimization off");
4824 -- Otherwise find out the target type
4828 -- For assignment, use left side subtype
4830 if Nkind
(P
) = N_Assignment_Statement
4831 and then Expression
(P
) = N
4833 Ttyp
:= Etype
(Name
(P
));
4835 -- For indexed component, use subscript subtype
4837 elsif Nkind
(P
) = N_Indexed_Component
then
4844 Atyp
:= Etype
(Prefix
(P
));
4846 if Is_Access_Type
(Atyp
) then
4847 Atyp
:= Designated_Type
(Atyp
);
4849 -- If the prefix is an access to an unconstrained array,
4850 -- perform check unconditionally: it depends on the bounds of
4851 -- an object and we cannot currently recognize whether the test
4852 -- may be redundant.
4854 if not Is_Constrained
(Atyp
) then
4855 Activate_Range_Check
(N
);
4859 -- Ditto if the prefix is an explicit dereference whose designated
4860 -- type is unconstrained.
4862 elsif Nkind
(Prefix
(P
)) = N_Explicit_Dereference
4863 and then not Is_Constrained
(Atyp
)
4865 Activate_Range_Check
(N
);
4869 Indx
:= First_Index
(Atyp
);
4870 Subs
:= First
(Expressions
(P
));
4873 Ttyp
:= Etype
(Indx
);
4882 -- For now, ignore all other cases, they are not so interesting
4885 if Debug_Flag_CC
then
4886 w
(" target type not found, flag set");
4889 Activate_Range_Check
(N
);
4893 -- Evaluate and check the expression
4898 Target_Type
=> Ttyp
,
4904 if Debug_Flag_CC
then
4905 w
("Called Find_Check");
4906 w
("Target_Typ = ", Int
(Ttyp
));
4910 w
(" Check_Num = ", Chk
);
4911 w
(" Ent = ", Int
(Ent
));
4912 Write_Str
(" Ofs = ");
4917 -- If check is not of form to optimize, then set flag and we are done
4920 if Debug_Flag_CC
then
4921 w
(" expression not of optimizable type, flag set");
4924 Activate_Range_Check
(N
);
4928 -- If check is already performed, then return without setting flag
4931 if Debug_Flag_CC
then
4932 w
("Check suppressed!");
4938 -- Here we will make a new entry for the new check
4940 Activate_Range_Check
(N
);
4941 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
4942 Saved_Checks
(Num_Saved_Checks
) :=
4947 Target_Type
=> Ttyp
);
4949 if Debug_Flag_CC
then
4950 w
("Make new entry, check number = ", Num_Saved_Checks
);
4951 w
(" Entity = ", Int
(Ent
));
4952 Write_Str
(" Offset = ");
4954 w
(" Check_Type = R");
4955 w
(" Target_Type = ", Int
(Ttyp
));
4956 pg
(Union_Id
(Ttyp
));
4959 -- If we get an exception, then something went wrong, probably because of
4960 -- an error in the structure of the tree due to an incorrect program. Or
4961 -- it may be a bug in the optimization circuit. In either case the safest
4962 -- thing is simply to set the check flag unconditionally.
4966 Activate_Range_Check
(N
);
4968 if Debug_Flag_CC
then
4969 w
(" exception occurred, range flag set");
4973 end Enable_Range_Check
;
4979 procedure Ensure_Valid
(Expr
: Node_Id
; Holes_OK
: Boolean := False) is
4980 Typ
: constant Entity_Id
:= Etype
(Expr
);
4983 -- Ignore call if we are not doing any validity checking
4985 if not Validity_Checks_On
then
4988 -- Ignore call if range or validity checks suppressed on entity or type
4990 elsif Range_Or_Validity_Checks_Suppressed
(Expr
) then
4993 -- No check required if expression is from the expander, we assume the
4994 -- expander will generate whatever checks are needed. Note that this is
4995 -- not just an optimization, it avoids infinite recursions!
4997 -- Unchecked conversions must be checked, unless they are initialized
4998 -- scalar values, as in a component assignment in an init proc.
5000 -- In addition, we force a check if Force_Validity_Checks is set
5002 elsif not Comes_From_Source
(Expr
)
5003 and then not Force_Validity_Checks
5004 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
5005 or else Kill_Range_Check
(Expr
))
5009 -- No check required if expression is known to have valid value
5011 elsif Expr_Known_Valid
(Expr
) then
5014 -- Ignore case of enumeration with holes where the flag is set not to
5015 -- worry about holes, since no special validity check is needed
5017 elsif Is_Enumeration_Type
(Typ
)
5018 and then Has_Non_Standard_Rep
(Typ
)
5023 -- No check required on the left-hand side of an assignment
5025 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
5026 and then Expr
= Name
(Parent
(Expr
))
5030 -- No check on a universal real constant. The context will eventually
5031 -- convert it to a machine number for some target type, or report an
5034 elsif Nkind
(Expr
) = N_Real_Literal
5035 and then Etype
(Expr
) = Universal_Real
5039 -- If the expression denotes a component of a packed boolean array,
5040 -- no possible check applies. We ignore the old ACATS chestnuts that
5041 -- involve Boolean range True..True.
5043 -- Note: validity checks are generated for expressions that yield a
5044 -- scalar type, when it is possible to create a value that is outside of
5045 -- the type. If this is a one-bit boolean no such value exists. This is
5046 -- an optimization, and it also prevents compiler blowing up during the
5047 -- elaboration of improperly expanded packed array references.
5049 elsif Nkind
(Expr
) = N_Indexed_Component
5050 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Expr
)))
5051 and then Root_Type
(Etype
(Expr
)) = Standard_Boolean
5055 -- An annoying special case. If this is an out parameter of a scalar
5056 -- type, then the value is not going to be accessed, therefore it is
5057 -- inappropriate to do any validity check at the call site.
5060 -- Only need to worry about scalar types
5062 if Is_Scalar_Type
(Typ
) then
5072 -- Find actual argument (which may be a parameter association)
5073 -- and the parent of the actual argument (the call statement)
5078 if Nkind
(P
) = N_Parameter_Association
then
5083 -- Only need to worry if we are argument of a procedure call
5084 -- since functions don't have out parameters. If this is an
5085 -- indirect or dispatching call, get signature from the
5088 if Nkind
(P
) = N_Procedure_Call_Statement
then
5089 L
:= Parameter_Associations
(P
);
5091 if Is_Entity_Name
(Name
(P
)) then
5092 E
:= Entity
(Name
(P
));
5094 pragma Assert
(Nkind
(Name
(P
)) = N_Explicit_Dereference
);
5095 E
:= Etype
(Name
(P
));
5098 -- Only need to worry if there are indeed actuals, and if
5099 -- this could be a procedure call, otherwise we cannot get a
5100 -- match (either we are not an argument, or the mode of the
5101 -- formal is not OUT). This test also filters out the
5104 if Is_Non_Empty_List
(L
)
5105 and then Is_Subprogram
(E
)
5107 -- This is the loop through parameters, looking for an
5108 -- OUT parameter for which we are the argument.
5110 F
:= First_Formal
(E
);
5112 while Present
(F
) loop
5113 if Ekind
(F
) = E_Out_Parameter
and then A
= N
then
5126 -- If this is a boolean expression, only its elementary operands need
5127 -- checking: if they are valid, a boolean or short-circuit operation
5128 -- with them will be valid as well.
5130 if Base_Type
(Typ
) = Standard_Boolean
5132 (Nkind
(Expr
) in N_Op
or else Nkind
(Expr
) in N_Short_Circuit
)
5137 -- If we fall through, a validity check is required
5139 Insert_Valid_Check
(Expr
);
5141 if Is_Entity_Name
(Expr
)
5142 and then Safe_To_Capture_Value
(Expr
, Entity
(Expr
))
5144 Set_Is_Known_Valid
(Entity
(Expr
));
5148 ----------------------
5149 -- Expr_Known_Valid --
5150 ----------------------
5152 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
5153 Typ
: constant Entity_Id
:= Etype
(Expr
);
5156 -- Non-scalar types are always considered valid, since they never give
5157 -- rise to the issues of erroneous or bounded error behavior that are
5158 -- the concern. In formal reference manual terms the notion of validity
5159 -- only applies to scalar types. Note that even when packed arrays are
5160 -- represented using modular types, they are still arrays semantically,
5161 -- so they are also always valid (in particular, the unused bits can be
5162 -- random rubbish without affecting the validity of the array value).
5164 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Type
(Typ
) then
5167 -- If no validity checking, then everything is considered valid
5169 elsif not Validity_Checks_On
then
5172 -- Floating-point types are considered valid unless floating-point
5173 -- validity checks have been specifically turned on.
5175 elsif Is_Floating_Point_Type
(Typ
)
5176 and then not Validity_Check_Floating_Point
5180 -- If the expression is the value of an object that is known to be
5181 -- valid, then clearly the expression value itself is valid.
5183 elsif Is_Entity_Name
(Expr
)
5184 and then Is_Known_Valid
(Entity
(Expr
))
5188 -- References to discriminants are always considered valid. The value
5189 -- of a discriminant gets checked when the object is built. Within the
5190 -- record, we consider it valid, and it is important to do so, since
5191 -- otherwise we can try to generate bogus validity checks which
5192 -- reference discriminants out of scope. Discriminants of concurrent
5193 -- types are excluded for the same reason.
5195 elsif Is_Entity_Name
(Expr
)
5196 and then Denotes_Discriminant
(Expr
, Check_Concurrent
=> True)
5200 -- If the type is one for which all values are known valid, then we are
5201 -- sure that the value is valid except in the slightly odd case where
5202 -- the expression is a reference to a variable whose size has been
5203 -- explicitly set to a value greater than the object size.
5205 elsif Is_Known_Valid
(Typ
) then
5206 if Is_Entity_Name
(Expr
)
5207 and then Ekind
(Entity
(Expr
)) = E_Variable
5208 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
5215 -- Integer and character literals always have valid values, where
5216 -- appropriate these will be range checked in any case.
5218 elsif Nkind
(Expr
) = N_Integer_Literal
5220 Nkind
(Expr
) = N_Character_Literal
5224 -- Real literals are assumed to be valid in VM targets
5226 elsif VM_Target
/= No_VM
5227 and then Nkind
(Expr
) = N_Real_Literal
5231 -- If we have a type conversion or a qualification of a known valid
5232 -- value, then the result will always be valid.
5234 elsif Nkind
(Expr
) = N_Type_Conversion
5236 Nkind
(Expr
) = N_Qualified_Expression
5238 return Expr_Known_Valid
(Expression
(Expr
));
5240 -- The result of any operator is always considered valid, since we
5241 -- assume the necessary checks are done by the operator. For operators
5242 -- on floating-point operations, we must also check when the operation
5243 -- is the right-hand side of an assignment, or is an actual in a call.
5245 elsif Nkind
(Expr
) in N_Op
then
5246 if Is_Floating_Point_Type
(Typ
)
5247 and then Validity_Check_Floating_Point
5249 (Nkind
(Parent
(Expr
)) = N_Assignment_Statement
5250 or else Nkind
(Parent
(Expr
)) = N_Function_Call
5251 or else Nkind
(Parent
(Expr
)) = N_Parameter_Association
)
5258 -- The result of a membership test is always valid, since it is true or
5259 -- false, there are no other possibilities.
5261 elsif Nkind
(Expr
) in N_Membership_Test
then
5264 -- For all other cases, we do not know the expression is valid
5269 end Expr_Known_Valid
;
5275 procedure Find_Check
5277 Check_Type
: Character;
5278 Target_Type
: Entity_Id
;
5279 Entry_OK
: out Boolean;
5280 Check_Num
: out Nat
;
5281 Ent
: out Entity_Id
;
5284 function Within_Range_Of
5285 (Target_Type
: Entity_Id
;
5286 Check_Type
: Entity_Id
) return Boolean;
5287 -- Given a requirement for checking a range against Target_Type, and
5288 -- and a range Check_Type against which a check has already been made,
5289 -- determines if the check against check type is sufficient to ensure
5290 -- that no check against Target_Type is required.
5292 ---------------------
5293 -- Within_Range_Of --
5294 ---------------------
5296 function Within_Range_Of
5297 (Target_Type
: Entity_Id
;
5298 Check_Type
: Entity_Id
) return Boolean
5301 if Target_Type
= Check_Type
then
5306 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
5307 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
5308 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
5309 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
5313 or else (Compile_Time_Known_Value
(Tlo
)
5315 Compile_Time_Known_Value
(Clo
)
5317 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
5320 or else (Compile_Time_Known_Value
(Thi
)
5322 Compile_Time_Known_Value
(Chi
)
5324 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
5332 end Within_Range_Of
;
5334 -- Start of processing for Find_Check
5337 -- Establish default, in case no entry is found
5341 -- Case of expression is simple entity reference
5343 if Is_Entity_Name
(Expr
) then
5344 Ent
:= Entity
(Expr
);
5347 -- Case of expression is entity + known constant
5349 elsif Nkind
(Expr
) = N_Op_Add
5350 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
5351 and then Is_Entity_Name
(Left_Opnd
(Expr
))
5353 Ent
:= Entity
(Left_Opnd
(Expr
));
5354 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
5356 -- Case of expression is entity - known constant
5358 elsif Nkind
(Expr
) = N_Op_Subtract
5359 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
5360 and then Is_Entity_Name
(Left_Opnd
(Expr
))
5362 Ent
:= Entity
(Left_Opnd
(Expr
));
5363 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
5365 -- Any other expression is not of the right form
5374 -- Come here with expression of appropriate form, check if entity is an
5375 -- appropriate one for our purposes.
5377 if (Ekind
(Ent
) = E_Variable
5378 or else Is_Constant_Object
(Ent
))
5379 and then not Is_Library_Level_Entity
(Ent
)
5387 -- See if there is matching check already
5389 for J
in reverse 1 .. Num_Saved_Checks
loop
5391 SC
: Saved_Check
renames Saved_Checks
(J
);
5394 if SC
.Killed
= False
5395 and then SC
.Entity
= Ent
5396 and then SC
.Offset
= Ofs
5397 and then SC
.Check_Type
= Check_Type
5398 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
5406 -- If we fall through entry was not found
5411 ---------------------------------
5412 -- Generate_Discriminant_Check --
5413 ---------------------------------
5415 -- Note: the code for this procedure is derived from the
5416 -- Emit_Discriminant_Check Routine in trans.c.
5418 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
5419 Loc
: constant Source_Ptr
:= Sloc
(N
);
5420 Pref
: constant Node_Id
:= Prefix
(N
);
5421 Sel
: constant Node_Id
:= Selector_Name
(N
);
5423 Orig_Comp
: constant Entity_Id
:=
5424 Original_Record_Component
(Entity
(Sel
));
5425 -- The original component to be checked
5427 Discr_Fct
: constant Entity_Id
:=
5428 Discriminant_Checking_Func
(Orig_Comp
);
5429 -- The discriminant checking function
5432 -- One discriminant to be checked in the type
5434 Real_Discr
: Entity_Id
;
5435 -- Actual discriminant in the call
5437 Pref_Type
: Entity_Id
;
5438 -- Type of relevant prefix (ignoring private/access stuff)
5441 -- List of arguments for function call
5444 -- Keep track of the formal corresponding to the actual we build for
5445 -- each discriminant, in order to be able to perform the necessary type
5449 -- Selected component reference for checking function argument
5452 Pref_Type
:= Etype
(Pref
);
5454 -- Force evaluation of the prefix, so that it does not get evaluated
5455 -- twice (once for the check, once for the actual reference). Such a
5456 -- double evaluation is always a potential source of inefficiency,
5457 -- and is functionally incorrect in the volatile case, or when the
5458 -- prefix may have side-effects. An entity or a component of an
5459 -- entity requires no evaluation.
5461 if Is_Entity_Name
(Pref
) then
5462 if Treat_As_Volatile
(Entity
(Pref
)) then
5463 Force_Evaluation
(Pref
, Name_Req
=> True);
5466 elsif Treat_As_Volatile
(Etype
(Pref
)) then
5467 Force_Evaluation
(Pref
, Name_Req
=> True);
5469 elsif Nkind
(Pref
) = N_Selected_Component
5470 and then Is_Entity_Name
(Prefix
(Pref
))
5475 Force_Evaluation
(Pref
, Name_Req
=> True);
5478 -- For a tagged type, use the scope of the original component to
5479 -- obtain the type, because ???
5481 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
5482 Pref_Type
:= Scope
(Orig_Comp
);
5484 -- For an untagged derived type, use the discriminants of the parent
5485 -- which have been renamed in the derivation, possibly by a one-to-many
5486 -- discriminant constraint. For non-tagged type, initially get the Etype
5490 if Is_Derived_Type
(Pref_Type
)
5491 and then Number_Discriminants
(Pref_Type
) /=
5492 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
5494 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
5498 -- We definitely should have a checking function, This routine should
5499 -- not be called if no discriminant checking function is present.
5501 pragma Assert
(Present
(Discr_Fct
));
5503 -- Create the list of the actual parameters for the call. This list
5504 -- is the list of the discriminant fields of the record expression to
5505 -- be discriminant checked.
5508 Formal
:= First_Formal
(Discr_Fct
);
5509 Discr
:= First_Discriminant
(Pref_Type
);
5510 while Present
(Discr
) loop
5512 -- If we have a corresponding discriminant field, and a parent
5513 -- subtype is present, then we want to use the corresponding
5514 -- discriminant since this is the one with the useful value.
5516 if Present
(Corresponding_Discriminant
(Discr
))
5517 and then Ekind
(Pref_Type
) = E_Record_Type
5518 and then Present
(Parent_Subtype
(Pref_Type
))
5520 Real_Discr
:= Corresponding_Discriminant
(Discr
);
5522 Real_Discr
:= Discr
;
5525 -- Construct the reference to the discriminant
5528 Make_Selected_Component
(Loc
,
5530 Unchecked_Convert_To
(Pref_Type
,
5531 Duplicate_Subexpr
(Pref
)),
5532 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
5534 -- Manually analyze and resolve this selected component. We really
5535 -- want it just as it appears above, and do not want the expander
5536 -- playing discriminal games etc with this reference. Then we append
5537 -- the argument to the list we are gathering.
5539 Set_Etype
(Scomp
, Etype
(Real_Discr
));
5540 Set_Analyzed
(Scomp
, True);
5541 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
5543 Next_Formal_With_Extras
(Formal
);
5544 Next_Discriminant
(Discr
);
5547 -- Now build and insert the call
5550 Make_Raise_Constraint_Error
(Loc
,
5552 Make_Function_Call
(Loc
,
5553 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
5554 Parameter_Associations
=> Args
),
5555 Reason
=> CE_Discriminant_Check_Failed
));
5556 end Generate_Discriminant_Check
;
5558 ---------------------------
5559 -- Generate_Index_Checks --
5560 ---------------------------
5562 procedure Generate_Index_Checks
(N
: Node_Id
) is
5564 function Entity_Of_Prefix
return Entity_Id
;
5565 -- Returns the entity of the prefix of N (or Empty if not found)
5567 ----------------------
5568 -- Entity_Of_Prefix --
5569 ----------------------
5571 function Entity_Of_Prefix
return Entity_Id
is
5576 while not Is_Entity_Name
(P
) loop
5577 if not Nkind_In
(P
, N_Selected_Component
,
5578 N_Indexed_Component
)
5587 end Entity_Of_Prefix
;
5591 Loc
: constant Source_Ptr
:= Sloc
(N
);
5592 A
: constant Node_Id
:= Prefix
(N
);
5593 A_Ent
: constant Entity_Id
:= Entity_Of_Prefix
;
5596 -- Start of processing for Generate_Index_Checks
5599 -- Ignore call if the prefix is not an array since we have a serious
5600 -- error in the sources. Ignore it also if index checks are suppressed
5601 -- for array object or type.
5603 if not Is_Array_Type
(Etype
(A
))
5604 or else (Present
(A_Ent
)
5605 and then Index_Checks_Suppressed
(A_Ent
))
5606 or else Index_Checks_Suppressed
(Etype
(A
))
5610 -- The indexed component we are dealing with contains 'Loop_Entry in its
5611 -- prefix. This case arises when analysis has determined that constructs
5614 -- Prefix'Loop_Entry (Expr)
5615 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
5617 -- require rewriting for error detection purposes. A side effect of this
5618 -- action is the generation of index checks that mention 'Loop_Entry.
5619 -- Delay the generation of the check until 'Loop_Entry has been properly
5620 -- expanded. This is done in Expand_Loop_Entry_Attributes.
5622 elsif Nkind
(Prefix
(N
)) = N_Attribute_Reference
5623 and then Attribute_Name
(Prefix
(N
)) = Name_Loop_Entry
5628 -- Generate a raise of constraint error with the appropriate reason and
5629 -- a condition of the form:
5631 -- Base_Type (Sub) not in Array'Range (Subscript)
5633 -- Note that the reason we generate the conversion to the base type here
5634 -- is that we definitely want the range check to take place, even if it
5635 -- looks like the subtype is OK. Optimization considerations that allow
5636 -- us to omit the check have already been taken into account in the
5637 -- setting of the Do_Range_Check flag earlier on.
5639 Sub
:= First
(Expressions
(N
));
5641 -- Handle string literals
5643 if Ekind
(Etype
(A
)) = E_String_Literal_Subtype
then
5644 if Do_Range_Check
(Sub
) then
5645 Set_Do_Range_Check
(Sub
, False);
5647 -- For string literals we obtain the bounds of the string from the
5648 -- associated subtype.
5651 Make_Raise_Constraint_Error
(Loc
,
5655 Convert_To
(Base_Type
(Etype
(Sub
)),
5656 Duplicate_Subexpr_Move_Checks
(Sub
)),
5658 Make_Attribute_Reference
(Loc
,
5659 Prefix
=> New_Reference_To
(Etype
(A
), Loc
),
5660 Attribute_Name
=> Name_Range
)),
5661 Reason
=> CE_Index_Check_Failed
));
5668 A_Idx
: Node_Id
:= Empty
;
5675 A_Idx
:= First_Index
(Etype
(A
));
5677 while Present
(Sub
) loop
5678 if Do_Range_Check
(Sub
) then
5679 Set_Do_Range_Check
(Sub
, False);
5681 -- Force evaluation except for the case of a simple name of
5682 -- a non-volatile entity.
5684 if not Is_Entity_Name
(Sub
)
5685 or else Treat_As_Volatile
(Entity
(Sub
))
5687 Force_Evaluation
(Sub
);
5690 if Nkind
(A_Idx
) = N_Range
then
5693 elsif Nkind
(A_Idx
) = N_Identifier
5694 or else Nkind
(A_Idx
) = N_Expanded_Name
5696 A_Range
:= Scalar_Range
(Entity
(A_Idx
));
5698 else pragma Assert
(Nkind
(A_Idx
) = N_Subtype_Indication
);
5699 A_Range
:= Range_Expression
(Constraint
(A_Idx
));
5702 -- For array objects with constant bounds we can generate
5703 -- the index check using the bounds of the type of the index
5706 and then Ekind
(A_Ent
) = E_Variable
5707 and then Is_Constant_Bound
(Low_Bound
(A_Range
))
5708 and then Is_Constant_Bound
(High_Bound
(A_Range
))
5711 Make_Attribute_Reference
(Loc
,
5713 New_Reference_To
(Etype
(A_Idx
), Loc
),
5714 Attribute_Name
=> Name_Range
);
5716 -- For arrays with non-constant bounds we cannot generate
5717 -- the index check using the bounds of the type of the index
5718 -- since it may reference discriminants of some enclosing
5719 -- type. We obtain the bounds directly from the prefix
5726 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
5730 Make_Attribute_Reference
(Loc
,
5732 Duplicate_Subexpr_Move_Checks
(A
, Name_Req
=> True),
5733 Attribute_Name
=> Name_Range
,
5734 Expressions
=> Num
);
5738 Make_Raise_Constraint_Error
(Loc
,
5742 Convert_To
(Base_Type
(Etype
(Sub
)),
5743 Duplicate_Subexpr_Move_Checks
(Sub
)),
5744 Right_Opnd
=> Range_N
),
5745 Reason
=> CE_Index_Check_Failed
));
5748 A_Idx
:= Next_Index
(A_Idx
);
5754 end Generate_Index_Checks
;
5756 --------------------------
5757 -- Generate_Range_Check --
5758 --------------------------
5760 procedure Generate_Range_Check
5762 Target_Type
: Entity_Id
;
5763 Reason
: RT_Exception_Code
)
5765 Loc
: constant Source_Ptr
:= Sloc
(N
);
5766 Source_Type
: constant Entity_Id
:= Etype
(N
);
5767 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
5768 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
5771 -- First special case, if the source type is already within the range
5772 -- of the target type, then no check is needed (probably we should have
5773 -- stopped Do_Range_Check from being set in the first place, but better
5774 -- late than never in preventing junk code!
5776 if In_Subrange_Of
(Source_Type
, Target_Type
)
5778 -- We do NOT apply this if the source node is a literal, since in this
5779 -- case the literal has already been labeled as having the subtype of
5783 (Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
, N_Character_Literal
)
5786 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
5788 -- Also do not apply this for floating-point if Check_Float_Overflow
5791 (Is_Floating_Point_Type
(Source_Type
) and Check_Float_Overflow
)
5796 -- We need a check, so force evaluation of the node, so that it does
5797 -- not get evaluated twice (once for the check, once for the actual
5798 -- reference). Such a double evaluation is always a potential source
5799 -- of inefficiency, and is functionally incorrect in the volatile case.
5801 if not Is_Entity_Name
(N
) or else Treat_As_Volatile
(Entity
(N
)) then
5802 Force_Evaluation
(N
);
5805 -- The easiest case is when Source_Base_Type and Target_Base_Type are
5806 -- the same since in this case we can simply do a direct check of the
5807 -- value of N against the bounds of Target_Type.
5809 -- [constraint_error when N not in Target_Type]
5811 -- Note: this is by far the most common case, for example all cases of
5812 -- checks on the RHS of assignments are in this category, but not all
5813 -- cases are like this. Notably conversions can involve two types.
5815 if Source_Base_Type
= Target_Base_Type
then
5817 Make_Raise_Constraint_Error
(Loc
,
5820 Left_Opnd
=> Duplicate_Subexpr
(N
),
5821 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
5824 -- Next test for the case where the target type is within the bounds
5825 -- of the base type of the source type, since in this case we can
5826 -- simply convert these bounds to the base type of T to do the test.
5828 -- [constraint_error when N not in
5829 -- Source_Base_Type (Target_Type'First)
5831 -- Source_Base_Type(Target_Type'Last))]
5833 -- The conversions will always work and need no check
5835 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
5836 -- of converting from an enumeration value to an integer type, such as
5837 -- occurs for the case of generating a range check on Enum'Val(Exp)
5838 -- (which used to be handled by gigi). This is OK, since the conversion
5839 -- itself does not require a check.
5841 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
5843 Make_Raise_Constraint_Error
(Loc
,
5846 Left_Opnd
=> Duplicate_Subexpr
(N
),
5851 Unchecked_Convert_To
(Source_Base_Type
,
5852 Make_Attribute_Reference
(Loc
,
5854 New_Occurrence_Of
(Target_Type
, Loc
),
5855 Attribute_Name
=> Name_First
)),
5858 Unchecked_Convert_To
(Source_Base_Type
,
5859 Make_Attribute_Reference
(Loc
,
5861 New_Occurrence_Of
(Target_Type
, Loc
),
5862 Attribute_Name
=> Name_Last
)))),
5865 -- Note that at this stage we now that the Target_Base_Type is not in
5866 -- the range of the Source_Base_Type (since even the Target_Type itself
5867 -- is not in this range). It could still be the case that Source_Type is
5868 -- in range of the target base type since we have not checked that case.
5870 -- If that is the case, we can freely convert the source to the target,
5871 -- and then test the target result against the bounds.
5873 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
5875 -- We make a temporary to hold the value of the converted value
5876 -- (converted to the base type), and then we will do the test against
5879 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
5880 -- [constraint_error when Tnn not in Target_Type]
5882 -- Then the conversion itself is replaced by an occurrence of Tnn
5885 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
5888 Insert_Actions
(N
, New_List
(
5889 Make_Object_Declaration
(Loc
,
5890 Defining_Identifier
=> Tnn
,
5891 Object_Definition
=>
5892 New_Occurrence_Of
(Target_Base_Type
, Loc
),
5893 Constant_Present
=> True,
5895 Make_Type_Conversion
(Loc
,
5896 Subtype_Mark
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
5897 Expression
=> Duplicate_Subexpr
(N
))),
5899 Make_Raise_Constraint_Error
(Loc
,
5902 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
5903 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
5905 Reason
=> Reason
)));
5907 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
5909 -- Set the type of N, because the declaration for Tnn might not
5910 -- be analyzed yet, as is the case if N appears within a record
5911 -- declaration, as a discriminant constraint or expression.
5913 Set_Etype
(N
, Target_Base_Type
);
5916 -- At this stage, we know that we have two scalar types, which are
5917 -- directly convertible, and where neither scalar type has a base
5918 -- range that is in the range of the other scalar type.
5920 -- The only way this can happen is with a signed and unsigned type.
5921 -- So test for these two cases:
5924 -- Case of the source is unsigned and the target is signed
5926 if Is_Unsigned_Type
(Source_Base_Type
)
5927 and then not Is_Unsigned_Type
(Target_Base_Type
)
5929 -- If the source is unsigned and the target is signed, then we
5930 -- know that the source is not shorter than the target (otherwise
5931 -- the source base type would be in the target base type range).
5933 -- In other words, the unsigned type is either the same size as
5934 -- the target, or it is larger. It cannot be smaller.
5937 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
5939 -- We only need to check the low bound if the low bound of the
5940 -- target type is non-negative. If the low bound of the target
5941 -- type is negative, then we know that we will fit fine.
5943 -- If the high bound of the target type is negative, then we
5944 -- know we have a constraint error, since we can't possibly
5945 -- have a negative source.
5947 -- With these two checks out of the way, we can do the check
5948 -- using the source type safely
5950 -- This is definitely the most annoying case!
5952 -- [constraint_error
5953 -- when (Target_Type'First >= 0
5955 -- N < Source_Base_Type (Target_Type'First))
5956 -- or else Target_Type'Last < 0
5957 -- or else N > Source_Base_Type (Target_Type'Last)];
5959 -- We turn off all checks since we know that the conversions
5960 -- will work fine, given the guards for negative values.
5963 Make_Raise_Constraint_Error
(Loc
,
5969 Left_Opnd
=> Make_Op_Ge
(Loc
,
5971 Make_Attribute_Reference
(Loc
,
5973 New_Occurrence_Of
(Target_Type
, Loc
),
5974 Attribute_Name
=> Name_First
),
5975 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
5979 Left_Opnd
=> Duplicate_Subexpr
(N
),
5981 Convert_To
(Source_Base_Type
,
5982 Make_Attribute_Reference
(Loc
,
5984 New_Occurrence_Of
(Target_Type
, Loc
),
5985 Attribute_Name
=> Name_First
)))),
5990 Make_Attribute_Reference
(Loc
,
5991 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
5992 Attribute_Name
=> Name_Last
),
5993 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
5997 Left_Opnd
=> Duplicate_Subexpr
(N
),
5999 Convert_To
(Source_Base_Type
,
6000 Make_Attribute_Reference
(Loc
,
6001 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
6002 Attribute_Name
=> Name_Last
)))),
6005 Suppress
=> All_Checks
);
6007 -- Only remaining possibility is that the source is signed and
6008 -- the target is unsigned.
6011 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
6012 and then Is_Unsigned_Type
(Target_Base_Type
));
6014 -- If the source is signed and the target is unsigned, then we
6015 -- know that the target is not shorter than the source (otherwise
6016 -- the target base type would be in the source base type range).
6018 -- In other words, the unsigned type is either the same size as
6019 -- the target, or it is larger. It cannot be smaller.
6021 -- Clearly we have an error if the source value is negative since
6022 -- no unsigned type can have negative values. If the source type
6023 -- is non-negative, then the check can be done using the target
6026 -- Tnn : constant Target_Base_Type (N) := Target_Type;
6028 -- [constraint_error
6029 -- when N < 0 or else Tnn not in Target_Type];
6031 -- We turn off all checks for the conversion of N to the target
6032 -- base type, since we generate the explicit check to ensure that
6033 -- the value is non-negative
6036 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
6039 Insert_Actions
(N
, New_List
(
6040 Make_Object_Declaration
(Loc
,
6041 Defining_Identifier
=> Tnn
,
6042 Object_Definition
=>
6043 New_Occurrence_Of
(Target_Base_Type
, Loc
),
6044 Constant_Present
=> True,
6046 Make_Unchecked_Type_Conversion
(Loc
,
6048 New_Occurrence_Of
(Target_Base_Type
, Loc
),
6049 Expression
=> Duplicate_Subexpr
(N
))),
6051 Make_Raise_Constraint_Error
(Loc
,
6056 Left_Opnd
=> Duplicate_Subexpr
(N
),
6057 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
6061 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
6063 New_Occurrence_Of
(Target_Type
, Loc
))),
6066 Suppress
=> All_Checks
);
6068 -- Set the Etype explicitly, because Insert_Actions may have
6069 -- placed the declaration in the freeze list for an enclosing
6070 -- construct, and thus it is not analyzed yet.
6072 Set_Etype
(Tnn
, Target_Base_Type
);
6073 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
6077 end Generate_Range_Check
;
6083 function Get_Check_Id
(N
: Name_Id
) return Check_Id
is
6085 -- For standard check name, we can do a direct computation
6087 if N
in First_Check_Name
.. Last_Check_Name
then
6088 return Check_Id
(N
- (First_Check_Name
- 1));
6090 -- For non-standard names added by pragma Check_Name, search table
6093 for J
in All_Checks
+ 1 .. Check_Names
.Last
loop
6094 if Check_Names
.Table
(J
) = N
then
6100 -- No matching name found
6105 ---------------------
6106 -- Get_Discriminal --
6107 ---------------------
6109 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
6110 Loc
: constant Source_Ptr
:= Sloc
(E
);
6115 -- The bound can be a bona fide parameter of a protected operation,
6116 -- rather than a prival encoded as an in-parameter.
6118 if No
(Discriminal_Link
(Entity
(Bound
))) then
6122 -- Climb the scope stack looking for an enclosing protected type. If
6123 -- we run out of scopes, return the bound itself.
6126 while Present
(Sc
) loop
6127 if Sc
= Standard_Standard
then
6130 elsif Ekind
(Sc
) = E_Protected_Type
then
6137 D
:= First_Discriminant
(Sc
);
6138 while Present
(D
) loop
6139 if Chars
(D
) = Chars
(Bound
) then
6140 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
6143 Next_Discriminant
(D
);
6147 end Get_Discriminal
;
6149 ----------------------
6150 -- Get_Range_Checks --
6151 ----------------------
6153 function Get_Range_Checks
6155 Target_Typ
: Entity_Id
;
6156 Source_Typ
: Entity_Id
:= Empty
;
6157 Warn_Node
: Node_Id
:= Empty
) return Check_Result
6160 return Selected_Range_Checks
6161 (Ck_Node
, Target_Typ
, Source_Typ
, Warn_Node
);
6162 end Get_Range_Checks
;
6168 function Guard_Access
6171 Ck_Node
: Node_Id
) return Node_Id
6174 if Nkind
(Cond
) = N_Or_Else
then
6175 Set_Paren_Count
(Cond
, 1);
6178 if Nkind
(Ck_Node
) = N_Allocator
then
6185 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
6186 Right_Opnd
=> Make_Null
(Loc
)),
6187 Right_Opnd
=> Cond
);
6191 -----------------------------
6192 -- Index_Checks_Suppressed --
6193 -----------------------------
6195 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6197 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6198 return Is_Check_Suppressed
(E
, Index_Check
);
6200 return Scope_Suppress
.Suppress
(Index_Check
);
6202 end Index_Checks_Suppressed
;
6208 procedure Initialize
is
6210 for J
in Determine_Range_Cache_N
'Range loop
6211 Determine_Range_Cache_N
(J
) := Empty
;
6216 for J
in Int
range 1 .. All_Checks
loop
6217 Check_Names
.Append
(Name_Id
(Int
(First_Check_Name
) + J
- 1));
6221 -------------------------
6222 -- Insert_Range_Checks --
6223 -------------------------
6225 procedure Insert_Range_Checks
6226 (Checks
: Check_Result
;
6228 Suppress_Typ
: Entity_Id
;
6229 Static_Sloc
: Source_Ptr
:= No_Location
;
6230 Flag_Node
: Node_Id
:= Empty
;
6231 Do_Before
: Boolean := False)
6233 Internal_Flag_Node
: Node_Id
:= Flag_Node
;
6234 Internal_Static_Sloc
: Source_Ptr
:= Static_Sloc
;
6236 Check_Node
: Node_Id
;
6237 Checks_On
: constant Boolean :=
6238 (not Index_Checks_Suppressed
(Suppress_Typ
))
6239 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
6242 -- For now we just return if Checks_On is false, however this should be
6243 -- enhanced to check for an always True value in the condition and to
6244 -- generate a compilation warning???
6246 if not Full_Expander_Active
or else not Checks_On
then
6250 if Static_Sloc
= No_Location
then
6251 Internal_Static_Sloc
:= Sloc
(Node
);
6254 if No
(Flag_Node
) then
6255 Internal_Flag_Node
:= Node
;
6258 for J
in 1 .. 2 loop
6259 exit when No
(Checks
(J
));
6261 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
6262 and then Present
(Condition
(Checks
(J
)))
6264 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
6265 Check_Node
:= Checks
(J
);
6266 Mark_Rewrite_Insertion
(Check_Node
);
6269 Insert_Before_And_Analyze
(Node
, Check_Node
);
6271 Insert_After_And_Analyze
(Node
, Check_Node
);
6274 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
6279 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
6280 Reason
=> CE_Range_Check_Failed
);
6281 Mark_Rewrite_Insertion
(Check_Node
);
6284 Insert_Before_And_Analyze
(Node
, Check_Node
);
6286 Insert_After_And_Analyze
(Node
, Check_Node
);
6290 end Insert_Range_Checks
;
6292 ------------------------
6293 -- Insert_Valid_Check --
6294 ------------------------
6296 procedure Insert_Valid_Check
(Expr
: Node_Id
) is
6297 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6298 Typ
: constant Entity_Id
:= Etype
(Expr
);
6302 -- Do not insert if checks off, or if not checking validity or
6303 -- if expression is known to be valid
6305 if not Validity_Checks_On
6306 or else Range_Or_Validity_Checks_Suppressed
(Expr
)
6307 or else Expr_Known_Valid
(Expr
)
6312 -- Do not insert checks within a predicate function. This will arise
6313 -- if the current unit and the predicate function are being compiled
6314 -- with validity checks enabled.
6316 if Present
(Predicate_Function
(Typ
))
6317 and then Current_Scope
= Predicate_Function
(Typ
)
6322 -- If we have a checked conversion, then validity check applies to
6323 -- the expression inside the conversion, not the result, since if
6324 -- the expression inside is valid, then so is the conversion result.
6327 while Nkind
(Exp
) = N_Type_Conversion
loop
6328 Exp
:= Expression
(Exp
);
6331 -- We are about to insert the validity check for Exp. We save and
6332 -- reset the Do_Range_Check flag over this validity check, and then
6333 -- put it back for the final original reference (Exp may be rewritten).
6336 DRC
: constant Boolean := Do_Range_Check
(Exp
);
6341 Set_Do_Range_Check
(Exp
, False);
6343 -- Force evaluation to avoid multiple reads for atomic/volatile
6345 if Is_Entity_Name
(Exp
)
6346 and then Is_Volatile
(Entity
(Exp
))
6348 Force_Evaluation
(Exp
, Name_Req
=> True);
6351 -- Build the prefix for the 'Valid call
6353 PV
:= Duplicate_Subexpr_No_Checks
(Exp
, Name_Req
=> True);
6355 -- A rather specialized kludge. If PV is an analyzed expression
6356 -- which is an indexed component of a packed array that has not
6357 -- been properly expanded, turn off its Analyzed flag to make sure
6358 -- it gets properly reexpanded.
6360 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
6361 -- an analyze with the old parent pointer. This may point e.g. to
6362 -- a subprogram call, which deactivates this expansion.
6365 and then Nkind
(PV
) = N_Indexed_Component
6366 and then Present
(Packed_Array_Type
(Etype
(Prefix
(PV
))))
6368 Set_Analyzed
(PV
, False);
6371 -- Build the raise CE node to check for validity
6374 Make_Raise_Constraint_Error
(Loc
,
6378 Make_Attribute_Reference
(Loc
,
6380 Attribute_Name
=> Name_Valid
)),
6381 Reason
=> CE_Invalid_Data
);
6383 -- Insert the validity check. Note that we do this with validity
6384 -- checks turned off, to avoid recursion, we do not want validity
6385 -- checks on the validity checking code itself!
6387 Insert_Action
(Expr
, CE
, Suppress
=> Validity_Check
);
6389 -- If the expression is a reference to an element of a bit-packed
6390 -- array, then it is rewritten as a renaming declaration. If the
6391 -- expression is an actual in a call, it has not been expanded,
6392 -- waiting for the proper point at which to do it. The same happens
6393 -- with renamings, so that we have to force the expansion now. This
6394 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
6397 if Is_Entity_Name
(Exp
)
6398 and then Nkind
(Parent
(Entity
(Exp
))) =
6399 N_Object_Renaming_Declaration
6402 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
6404 if Nkind
(Old_Exp
) = N_Indexed_Component
6405 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
6407 Expand_Packed_Element_Reference
(Old_Exp
);
6412 -- Put back the Do_Range_Check flag on the resulting (possibly
6413 -- rewritten) expression.
6415 -- Note: it might be thought that a validity check is not required
6416 -- when a range check is present, but that's not the case, because
6417 -- the back end is allowed to assume for the range check that the
6418 -- operand is within its declared range (an assumption that validity
6419 -- checking is all about NOT assuming!)
6421 -- Note: no need to worry about Possible_Local_Raise here, it will
6422 -- already have been called if original node has Do_Range_Check set.
6424 Set_Do_Range_Check
(Exp
, DRC
);
6426 end Insert_Valid_Check
;
6428 -------------------------------------
6429 -- Is_Signed_Integer_Arithmetic_Op --
6430 -------------------------------------
6432 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean is
6435 when N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
6436 N_Op_Minus | N_Op_Mod | N_Op_Multiply | N_Op_Plus |
6437 N_Op_Rem | N_Op_Subtract
=>
6438 return Is_Signed_Integer_Type
(Etype
(N
));
6440 when N_If_Expression | N_Case_Expression
=>
6441 return Is_Signed_Integer_Type
(Etype
(N
));
6446 end Is_Signed_Integer_Arithmetic_Op
;
6448 ----------------------------------
6449 -- Install_Null_Excluding_Check --
6450 ----------------------------------
6452 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
6453 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
6454 Typ
: constant Entity_Id
:= Etype
(N
);
6456 function Safe_To_Capture_In_Parameter_Value
return Boolean;
6457 -- Determines if it is safe to capture Known_Non_Null status for an
6458 -- the entity referenced by node N. The caller ensures that N is indeed
6459 -- an entity name. It is safe to capture the non-null status for an IN
6460 -- parameter when the reference occurs within a declaration that is sure
6461 -- to be executed as part of the declarative region.
6463 procedure Mark_Non_Null
;
6464 -- After installation of check, if the node in question is an entity
6465 -- name, then mark this entity as non-null if possible.
6467 function Safe_To_Capture_In_Parameter_Value
return Boolean is
6468 E
: constant Entity_Id
:= Entity
(N
);
6469 S
: constant Entity_Id
:= Current_Scope
;
6473 if Ekind
(E
) /= E_In_Parameter
then
6477 -- Two initial context checks. We must be inside a subprogram body
6478 -- with declarations and reference must not appear in nested scopes.
6480 if (Ekind
(S
) /= E_Function
and then Ekind
(S
) /= E_Procedure
)
6481 or else Scope
(E
) /= S
6486 S_Par
:= Parent
(Parent
(S
));
6488 if Nkind
(S_Par
) /= N_Subprogram_Body
6489 or else No
(Declarations
(S_Par
))
6499 -- Retrieve the declaration node of N (if any). Note that N
6500 -- may be a part of a complex initialization expression.
6504 while Present
(P
) loop
6506 -- If we have a short circuit form, and we are within the right
6507 -- hand expression, we return false, since the right hand side
6508 -- is not guaranteed to be elaborated.
6510 if Nkind
(P
) in N_Short_Circuit
6511 and then N
= Right_Opnd
(P
)
6516 -- Similarly, if we are in an if expression and not part of the
6517 -- condition, then we return False, since neither the THEN or
6518 -- ELSE dependent expressions will always be elaborated.
6520 if Nkind
(P
) = N_If_Expression
6521 and then N
/= First
(Expressions
(P
))
6526 -- If we are in a case expression, and not part of the
6527 -- expression, then we return False, since a particular
6528 -- dependent expression may not always be elaborated
6530 if Nkind
(P
) = N_Case_Expression
6531 and then N
/= Expression
(P
)
6536 -- While traversing the parent chain, we find that N
6537 -- belongs to a statement, thus it may never appear in
6538 -- a declarative region.
6540 if Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
6541 or else Nkind
(P
) = N_Procedure_Call_Statement
6546 -- If we are at a declaration, record it and exit
6548 if Nkind
(P
) in N_Declaration
6549 and then Nkind
(P
) not in N_Subprogram_Specification
6562 return List_Containing
(N_Decl
) = Declarations
(S_Par
);
6564 end Safe_To_Capture_In_Parameter_Value
;
6570 procedure Mark_Non_Null
is
6572 -- Only case of interest is if node N is an entity name
6574 if Is_Entity_Name
(N
) then
6576 -- For sure, we want to clear an indication that this is known to
6577 -- be null, since if we get past this check, it definitely is not!
6579 Set_Is_Known_Null
(Entity
(N
), False);
6581 -- We can mark the entity as known to be non-null if either it is
6582 -- safe to capture the value, or in the case of an IN parameter,
6583 -- which is a constant, if the check we just installed is in the
6584 -- declarative region of the subprogram body. In this latter case,
6585 -- a check is decisive for the rest of the body if the expression
6586 -- is sure to be elaborated, since we know we have to elaborate
6587 -- all declarations before executing the body.
6589 -- Couldn't this always be part of Safe_To_Capture_Value ???
6591 if Safe_To_Capture_Value
(N
, Entity
(N
))
6592 or else Safe_To_Capture_In_Parameter_Value
6594 Set_Is_Known_Non_Null
(Entity
(N
));
6599 -- Start of processing for Install_Null_Excluding_Check
6602 pragma Assert
(Is_Access_Type
(Typ
));
6604 -- No check inside a generic (why not???)
6606 if Inside_A_Generic
then
6610 -- No check needed if known to be non-null
6612 if Known_Non_Null
(N
) then
6616 -- If known to be null, here is where we generate a compile time check
6618 if Known_Null
(N
) then
6620 -- Avoid generating warning message inside init procs
6622 if not Inside_Init_Proc
then
6623 Apply_Compile_Time_Constraint_Error
6625 "null value not allowed here??",
6626 CE_Access_Check_Failed
);
6629 Make_Raise_Constraint_Error
(Loc
,
6630 Reason
=> CE_Access_Check_Failed
));
6637 -- If entity is never assigned, for sure a warning is appropriate
6639 if Is_Entity_Name
(N
) then
6640 Check_Unset_Reference
(N
);
6643 -- No check needed if checks are suppressed on the range. Note that we
6644 -- don't set Is_Known_Non_Null in this case (we could legitimately do
6645 -- so, since the program is erroneous, but we don't like to casually
6646 -- propagate such conclusions from erroneosity).
6648 if Access_Checks_Suppressed
(Typ
) then
6652 -- No check needed for access to concurrent record types generated by
6653 -- the expander. This is not just an optimization (though it does indeed
6654 -- remove junk checks). It also avoids generation of junk warnings.
6656 if Nkind
(N
) in N_Has_Chars
6657 and then Chars
(N
) = Name_uObject
6658 and then Is_Concurrent_Record_Type
6659 (Directly_Designated_Type
(Etype
(N
)))
6664 -- No check needed in interface thunks since the runtime check is
6665 -- already performed at the caller side.
6667 if Is_Thunk
(Current_Scope
) then
6671 -- No check needed for the Get_Current_Excep.all.all idiom generated by
6672 -- the expander within exception handlers, since we know that the value
6673 -- can never be null.
6675 -- Is this really the right way to do this? Normally we generate such
6676 -- code in the expander with checks off, and that's how we suppress this
6677 -- kind of junk check ???
6679 if Nkind
(N
) = N_Function_Call
6680 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
6681 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
6682 and then Is_RTE
(Entity
(Prefix
(Name
(N
))), RE_Get_Current_Excep
)
6687 -- Otherwise install access check
6690 Make_Raise_Constraint_Error
(Loc
,
6693 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
6694 Right_Opnd
=> Make_Null
(Loc
)),
6695 Reason
=> CE_Access_Check_Failed
));
6698 end Install_Null_Excluding_Check
;
6700 --------------------------
6701 -- Install_Static_Check --
6702 --------------------------
6704 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
6705 Stat
: constant Boolean := Is_Static_Expression
(R_Cno
);
6706 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
6710 Make_Raise_Constraint_Error
(Loc
,
6711 Reason
=> CE_Range_Check_Failed
));
6712 Set_Analyzed
(R_Cno
);
6713 Set_Etype
(R_Cno
, Typ
);
6714 Set_Raises_Constraint_Error
(R_Cno
);
6715 Set_Is_Static_Expression
(R_Cno
, Stat
);
6717 -- Now deal with possible local raise handling
6719 Possible_Local_Raise
(R_Cno
, Standard_Constraint_Error
);
6720 end Install_Static_Check
;
6722 -------------------------
6723 -- Is_Check_Suppressed --
6724 -------------------------
6726 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
6727 Ptr
: Suppress_Stack_Entry_Ptr
;
6730 -- First search the local entity suppress stack. We search this from the
6731 -- top of the stack down so that we get the innermost entry that applies
6732 -- to this case if there are nested entries.
6734 Ptr
:= Local_Suppress_Stack_Top
;
6735 while Ptr
/= null loop
6736 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
6737 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
6739 return Ptr
.Suppress
;
6745 -- Now search the global entity suppress table for a matching entry.
6746 -- We also search this from the top down so that if there are multiple
6747 -- pragmas for the same entity, the last one applies (not clear what
6748 -- or whether the RM specifies this handling, but it seems reasonable).
6750 Ptr
:= Global_Suppress_Stack_Top
;
6751 while Ptr
/= null loop
6752 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
6753 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
6755 return Ptr
.Suppress
;
6761 -- If we did not find a matching entry, then use the normal scope
6762 -- suppress value after all (actually this will be the global setting
6763 -- since it clearly was not overridden at any point). For a predefined
6764 -- check, we test the specific flag. For a user defined check, we check
6765 -- the All_Checks flag. The Overflow flag requires special handling to
6766 -- deal with the General vs Assertion case
6768 if C
= Overflow_Check
then
6769 return Overflow_Checks_Suppressed
(Empty
);
6770 elsif C
in Predefined_Check_Id
then
6771 return Scope_Suppress
.Suppress
(C
);
6773 return Scope_Suppress
.Suppress
(All_Checks
);
6775 end Is_Check_Suppressed
;
6777 ---------------------
6778 -- Kill_All_Checks --
6779 ---------------------
6781 procedure Kill_All_Checks
is
6783 if Debug_Flag_CC
then
6784 w
("Kill_All_Checks");
6787 -- We reset the number of saved checks to zero, and also modify all
6788 -- stack entries for statement ranges to indicate that the number of
6789 -- checks at each level is now zero.
6791 Num_Saved_Checks
:= 0;
6793 -- Note: the Int'Min here avoids any possibility of J being out of
6794 -- range when called from e.g. Conditional_Statements_Begin.
6796 for J
in 1 .. Int
'Min (Saved_Checks_TOS
, Saved_Checks_Stack
'Last) loop
6797 Saved_Checks_Stack
(J
) := 0;
6799 end Kill_All_Checks
;
6805 procedure Kill_Checks
(V
: Entity_Id
) is
6807 if Debug_Flag_CC
then
6808 w
("Kill_Checks for entity", Int
(V
));
6811 for J
in 1 .. Num_Saved_Checks
loop
6812 if Saved_Checks
(J
).Entity
= V
then
6813 if Debug_Flag_CC
then
6814 w
(" Checks killed for saved check ", J
);
6817 Saved_Checks
(J
).Killed
:= True;
6822 ------------------------------
6823 -- Length_Checks_Suppressed --
6824 ------------------------------
6826 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6828 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6829 return Is_Check_Suppressed
(E
, Length_Check
);
6831 return Scope_Suppress
.Suppress
(Length_Check
);
6833 end Length_Checks_Suppressed
;
6835 -----------------------
6836 -- Make_Bignum_Block --
6837 -----------------------
6839 function Make_Bignum_Block
(Loc
: Source_Ptr
) return Node_Id
is
6840 M
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uM
);
6844 Make_Block_Statement
(Loc
,
6845 Declarations
=> New_List
(
6846 Make_Object_Declaration
(Loc
,
6847 Defining_Identifier
=> M
,
6848 Object_Definition
=>
6849 New_Occurrence_Of
(RTE
(RE_Mark_Id
), Loc
),
6851 Make_Function_Call
(Loc
,
6852 Name
=> New_Reference_To
(RTE
(RE_SS_Mark
), Loc
)))),
6854 Handled_Statement_Sequence
=>
6855 Make_Handled_Sequence_Of_Statements
(Loc
,
6856 Statements
=> New_List
(
6857 Make_Procedure_Call_Statement
(Loc
,
6858 Name
=> New_Occurrence_Of
(RTE
(RE_SS_Release
), Loc
),
6859 Parameter_Associations
=> New_List
(
6860 New_Reference_To
(M
, Loc
))))));
6861 end Make_Bignum_Block
;
6863 ----------------------------------
6864 -- Minimize_Eliminate_Overflows --
6865 ----------------------------------
6867 -- This is a recursive routine that is called at the top of an expression
6868 -- tree to properly process overflow checking for a whole subtree by making
6869 -- recursive calls to process operands. This processing may involve the use
6870 -- of bignum or long long integer arithmetic, which will change the types
6871 -- of operands and results. That's why we can't do this bottom up (since
6872 -- it would interfere with semantic analysis).
6874 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
6875 -- the operator expansion routines, as well as the expansion routines for
6876 -- if/case expression, do nothing (for the moment) except call the routine
6877 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
6878 -- routine does nothing for non top-level nodes, so at the point where the
6879 -- call is made for the top level node, the entire expression subtree has
6880 -- not been expanded, or processed for overflow. All that has to happen as
6881 -- a result of the top level call to this routine.
6883 -- As noted above, the overflow processing works by making recursive calls
6884 -- for the operands, and figuring out what to do, based on the processing
6885 -- of these operands (e.g. if a bignum operand appears, the parent op has
6886 -- to be done in bignum mode), and the determined ranges of the operands.
6888 -- After possible rewriting of a constituent subexpression node, a call is
6889 -- made to either reexpand the node (if nothing has changed) or reanalyze
6890 -- the node (if it has been modified by the overflow check processing). The
6891 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
6892 -- a recursive call into the whole overflow apparatus, an important rule
6893 -- for this call is that the overflow handling mode must be temporarily set
6896 procedure Minimize_Eliminate_Overflows
6900 Top_Level
: Boolean)
6902 Rtyp
: constant Entity_Id
:= Etype
(N
);
6903 pragma Assert
(Is_Signed_Integer_Type
(Rtyp
));
6904 -- Result type, must be a signed integer type
6906 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
6907 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
6909 Loc
: constant Source_Ptr
:= Sloc
(N
);
6912 -- Ranges of values for right operand (operator case)
6915 -- Ranges of values for left operand (operator case)
6917 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
6918 -- Operands and results are of this type when we convert
6920 LLLo
: constant Uint
:= Intval
(Type_Low_Bound
(LLIB
));
6921 LLHi
: constant Uint
:= Intval
(Type_High_Bound
(LLIB
));
6922 -- Bounds of Long_Long_Integer
6924 Binary
: constant Boolean := Nkind
(N
) in N_Binary_Op
;
6925 -- Indicates binary operator case
6928 -- Used in call to Determine_Range
6930 Bignum_Operands
: Boolean;
6931 -- Set True if one or more operands is already of type Bignum, meaning
6932 -- that for sure (regardless of Top_Level setting) we are committed to
6933 -- doing the operation in Bignum mode (or in the case of a case or if
6934 -- expression, converting all the dependent expressions to Bignum).
6936 Long_Long_Integer_Operands
: Boolean;
6937 -- Set True if one or more operands is already of type Long_Long_Integer
6938 -- which means that if the result is known to be in the result type
6939 -- range, then we must convert such operands back to the result type.
6941 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False);
6942 -- This is called when we have modified the node and we therefore need
6943 -- to reanalyze it. It is important that we reset the mode to STRICT for
6944 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
6945 -- we would reenter this routine recursively which would not be good!
6946 -- The argument Suppress is set True if we also want to suppress
6947 -- overflow checking for the reexpansion (this is set when we know
6948 -- overflow is not possible). Typ is the type for the reanalysis.
6950 procedure Reexpand
(Suppress
: Boolean := False);
6951 -- This is like Reanalyze, but does not do the Analyze step, it only
6952 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
6953 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
6954 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
6955 -- Note that skipping reanalysis is not just an optimization, testing
6956 -- has showed up several complex cases in which reanalyzing an already
6957 -- analyzed node causes incorrect behavior.
6959 function In_Result_Range
return Boolean;
6960 -- Returns True iff Lo .. Hi are within range of the result type
6962 procedure Max
(A
: in out Uint
; B
: Uint
);
6963 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
6965 procedure Min
(A
: in out Uint
; B
: Uint
);
6966 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
6968 ---------------------
6969 -- In_Result_Range --
6970 ---------------------
6972 function In_Result_Range
return Boolean is
6974 if Lo
= No_Uint
or else Hi
= No_Uint
then
6977 elsif Is_Static_Subtype
(Etype
(N
)) then
6978 return Lo
>= Expr_Value
(Type_Low_Bound
(Rtyp
))
6980 Hi
<= Expr_Value
(Type_High_Bound
(Rtyp
));
6983 return Lo
>= Expr_Value
(Type_Low_Bound
(Base_Type
(Rtyp
)))
6985 Hi
<= Expr_Value
(Type_High_Bound
(Base_Type
(Rtyp
)));
6987 end In_Result_Range
;
6993 procedure Max
(A
: in out Uint
; B
: Uint
) is
6995 if A
= No_Uint
or else B
> A
then
7004 procedure Min
(A
: in out Uint
; B
: Uint
) is
7006 if A
= No_Uint
or else B
< A
then
7015 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False) is
7016 Svg
: constant Overflow_Mode_Type
:=
7017 Scope_Suppress
.Overflow_Mode_General
;
7018 Sva
: constant Overflow_Mode_Type
:=
7019 Scope_Suppress
.Overflow_Mode_Assertions
;
7020 Svo
: constant Boolean :=
7021 Scope_Suppress
.Suppress
(Overflow_Check
);
7024 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7025 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7028 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
7031 Analyze_And_Resolve
(N
, Typ
);
7033 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
7034 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
7035 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
7042 procedure Reexpand
(Suppress
: Boolean := False) is
7043 Svg
: constant Overflow_Mode_Type
:=
7044 Scope_Suppress
.Overflow_Mode_General
;
7045 Sva
: constant Overflow_Mode_Type
:=
7046 Scope_Suppress
.Overflow_Mode_Assertions
;
7047 Svo
: constant Boolean :=
7048 Scope_Suppress
.Suppress
(Overflow_Check
);
7051 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7052 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7053 Set_Analyzed
(N
, False);
7056 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
7061 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
7062 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
7063 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
7066 -- Start of processing for Minimize_Eliminate_Overflows
7069 -- Case where we do not have a signed integer arithmetic operation
7071 if not Is_Signed_Integer_Arithmetic_Op
(N
) then
7073 -- Use the normal Determine_Range routine to get the range. We
7074 -- don't require operands to be valid, invalid values may result in
7075 -- rubbish results where the result has not been properly checked for
7076 -- overflow, that's fine!
7078 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> False);
7080 -- If Determine_Range did not work (can this in fact happen? Not
7081 -- clear but might as well protect), use type bounds.
7084 Lo
:= Intval
(Type_Low_Bound
(Base_Type
(Etype
(N
))));
7085 Hi
:= Intval
(Type_High_Bound
(Base_Type
(Etype
(N
))));
7088 -- If we don't have a binary operator, all we have to do is to set
7089 -- the Hi/Lo range, so we are done
7093 -- Processing for if expression
7095 elsif Nkind
(N
) = N_If_Expression
then
7097 Then_DE
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
7098 Else_DE
: constant Node_Id
:= Next
(Then_DE
);
7101 Bignum_Operands
:= False;
7103 Minimize_Eliminate_Overflows
7104 (Then_DE
, Lo
, Hi
, Top_Level
=> False);
7106 if Lo
= No_Uint
then
7107 Bignum_Operands
:= True;
7110 Minimize_Eliminate_Overflows
7111 (Else_DE
, Rlo
, Rhi
, Top_Level
=> False);
7113 if Rlo
= No_Uint
then
7114 Bignum_Operands
:= True;
7116 Long_Long_Integer_Operands
:=
7117 Etype
(Then_DE
) = LLIB
or else Etype
(Else_DE
) = LLIB
;
7123 -- If at least one of our operands is now Bignum, we must rebuild
7124 -- the if expression to use Bignum operands. We will analyze the
7125 -- rebuilt if expression with overflow checks off, since once we
7126 -- are in bignum mode, we are all done with overflow checks!
7128 if Bignum_Operands
then
7130 Make_If_Expression
(Loc
,
7131 Expressions
=> New_List
(
7132 Remove_Head
(Expressions
(N
)),
7133 Convert_To_Bignum
(Then_DE
),
7134 Convert_To_Bignum
(Else_DE
)),
7135 Is_Elsif
=> Is_Elsif
(N
)));
7137 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
7139 -- If we have no Long_Long_Integer operands, then we are in result
7140 -- range, since it means that none of our operands felt the need
7141 -- to worry about overflow (otherwise it would have already been
7142 -- converted to long long integer or bignum). We reexpand to
7143 -- complete the expansion of the if expression (but we do not
7144 -- need to reanalyze).
7146 elsif not Long_Long_Integer_Operands
then
7147 Set_Do_Overflow_Check
(N
, False);
7150 -- Otherwise convert us to long long integer mode. Note that we
7151 -- don't need any further overflow checking at this level.
7154 Convert_To_And_Rewrite
(LLIB
, Then_DE
);
7155 Convert_To_And_Rewrite
(LLIB
, Else_DE
);
7156 Set_Etype
(N
, LLIB
);
7158 -- Now reanalyze with overflow checks off
7160 Set_Do_Overflow_Check
(N
, False);
7161 Reanalyze
(LLIB
, Suppress
=> True);
7167 -- Here for case expression
7169 elsif Nkind
(N
) = N_Case_Expression
then
7170 Bignum_Operands
:= False;
7171 Long_Long_Integer_Operands
:= False;
7177 -- Loop through expressions applying recursive call
7179 Alt
:= First
(Alternatives
(N
));
7180 while Present
(Alt
) loop
7182 Aexp
: constant Node_Id
:= Expression
(Alt
);
7185 Minimize_Eliminate_Overflows
7186 (Aexp
, Lo
, Hi
, Top_Level
=> False);
7188 if Lo
= No_Uint
then
7189 Bignum_Operands
:= True;
7190 elsif Etype
(Aexp
) = LLIB
then
7191 Long_Long_Integer_Operands
:= True;
7198 -- If we have no bignum or long long integer operands, it means
7199 -- that none of our dependent expressions could raise overflow.
7200 -- In this case, we simply return with no changes except for
7201 -- resetting the overflow flag, since we are done with overflow
7202 -- checks for this node. We will reexpand to get the needed
7203 -- expansion for the case expression, but we do not need to
7204 -- reanalyze, since nothing has changed.
7206 if not (Bignum_Operands
or Long_Long_Integer_Operands
) then
7207 Set_Do_Overflow_Check
(N
, False);
7208 Reexpand
(Suppress
=> True);
7210 -- Otherwise we are going to rebuild the case expression using
7211 -- either bignum or long long integer operands throughout.
7220 New_Alts
:= New_List
;
7221 Alt
:= First
(Alternatives
(N
));
7222 while Present
(Alt
) loop
7223 if Bignum_Operands
then
7224 New_Exp
:= Convert_To_Bignum
(Expression
(Alt
));
7225 Rtype
:= RTE
(RE_Bignum
);
7227 New_Exp
:= Convert_To
(LLIB
, Expression
(Alt
));
7231 Append_To
(New_Alts
,
7232 Make_Case_Expression_Alternative
(Sloc
(Alt
),
7234 Discrete_Choices
=> Discrete_Choices
(Alt
),
7235 Expression
=> New_Exp
));
7241 Make_Case_Expression
(Loc
,
7242 Expression
=> Expression
(N
),
7243 Alternatives
=> New_Alts
));
7245 Reanalyze
(Rtype
, Suppress
=> True);
7253 -- If we have an arithmetic operator we make recursive calls on the
7254 -- operands to get the ranges (and to properly process the subtree
7255 -- that lies below us!)
7257 Minimize_Eliminate_Overflows
7258 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
7261 Minimize_Eliminate_Overflows
7262 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
7265 -- Record if we have Long_Long_Integer operands
7267 Long_Long_Integer_Operands
:=
7268 Etype
(Right_Opnd
(N
)) = LLIB
7269 or else (Binary
and then Etype
(Left_Opnd
(N
)) = LLIB
);
7271 -- If either operand is a bignum, then result will be a bignum and we
7272 -- don't need to do any range analysis. As previously discussed we could
7273 -- do range analysis in such cases, but it could mean working with giant
7274 -- numbers at compile time for very little gain (the number of cases
7275 -- in which we could slip back from bignum mode is small).
7277 if Rlo
= No_Uint
or else (Binary
and then Llo
= No_Uint
) then
7280 Bignum_Operands
:= True;
7282 -- Otherwise compute result range
7285 Bignum_Operands
:= False;
7293 Hi
:= UI_Max
(abs Rlo
, abs Rhi
);
7305 -- If the right operand can only be zero, set 0..0
7307 if Rlo
= 0 and then Rhi
= 0 then
7311 -- Possible bounds of division must come from dividing end
7312 -- values of the input ranges (four possibilities), provided
7313 -- zero is not included in the possible values of the right
7316 -- Otherwise, we just consider two intervals of values for
7317 -- the right operand: the interval of negative values (up to
7318 -- -1) and the interval of positive values (starting at 1).
7319 -- Since division by 1 is the identity, and division by -1
7320 -- is negation, we get all possible bounds of division in that
7321 -- case by considering:
7322 -- - all values from the division of end values of input
7324 -- - the end values of the left operand;
7325 -- - the negation of the end values of the left operand.
7329 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
7330 -- Mark so we can release the RR and Ev values
7338 -- Discard extreme values of zero for the divisor, since
7339 -- they will simply result in an exception in any case.
7347 -- Compute possible bounds coming from dividing end
7348 -- values of the input ranges.
7355 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
7356 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
7358 -- If the right operand can be both negative or positive,
7359 -- include the end values of the left operand in the
7360 -- extreme values, as well as their negation.
7362 if Rlo
< 0 and then Rhi
> 0 then
7369 UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
)));
7371 UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
)));
7374 -- Release the RR and Ev values
7376 Release_And_Save
(Mrk
, Lo
, Hi
);
7384 -- Discard negative values for the exponent, since they will
7385 -- simply result in an exception in any case.
7393 -- Estimate number of bits in result before we go computing
7394 -- giant useless bounds. Basically the number of bits in the
7395 -- result is the number of bits in the base multiplied by the
7396 -- value of the exponent. If this is big enough that the result
7397 -- definitely won't fit in Long_Long_Integer, switch to bignum
7398 -- mode immediately, and avoid computing giant bounds.
7400 -- The comparison here is approximate, but conservative, it
7401 -- only clicks on cases that are sure to exceed the bounds.
7403 if Num_Bits
(UI_Max
(abs Llo
, abs Lhi
)) * Rhi
+ 1 > 100 then
7407 -- If right operand is zero then result is 1
7414 -- High bound comes either from exponentiation of largest
7415 -- positive value to largest exponent value, or from
7416 -- the exponentiation of most negative value to an
7430 if Rhi
mod 2 = 0 then
7433 Hi2
:= Llo
** (Rhi
- 1);
7439 Hi
:= UI_Max
(Hi1
, Hi2
);
7442 -- Result can only be negative if base can be negative
7445 if Rhi
mod 2 = 0 then
7446 Lo
:= Llo
** (Rhi
- 1);
7451 -- Otherwise low bound is minimum ** minimum
7468 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
7469 -- This is the maximum absolute value of the result
7475 -- The result depends only on the sign and magnitude of
7476 -- the right operand, it does not depend on the sign or
7477 -- magnitude of the left operand.
7490 when N_Op_Multiply
=>
7492 -- Possible bounds of multiplication must come from multiplying
7493 -- end values of the input ranges (four possibilities).
7496 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
7497 -- Mark so we can release the Ev values
7499 Ev1
: constant Uint
:= Llo
* Rlo
;
7500 Ev2
: constant Uint
:= Llo
* Rhi
;
7501 Ev3
: constant Uint
:= Lhi
* Rlo
;
7502 Ev4
: constant Uint
:= Lhi
* Rhi
;
7505 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
7506 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
7508 -- Release the Ev values
7510 Release_And_Save
(Mrk
, Lo
, Hi
);
7513 -- Plus operator (affirmation)
7523 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
7524 -- This is the maximum absolute value of the result. Note
7525 -- that the result range does not depend on the sign of the
7532 -- Case of left operand negative, which results in a range
7533 -- of -Maxabs .. 0 for those negative values. If there are
7534 -- no negative values then Lo value of result is always 0.
7540 -- Case of left operand positive
7549 when N_Op_Subtract
=>
7553 -- Nothing else should be possible
7556 raise Program_Error
;
7560 -- Here for the case where we have not rewritten anything (no bignum
7561 -- operands or long long integer operands), and we know the result.
7562 -- If we know we are in the result range, and we do not have Bignum
7563 -- operands or Long_Long_Integer operands, we can just reexpand with
7564 -- overflow checks turned off (since we know we cannot have overflow).
7565 -- As always the reexpansion is required to complete expansion of the
7566 -- operator, but we do not need to reanalyze, and we prevent recursion
7567 -- by suppressing the check.
7569 if not (Bignum_Operands
or Long_Long_Integer_Operands
)
7570 and then In_Result_Range
7572 Set_Do_Overflow_Check
(N
, False);
7573 Reexpand
(Suppress
=> True);
7576 -- Here we know that we are not in the result range, and in the general
7577 -- case we will move into either the Bignum or Long_Long_Integer domain
7578 -- to compute the result. However, there is one exception. If we are
7579 -- at the top level, and we do not have Bignum or Long_Long_Integer
7580 -- operands, we will have to immediately convert the result back to
7581 -- the result type, so there is no point in Bignum/Long_Long_Integer
7585 and then not (Bignum_Operands
or Long_Long_Integer_Operands
)
7587 -- One further refinement. If we are at the top level, but our parent
7588 -- is a type conversion, then go into bignum or long long integer node
7589 -- since the result will be converted to that type directly without
7590 -- going through the result type, and we may avoid an overflow. This
7591 -- is the case for example of Long_Long_Integer (A ** 4), where A is
7592 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
7593 -- but does not fit in Integer.
7595 and then Nkind
(Parent
(N
)) /= N_Type_Conversion
7597 -- Here keep original types, but we need to complete analysis
7599 -- One subtlety. We can't just go ahead and do an analyze operation
7600 -- here because it will cause recursion into the whole MINIMIZED/
7601 -- ELIMINATED overflow processing which is not what we want. Here
7602 -- we are at the top level, and we need a check against the result
7603 -- mode (i.e. we want to use STRICT mode). So do exactly that!
7604 -- Also, we have not modified the node, so this is a case where
7605 -- we need to reexpand, but not reanalyze.
7610 -- Cases where we do the operation in Bignum mode. This happens either
7611 -- because one of our operands is in Bignum mode already, or because
7612 -- the computed bounds are outside the bounds of Long_Long_Integer,
7613 -- which in some cases can be indicated by Hi and Lo being No_Uint.
7615 -- Note: we could do better here and in some cases switch back from
7616 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
7617 -- 0 .. 1, but the cases are rare and it is not worth the effort.
7618 -- Failing to do this switching back is only an efficiency issue.
7620 elsif Lo
= No_Uint
or else Lo
< LLLo
or else Hi
> LLHi
then
7622 -- OK, we are definitely outside the range of Long_Long_Integer. The
7623 -- question is whether to move to Bignum mode, or stay in the domain
7624 -- of Long_Long_Integer, signalling that an overflow check is needed.
7626 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
7627 -- the Bignum business. In ELIMINATED mode, we will normally move
7628 -- into Bignum mode, but there is an exception if neither of our
7629 -- operands is Bignum now, and we are at the top level (Top_Level
7630 -- set True). In this case, there is no point in moving into Bignum
7631 -- mode to prevent overflow if the caller will immediately convert
7632 -- the Bignum value back to LLI with an overflow check. It's more
7633 -- efficient to stay in LLI mode with an overflow check (if needed)
7635 if Check_Mode
= Minimized
7636 or else (Top_Level
and not Bignum_Operands
)
7638 if Do_Overflow_Check
(N
) then
7639 Enable_Overflow_Check
(N
);
7642 -- The result now has to be in Long_Long_Integer mode, so adjust
7643 -- the possible range to reflect this. Note these calls also
7644 -- change No_Uint values from the top level case to LLI bounds.
7649 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
7652 pragma Assert
(Check_Mode
= Eliminated
);
7661 Fent
:= RTE
(RE_Big_Abs
);
7664 Fent
:= RTE
(RE_Big_Add
);
7667 Fent
:= RTE
(RE_Big_Div
);
7670 Fent
:= RTE
(RE_Big_Exp
);
7673 Fent
:= RTE
(RE_Big_Neg
);
7676 Fent
:= RTE
(RE_Big_Mod
);
7678 when N_Op_Multiply
=>
7679 Fent
:= RTE
(RE_Big_Mul
);
7682 Fent
:= RTE
(RE_Big_Rem
);
7684 when N_Op_Subtract
=>
7685 Fent
:= RTE
(RE_Big_Sub
);
7687 -- Anything else is an internal error, this includes the
7688 -- N_Op_Plus case, since how can plus cause the result
7689 -- to be out of range if the operand is in range?
7692 raise Program_Error
;
7695 -- Construct argument list for Bignum call, converting our
7696 -- operands to Bignum form if they are not already there.
7701 Append_To
(Args
, Convert_To_Bignum
(Left_Opnd
(N
)));
7704 Append_To
(Args
, Convert_To_Bignum
(Right_Opnd
(N
)));
7706 -- Now rewrite the arithmetic operator with a call to the
7707 -- corresponding bignum function.
7710 Make_Function_Call
(Loc
,
7711 Name
=> New_Occurrence_Of
(Fent
, Loc
),
7712 Parameter_Associations
=> Args
));
7713 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
7715 -- Indicate result is Bignum mode
7723 -- Otherwise we are in range of Long_Long_Integer, so no overflow
7724 -- check is required, at least not yet.
7727 Set_Do_Overflow_Check
(N
, False);
7730 -- Here we are not in Bignum territory, but we may have long long
7731 -- integer operands that need special handling. First a special check:
7732 -- If an exponentiation operator exponent is of type Long_Long_Integer,
7733 -- it means we converted it to prevent overflow, but exponentiation
7734 -- requires a Natural right operand, so convert it back to Natural.
7735 -- This conversion may raise an exception which is fine.
7737 if Nkind
(N
) = N_Op_Expon
and then Etype
(Right_Opnd
(N
)) = LLIB
then
7738 Convert_To_And_Rewrite
(Standard_Natural
, Right_Opnd
(N
));
7741 -- Here we will do the operation in Long_Long_Integer. We do this even
7742 -- if we know an overflow check is required, better to do this in long
7743 -- long integer mode, since we are less likely to overflow!
7745 -- Convert right or only operand to Long_Long_Integer, except that
7746 -- we do not touch the exponentiation right operand.
7748 if Nkind
(N
) /= N_Op_Expon
then
7749 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
7752 -- Convert left operand to Long_Long_Integer for binary case
7755 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
7758 -- Reset node to unanalyzed
7760 Set_Analyzed
(N
, False);
7761 Set_Etype
(N
, Empty
);
7762 Set_Entity
(N
, Empty
);
7764 -- Now analyze this new node. This reanalysis will complete processing
7765 -- for the node. In particular we will complete the expansion of an
7766 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
7767 -- we will complete any division checks (since we have not changed the
7768 -- setting of the Do_Division_Check flag).
7770 -- We do this reanalysis in STRICT mode to avoid recursion into the
7771 -- MINIMIZED/ELIMINATED handling, since we are now done with that!
7774 SG
: constant Overflow_Mode_Type
:=
7775 Scope_Suppress
.Overflow_Mode_General
;
7776 SA
: constant Overflow_Mode_Type
:=
7777 Scope_Suppress
.Overflow_Mode_Assertions
;
7780 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7781 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7783 if not Do_Overflow_Check
(N
) then
7784 Reanalyze
(LLIB
, Suppress
=> True);
7789 Scope_Suppress
.Overflow_Mode_General
:= SG
;
7790 Scope_Suppress
.Overflow_Mode_Assertions
:= SA
;
7792 end Minimize_Eliminate_Overflows
;
7794 -------------------------
7795 -- Overflow_Check_Mode --
7796 -------------------------
7798 function Overflow_Check_Mode
return Overflow_Mode_Type
is
7800 if In_Assertion_Expr
= 0 then
7801 return Scope_Suppress
.Overflow_Mode_General
;
7803 return Scope_Suppress
.Overflow_Mode_Assertions
;
7805 end Overflow_Check_Mode
;
7807 --------------------------------
7808 -- Overflow_Checks_Suppressed --
7809 --------------------------------
7811 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7813 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7814 return Is_Check_Suppressed
(E
, Overflow_Check
);
7816 return Scope_Suppress
.Suppress
(Overflow_Check
);
7818 end Overflow_Checks_Suppressed
;
7820 ---------------------------------
7821 -- Predicate_Checks_Suppressed --
7822 ---------------------------------
7824 function Predicate_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7826 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7827 return Is_Check_Suppressed
(E
, Predicate_Check
);
7829 return Scope_Suppress
.Suppress
(Predicate_Check
);
7831 end Predicate_Checks_Suppressed
;
7833 -----------------------------
7834 -- Range_Checks_Suppressed --
7835 -----------------------------
7837 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7841 -- Note: for now we always suppress range checks on Vax float types,
7842 -- since Gigi does not know how to generate these checks.
7844 if Vax_Float
(E
) then
7846 elsif Kill_Range_Checks
(E
) then
7848 elsif Checks_May_Be_Suppressed
(E
) then
7849 return Is_Check_Suppressed
(E
, Range_Check
);
7853 return Scope_Suppress
.Suppress
(Range_Check
);
7854 end Range_Checks_Suppressed
;
7856 -----------------------------------------
7857 -- Range_Or_Validity_Checks_Suppressed --
7858 -----------------------------------------
7860 -- Note: the coding would be simpler here if we simply made appropriate
7861 -- calls to Range/Validity_Checks_Suppressed, but that would result in
7862 -- duplicated checks which we prefer to avoid.
7864 function Range_Or_Validity_Checks_Suppressed
7865 (Expr
: Node_Id
) return Boolean
7868 -- Immediate return if scope checks suppressed for either check
7870 if Scope_Suppress
.Suppress
(Range_Check
)
7872 Scope_Suppress
.Suppress
(Validity_Check
)
7877 -- If no expression, that's odd, decide that checks are suppressed,
7878 -- since we don't want anyone trying to do checks in this case, which
7879 -- is most likely the result of some other error.
7885 -- Expression is present, so perform suppress checks on type
7888 Typ
: constant Entity_Id
:= Etype
(Expr
);
7890 if Vax_Float
(Typ
) then
7892 elsif Checks_May_Be_Suppressed
(Typ
)
7893 and then (Is_Check_Suppressed
(Typ
, Range_Check
)
7895 Is_Check_Suppressed
(Typ
, Validity_Check
))
7901 -- If expression is an entity name, perform checks on this entity
7903 if Is_Entity_Name
(Expr
) then
7905 Ent
: constant Entity_Id
:= Entity
(Expr
);
7907 if Checks_May_Be_Suppressed
(Ent
) then
7908 return Is_Check_Suppressed
(Ent
, Range_Check
)
7909 or else Is_Check_Suppressed
(Ent
, Validity_Check
);
7914 -- If we fall through, no checks suppressed
7917 end Range_Or_Validity_Checks_Suppressed
;
7923 procedure Remove_Checks
(Expr
: Node_Id
) is
7924 function Process
(N
: Node_Id
) return Traverse_Result
;
7925 -- Process a single node during the traversal
7927 procedure Traverse
is new Traverse_Proc
(Process
);
7928 -- The traversal procedure itself
7934 function Process
(N
: Node_Id
) return Traverse_Result
is
7936 if Nkind
(N
) not in N_Subexpr
then
7940 Set_Do_Range_Check
(N
, False);
7944 Traverse
(Left_Opnd
(N
));
7947 when N_Attribute_Reference
=>
7948 Set_Do_Overflow_Check
(N
, False);
7950 when N_Function_Call
=>
7951 Set_Do_Tag_Check
(N
, False);
7954 Set_Do_Overflow_Check
(N
, False);
7958 Set_Do_Division_Check
(N
, False);
7961 Set_Do_Length_Check
(N
, False);
7964 Set_Do_Division_Check
(N
, False);
7967 Set_Do_Length_Check
(N
, False);
7970 Set_Do_Division_Check
(N
, False);
7973 Set_Do_Length_Check
(N
, False);
7980 Traverse
(Left_Opnd
(N
));
7983 when N_Selected_Component
=>
7984 Set_Do_Discriminant_Check
(N
, False);
7986 when N_Type_Conversion
=>
7987 Set_Do_Length_Check
(N
, False);
7988 Set_Do_Tag_Check
(N
, False);
7989 Set_Do_Overflow_Check
(N
, False);
7998 -- Start of processing for Remove_Checks
8004 ----------------------------
8005 -- Selected_Length_Checks --
8006 ----------------------------
8008 function Selected_Length_Checks
8010 Target_Typ
: Entity_Id
;
8011 Source_Typ
: Entity_Id
;
8012 Warn_Node
: Node_Id
) return Check_Result
8014 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
8017 Expr_Actual
: Node_Id
;
8019 Cond
: Node_Id
:= Empty
;
8020 Do_Access
: Boolean := False;
8021 Wnode
: Node_Id
:= Warn_Node
;
8022 Ret_Result
: Check_Result
:= (Empty
, Empty
);
8023 Num_Checks
: Natural := 0;
8025 procedure Add_Check
(N
: Node_Id
);
8026 -- Adds the action given to Ret_Result if N is non-Empty
8028 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
8029 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8030 -- Comments required ???
8032 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
8033 -- True for equal literals and for nodes that denote the same constant
8034 -- entity, even if its value is not a static constant. This includes the
8035 -- case of a discriminal reference within an init proc. Removes some
8036 -- obviously superfluous checks.
8038 function Length_E_Cond
8039 (Exptyp
: Entity_Id
;
8041 Indx
: Nat
) return Node_Id
;
8042 -- Returns expression to compute:
8043 -- Typ'Length /= Exptyp'Length
8045 function Length_N_Cond
8048 Indx
: Nat
) return Node_Id
;
8049 -- Returns expression to compute:
8050 -- Typ'Length /= Expr'Length
8056 procedure Add_Check
(N
: Node_Id
) is
8060 -- For now, ignore attempt to place more than 2 checks ???
8062 if Num_Checks
= 2 then
8066 pragma Assert
(Num_Checks
<= 1);
8067 Num_Checks
:= Num_Checks
+ 1;
8068 Ret_Result
(Num_Checks
) := N
;
8076 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
8077 SE
: constant Entity_Id
:= Scope
(E
);
8079 E1
: Entity_Id
:= E
;
8082 if Ekind
(Scope
(E
)) = E_Record_Type
8083 and then Has_Discriminants
(Scope
(E
))
8085 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
8088 Insert_Action
(Ck_Node
, N
);
8089 E1
:= Defining_Identifier
(N
);
8093 if Ekind
(E1
) = E_String_Literal_Subtype
then
8095 Make_Integer_Literal
(Loc
,
8096 Intval
=> String_Literal_Length
(E1
));
8098 elsif SE
/= Standard_Standard
8099 and then Ekind
(Scope
(SE
)) = E_Protected_Type
8100 and then Has_Discriminants
(Scope
(SE
))
8101 and then Has_Completion
(Scope
(SE
))
8102 and then not Inside_Init_Proc
8104 -- If the type whose length is needed is a private component
8105 -- constrained by a discriminant, we must expand the 'Length
8106 -- attribute into an explicit computation, using the discriminal
8107 -- of the current protected operation. This is because the actual
8108 -- type of the prival is constructed after the protected opera-
8109 -- tion has been fully expanded.
8112 Indx_Type
: Node_Id
;
8115 Do_Expand
: Boolean := False;
8118 Indx_Type
:= First_Index
(E
);
8120 for J
in 1 .. Indx
- 1 loop
8121 Next_Index
(Indx_Type
);
8124 Get_Index_Bounds
(Indx_Type
, Lo
, Hi
);
8126 if Nkind
(Lo
) = N_Identifier
8127 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
8129 Lo
:= Get_Discriminal
(E
, Lo
);
8133 if Nkind
(Hi
) = N_Identifier
8134 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
8136 Hi
:= Get_Discriminal
(E
, Hi
);
8141 if not Is_Entity_Name
(Lo
) then
8142 Lo
:= Duplicate_Subexpr_No_Checks
(Lo
);
8145 if not Is_Entity_Name
(Hi
) then
8146 Lo
:= Duplicate_Subexpr_No_Checks
(Hi
);
8152 Make_Op_Subtract
(Loc
,
8156 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
8161 Make_Attribute_Reference
(Loc
,
8162 Attribute_Name
=> Name_Length
,
8164 New_Occurrence_Of
(E1
, Loc
));
8167 Set_Expressions
(N
, New_List
(
8168 Make_Integer_Literal
(Loc
, Indx
)));
8177 Make_Attribute_Reference
(Loc
,
8178 Attribute_Name
=> Name_Length
,
8180 New_Occurrence_Of
(E1
, Loc
));
8183 Set_Expressions
(N
, New_List
(
8184 Make_Integer_Literal
(Loc
, Indx
)));
8195 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8198 Make_Attribute_Reference
(Loc
,
8199 Attribute_Name
=> Name_Length
,
8201 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8202 Expressions
=> New_List
(
8203 Make_Integer_Literal
(Loc
, Indx
)));
8210 function Length_E_Cond
8211 (Exptyp
: Entity_Id
;
8213 Indx
: Nat
) return Node_Id
8218 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8219 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
8226 function Length_N_Cond
8229 Indx
: Nat
) return Node_Id
8234 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8235 Right_Opnd
=> Get_N_Length
(Expr
, Indx
));
8242 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
8245 (Nkind
(L
) = N_Integer_Literal
8246 and then Nkind
(R
) = N_Integer_Literal
8247 and then Intval
(L
) = Intval
(R
))
8251 and then Ekind
(Entity
(L
)) = E_Constant
8252 and then ((Is_Entity_Name
(R
)
8253 and then Entity
(L
) = Entity
(R
))
8255 (Nkind
(R
) = N_Type_Conversion
8256 and then Is_Entity_Name
(Expression
(R
))
8257 and then Entity
(L
) = Entity
(Expression
(R
)))))
8261 and then Ekind
(Entity
(R
)) = E_Constant
8262 and then Nkind
(L
) = N_Type_Conversion
8263 and then Is_Entity_Name
(Expression
(L
))
8264 and then Entity
(R
) = Entity
(Expression
(L
)))
8268 and then Is_Entity_Name
(R
)
8269 and then Entity
(L
) = Entity
(R
)
8270 and then Ekind
(Entity
(L
)) = E_In_Parameter
8271 and then Inside_Init_Proc
);
8274 -- Start of processing for Selected_Length_Checks
8277 if not Full_Expander_Active
then
8281 if Target_Typ
= Any_Type
8282 or else Target_Typ
= Any_Composite
8283 or else Raises_Constraint_Error
(Ck_Node
)
8292 T_Typ
:= Target_Typ
;
8294 if No
(Source_Typ
) then
8295 S_Typ
:= Etype
(Ck_Node
);
8297 S_Typ
:= Source_Typ
;
8300 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
8304 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
8305 S_Typ
:= Designated_Type
(S_Typ
);
8306 T_Typ
:= Designated_Type
(T_Typ
);
8309 -- A simple optimization for the null case
8311 if Known_Null
(Ck_Node
) then
8316 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
8317 if Is_Constrained
(T_Typ
) then
8319 -- The checking code to be generated will freeze the corresponding
8320 -- array type. However, we must freeze the type now, so that the
8321 -- freeze node does not appear within the generated if expression,
8324 Freeze_Before
(Ck_Node
, T_Typ
);
8326 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
8327 Exptyp
:= Get_Actual_Subtype
(Ck_Node
);
8329 if Is_Access_Type
(Exptyp
) then
8330 Exptyp
:= Designated_Type
(Exptyp
);
8333 -- String_Literal case. This needs to be handled specially be-
8334 -- cause no index types are available for string literals. The
8335 -- condition is simply:
8337 -- T_Typ'Length = string-literal-length
8339 if Nkind
(Expr_Actual
) = N_String_Literal
8340 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
8344 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
8346 Make_Integer_Literal
(Loc
,
8348 String_Literal_Length
(Etype
(Expr_Actual
))));
8350 -- General array case. Here we have a usable actual subtype for
8351 -- the expression, and the condition is built from the two types
8354 -- T_Typ'Length /= Exptyp'Length or else
8355 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
8356 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
8359 elsif Is_Constrained
(Exptyp
) then
8361 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
8374 -- At the library level, we need to ensure that the type of
8375 -- the object is elaborated before the check itself is
8376 -- emitted. This is only done if the object is in the
8377 -- current compilation unit, otherwise the type is frozen
8378 -- and elaborated in its unit.
8380 if Is_Itype
(Exptyp
)
8382 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
8384 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
8385 and then In_Open_Scopes
(Scope
(Exptyp
))
8387 Ref_Node
:= Make_Itype_Reference
(Sloc
(Ck_Node
));
8388 Set_Itype
(Ref_Node
, Exptyp
);
8389 Insert_Action
(Ck_Node
, Ref_Node
);
8392 L_Index
:= First_Index
(T_Typ
);
8393 R_Index
:= First_Index
(Exptyp
);
8395 for Indx
in 1 .. Ndims
loop
8396 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
8398 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
8400 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
8401 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
8403 -- Deal with compile time length check. Note that we
8404 -- skip this in the access case, because the access
8405 -- value may be null, so we cannot know statically.
8408 and then Compile_Time_Known_Value
(L_Low
)
8409 and then Compile_Time_Known_Value
(L_High
)
8410 and then Compile_Time_Known_Value
(R_Low
)
8411 and then Compile_Time_Known_Value
(R_High
)
8413 if Expr_Value
(L_High
) >= Expr_Value
(L_Low
) then
8414 L_Length
:= Expr_Value
(L_High
) -
8415 Expr_Value
(L_Low
) + 1;
8417 L_Length
:= UI_From_Int
(0);
8420 if Expr_Value
(R_High
) >= Expr_Value
(R_Low
) then
8421 R_Length
:= Expr_Value
(R_High
) -
8422 Expr_Value
(R_Low
) + 1;
8424 R_Length
:= UI_From_Int
(0);
8427 if L_Length
> R_Length
then
8429 (Compile_Time_Constraint_Error
8430 (Wnode
, "too few elements for}??", T_Typ
));
8432 elsif L_Length
< R_Length
then
8434 (Compile_Time_Constraint_Error
8435 (Wnode
, "too many elements for}??", T_Typ
));
8438 -- The comparison for an individual index subtype
8439 -- is omitted if the corresponding index subtypes
8440 -- statically match, since the result is known to
8441 -- be true. Note that this test is worth while even
8442 -- though we do static evaluation, because non-static
8443 -- subtypes can statically match.
8446 Subtypes_Statically_Match
8447 (Etype
(L_Index
), Etype
(R_Index
))
8450 (Same_Bounds
(L_Low
, R_Low
)
8451 and then Same_Bounds
(L_High
, R_High
))
8454 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
8463 -- Handle cases where we do not get a usable actual subtype that
8464 -- is constrained. This happens for example in the function call
8465 -- and explicit dereference cases. In these cases, we have to get
8466 -- the length or range from the expression itself, making sure we
8467 -- do not evaluate it more than once.
8469 -- Here Ck_Node is the original expression, or more properly the
8470 -- result of applying Duplicate_Expr to the original tree, forcing
8471 -- the result to be a name.
8475 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
8478 -- Build the condition for the explicit dereference case
8480 for Indx
in 1 .. Ndims
loop
8482 (Cond
, Length_N_Cond
(Ck_Node
, T_Typ
, Indx
));
8489 -- Construct the test and insert into the tree
8491 if Present
(Cond
) then
8493 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
8497 (Make_Raise_Constraint_Error
(Loc
,
8499 Reason
=> CE_Length_Check_Failed
));
8503 end Selected_Length_Checks
;
8505 ---------------------------
8506 -- Selected_Range_Checks --
8507 ---------------------------
8509 function Selected_Range_Checks
8511 Target_Typ
: Entity_Id
;
8512 Source_Typ
: Entity_Id
;
8513 Warn_Node
: Node_Id
) return Check_Result
8515 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
8518 Expr_Actual
: Node_Id
;
8520 Cond
: Node_Id
:= Empty
;
8521 Do_Access
: Boolean := False;
8522 Wnode
: Node_Id
:= Warn_Node
;
8523 Ret_Result
: Check_Result
:= (Empty
, Empty
);
8524 Num_Checks
: Integer := 0;
8526 procedure Add_Check
(N
: Node_Id
);
8527 -- Adds the action given to Ret_Result if N is non-Empty
8529 function Discrete_Range_Cond
8531 Typ
: Entity_Id
) return Node_Id
;
8532 -- Returns expression to compute:
8533 -- Low_Bound (Expr) < Typ'First
8535 -- High_Bound (Expr) > Typ'Last
8537 function Discrete_Expr_Cond
8539 Typ
: Entity_Id
) return Node_Id
;
8540 -- Returns expression to compute:
8545 function Get_E_First_Or_Last
8549 Nam
: Name_Id
) return Node_Id
;
8550 -- Returns an attribute reference
8551 -- E'First or E'Last
8552 -- with a source location of Loc.
8554 -- Nam is Name_First or Name_Last, according to which attribute is
8555 -- desired. If Indx is non-zero, it is passed as a literal in the
8556 -- Expressions of the attribute reference (identifying the desired
8557 -- array dimension).
8559 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8560 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8561 -- Returns expression to compute:
8562 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
8564 function Range_E_Cond
8565 (Exptyp
: Entity_Id
;
8569 -- Returns expression to compute:
8570 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
8572 function Range_Equal_E_Cond
8573 (Exptyp
: Entity_Id
;
8575 Indx
: Nat
) return Node_Id
;
8576 -- Returns expression to compute:
8577 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
8579 function Range_N_Cond
8582 Indx
: Nat
) return Node_Id
;
8583 -- Return expression to compute:
8584 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
8590 procedure Add_Check
(N
: Node_Id
) is
8594 -- For now, ignore attempt to place more than 2 checks ???
8596 if Num_Checks
= 2 then
8600 pragma Assert
(Num_Checks
<= 1);
8601 Num_Checks
:= Num_Checks
+ 1;
8602 Ret_Result
(Num_Checks
) := N
;
8606 -------------------------
8607 -- Discrete_Expr_Cond --
8608 -------------------------
8610 function Discrete_Expr_Cond
8612 Typ
: Entity_Id
) return Node_Id
8620 Convert_To
(Base_Type
(Typ
),
8621 Duplicate_Subexpr_No_Checks
(Expr
)),
8623 Convert_To
(Base_Type
(Typ
),
8624 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
))),
8629 Convert_To
(Base_Type
(Typ
),
8630 Duplicate_Subexpr_No_Checks
(Expr
)),
8634 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
))));
8635 end Discrete_Expr_Cond
;
8637 -------------------------
8638 -- Discrete_Range_Cond --
8639 -------------------------
8641 function Discrete_Range_Cond
8643 Typ
: Entity_Id
) return Node_Id
8645 LB
: Node_Id
:= Low_Bound
(Expr
);
8646 HB
: Node_Id
:= High_Bound
(Expr
);
8648 Left_Opnd
: Node_Id
;
8649 Right_Opnd
: Node_Id
;
8652 if Nkind
(LB
) = N_Identifier
8653 and then Ekind
(Entity
(LB
)) = E_Discriminant
8655 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
8662 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
8667 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
)));
8669 if Nkind
(HB
) = N_Identifier
8670 and then Ekind
(Entity
(HB
)) = E_Discriminant
8672 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
8679 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
8684 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
)));
8686 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
8687 end Discrete_Range_Cond
;
8689 -------------------------
8690 -- Get_E_First_Or_Last --
8691 -------------------------
8693 function Get_E_First_Or_Last
8697 Nam
: Name_Id
) return Node_Id
8702 Exprs
:= New_List
(Make_Integer_Literal
(Loc
, UI_From_Int
(Indx
)));
8707 return Make_Attribute_Reference
(Loc
,
8708 Prefix
=> New_Occurrence_Of
(E
, Loc
),
8709 Attribute_Name
=> Nam
,
8710 Expressions
=> Exprs
);
8711 end Get_E_First_Or_Last
;
8717 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8720 Make_Attribute_Reference
(Loc
,
8721 Attribute_Name
=> Name_First
,
8723 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8724 Expressions
=> New_List
(
8725 Make_Integer_Literal
(Loc
, Indx
)));
8732 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8735 Make_Attribute_Reference
(Loc
,
8736 Attribute_Name
=> Name_Last
,
8738 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8739 Expressions
=> New_List
(
8740 Make_Integer_Literal
(Loc
, Indx
)));
8747 function Range_E_Cond
8748 (Exptyp
: Entity_Id
;
8750 Indx
: Nat
) return Node_Id
8758 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
8760 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8765 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
8767 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8770 ------------------------
8771 -- Range_Equal_E_Cond --
8772 ------------------------
8774 function Range_Equal_E_Cond
8775 (Exptyp
: Entity_Id
;
8777 Indx
: Nat
) return Node_Id
8785 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
8787 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8792 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
8794 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8795 end Range_Equal_E_Cond
;
8801 function Range_N_Cond
8804 Indx
: Nat
) return Node_Id
8812 Get_N_First
(Expr
, Indx
),
8814 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8819 Get_N_Last
(Expr
, Indx
),
8821 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8824 -- Start of processing for Selected_Range_Checks
8827 if not Full_Expander_Active
then
8831 if Target_Typ
= Any_Type
8832 or else Target_Typ
= Any_Composite
8833 or else Raises_Constraint_Error
(Ck_Node
)
8842 T_Typ
:= Target_Typ
;
8844 if No
(Source_Typ
) then
8845 S_Typ
:= Etype
(Ck_Node
);
8847 S_Typ
:= Source_Typ
;
8850 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
8854 -- The order of evaluating T_Typ before S_Typ seems to be critical
8855 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
8856 -- in, and since Node can be an N_Range node, it might be invalid.
8857 -- Should there be an assert check somewhere for taking the Etype of
8858 -- an N_Range node ???
8860 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
8861 S_Typ
:= Designated_Type
(S_Typ
);
8862 T_Typ
:= Designated_Type
(T_Typ
);
8865 -- A simple optimization for the null case
8867 if Known_Null
(Ck_Node
) then
8872 -- For an N_Range Node, check for a null range and then if not
8873 -- null generate a range check action.
8875 if Nkind
(Ck_Node
) = N_Range
then
8877 -- There's no point in checking a range against itself
8879 if Ck_Node
= Scalar_Range
(T_Typ
) then
8884 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
8885 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
8886 Known_T_LB
: constant Boolean := Compile_Time_Known_Value
(T_LB
);
8887 Known_T_HB
: constant Boolean := Compile_Time_Known_Value
(T_HB
);
8889 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
8890 HB
: Node_Id
:= High_Bound
(Ck_Node
);
8894 Null_Range
: Boolean;
8895 Out_Of_Range_L
: Boolean;
8896 Out_Of_Range_H
: Boolean;
8899 -- Compute what is known at compile time
8901 if Known_T_LB
and Known_T_HB
then
8902 if Compile_Time_Known_Value
(LB
) then
8905 -- There's no point in checking that a bound is within its
8906 -- own range so pretend that it is known in this case. First
8907 -- deal with low bound.
8909 elsif Ekind
(Etype
(LB
)) = E_Signed_Integer_Subtype
8910 and then Scalar_Range
(Etype
(LB
)) = Scalar_Range
(T_Typ
)
8919 -- Likewise for the high bound
8921 if Compile_Time_Known_Value
(HB
) then
8924 elsif Ekind
(Etype
(HB
)) = E_Signed_Integer_Subtype
8925 and then Scalar_Range
(Etype
(HB
)) = Scalar_Range
(T_Typ
)
8935 -- Check for case where everything is static and we can do the
8936 -- check at compile time. This is skipped if we have an access
8937 -- type, since the access value may be null.
8939 -- ??? This code can be improved since you only need to know that
8940 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
8941 -- compile time to emit pertinent messages.
8943 if Known_T_LB
and Known_T_HB
and Known_LB
and Known_HB
8946 -- Floating-point case
8948 if Is_Floating_Point_Type
(S_Typ
) then
8949 Null_Range
:= Expr_Value_R
(HB
) < Expr_Value_R
(LB
);
8951 (Expr_Value_R
(LB
) < Expr_Value_R
(T_LB
))
8953 (Expr_Value_R
(LB
) > Expr_Value_R
(T_HB
));
8956 (Expr_Value_R
(HB
) > Expr_Value_R
(T_HB
))
8958 (Expr_Value_R
(HB
) < Expr_Value_R
(T_LB
));
8960 -- Fixed or discrete type case
8963 Null_Range
:= Expr_Value
(HB
) < Expr_Value
(LB
);
8965 (Expr_Value
(LB
) < Expr_Value
(T_LB
))
8967 (Expr_Value
(LB
) > Expr_Value
(T_HB
));
8970 (Expr_Value
(HB
) > Expr_Value
(T_HB
))
8972 (Expr_Value
(HB
) < Expr_Value
(T_LB
));
8975 if not Null_Range
then
8976 if Out_Of_Range_L
then
8977 if No
(Warn_Node
) then
8979 (Compile_Time_Constraint_Error
8980 (Low_Bound
(Ck_Node
),
8981 "static value out of range of}??", T_Typ
));
8985 (Compile_Time_Constraint_Error
8987 "static range out of bounds of}??", T_Typ
));
8991 if Out_Of_Range_H
then
8992 if No
(Warn_Node
) then
8994 (Compile_Time_Constraint_Error
8995 (High_Bound
(Ck_Node
),
8996 "static value out of range of}??", T_Typ
));
9000 (Compile_Time_Constraint_Error
9002 "static range out of bounds of}??", T_Typ
));
9009 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
9010 HB
: Node_Id
:= High_Bound
(Ck_Node
);
9013 -- If either bound is a discriminant and we are within the
9014 -- record declaration, it is a use of the discriminant in a
9015 -- constraint of a component, and nothing can be checked
9016 -- here. The check will be emitted within the init proc.
9017 -- Before then, the discriminal has no real meaning.
9018 -- Similarly, if the entity is a discriminal, there is no
9019 -- check to perform yet.
9021 -- The same holds within a discriminated synchronized type,
9022 -- where the discriminant may constrain a component or an
9025 if Nkind
(LB
) = N_Identifier
9026 and then Denotes_Discriminant
(LB
, True)
9028 if Current_Scope
= Scope
(Entity
(LB
))
9029 or else Is_Concurrent_Type
(Current_Scope
)
9030 or else Ekind
(Entity
(LB
)) /= E_Discriminant
9035 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
9039 if Nkind
(HB
) = N_Identifier
9040 and then Denotes_Discriminant
(HB
, True)
9042 if Current_Scope
= Scope
(Entity
(HB
))
9043 or else Is_Concurrent_Type
(Current_Scope
)
9044 or else Ekind
(Entity
(HB
)) /= E_Discriminant
9049 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
9053 Cond
:= Discrete_Range_Cond
(Ck_Node
, T_Typ
);
9054 Set_Paren_Count
(Cond
, 1);
9060 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(HB
),
9061 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(LB
)),
9062 Right_Opnd
=> Cond
);
9067 elsif Is_Scalar_Type
(S_Typ
) then
9069 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
9070 -- except the above simply sets a flag in the node and lets
9071 -- gigi generate the check base on the Etype of the expression.
9072 -- Sometimes, however we want to do a dynamic check against an
9073 -- arbitrary target type, so we do that here.
9075 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
9076 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9078 -- For literals, we can tell if the constraint error will be
9079 -- raised at compile time, so we never need a dynamic check, but
9080 -- if the exception will be raised, then post the usual warning,
9081 -- and replace the literal with a raise constraint error
9082 -- expression. As usual, skip this for access types
9084 elsif Compile_Time_Known_Value
(Ck_Node
)
9085 and then not Do_Access
9088 LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
9089 UB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
9091 Out_Of_Range
: Boolean;
9092 Static_Bounds
: constant Boolean :=
9093 Compile_Time_Known_Value
(LB
)
9094 and Compile_Time_Known_Value
(UB
);
9097 -- Following range tests should use Sem_Eval routine ???
9099 if Static_Bounds
then
9100 if Is_Floating_Point_Type
(S_Typ
) then
9102 (Expr_Value_R
(Ck_Node
) < Expr_Value_R
(LB
))
9104 (Expr_Value_R
(Ck_Node
) > Expr_Value_R
(UB
));
9106 -- Fixed or discrete type
9110 Expr_Value
(Ck_Node
) < Expr_Value
(LB
)
9112 Expr_Value
(Ck_Node
) > Expr_Value
(UB
);
9115 -- Bounds of the type are static and the literal is out of
9116 -- range so output a warning message.
9118 if Out_Of_Range
then
9119 if No
(Warn_Node
) then
9121 (Compile_Time_Constraint_Error
9123 "static value out of range of}??", T_Typ
));
9127 (Compile_Time_Constraint_Error
9129 "static value out of range of}??", T_Typ
));
9134 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9138 -- Here for the case of a non-static expression, we need a runtime
9139 -- check unless the source type range is guaranteed to be in the
9140 -- range of the target type.
9143 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
9144 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9149 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
9150 if Is_Constrained
(T_Typ
) then
9152 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
9153 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
9155 if Is_Access_Type
(Exptyp
) then
9156 Exptyp
:= Designated_Type
(Exptyp
);
9159 -- String_Literal case. This needs to be handled specially be-
9160 -- cause no index types are available for string literals. The
9161 -- condition is simply:
9163 -- T_Typ'Length = string-literal-length
9165 if Nkind
(Expr_Actual
) = N_String_Literal
then
9168 -- General array case. Here we have a usable actual subtype for
9169 -- the expression, and the condition is built from the two types
9171 -- T_Typ'First < Exptyp'First or else
9172 -- T_Typ'Last > Exptyp'Last or else
9173 -- T_Typ'First(1) < Exptyp'First(1) or else
9174 -- T_Typ'Last(1) > Exptyp'Last(1) or else
9177 elsif Is_Constrained
(Exptyp
) then
9179 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9185 L_Index
:= First_Index
(T_Typ
);
9186 R_Index
:= First_Index
(Exptyp
);
9188 for Indx
in 1 .. Ndims
loop
9189 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
9191 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
9193 -- Deal with compile time length check. Note that we
9194 -- skip this in the access case, because the access
9195 -- value may be null, so we cannot know statically.
9198 Subtypes_Statically_Match
9199 (Etype
(L_Index
), Etype
(R_Index
))
9201 -- If the target type is constrained then we
9202 -- have to check for exact equality of bounds
9203 -- (required for qualified expressions).
9205 if Is_Constrained
(T_Typ
) then
9208 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
9211 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
9221 -- Handle cases where we do not get a usable actual subtype that
9222 -- is constrained. This happens for example in the function call
9223 -- and explicit dereference cases. In these cases, we have to get
9224 -- the length or range from the expression itself, making sure we
9225 -- do not evaluate it more than once.
9227 -- Here Ck_Node is the original expression, or more properly the
9228 -- result of applying Duplicate_Expr to the original tree,
9229 -- forcing the result to be a name.
9233 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9236 -- Build the condition for the explicit dereference case
9238 for Indx
in 1 .. Ndims
loop
9240 (Cond
, Range_N_Cond
(Ck_Node
, T_Typ
, Indx
));
9246 -- For a conversion to an unconstrained array type, generate an
9247 -- Action to check that the bounds of the source value are within
9248 -- the constraints imposed by the target type (RM 4.6(38)). No
9249 -- check is needed for a conversion to an access to unconstrained
9250 -- array type, as 4.6(24.15/2) requires the designated subtypes
9251 -- of the two access types to statically match.
9253 if Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
9254 and then not Do_Access
9257 Opnd_Index
: Node_Id
;
9258 Targ_Index
: Node_Id
;
9259 Opnd_Range
: Node_Id
;
9262 Opnd_Index
:= First_Index
(Get_Actual_Subtype
(Ck_Node
));
9263 Targ_Index
:= First_Index
(T_Typ
);
9264 while Present
(Opnd_Index
) loop
9266 -- If the index is a range, use its bounds. If it is an
9267 -- entity (as will be the case if it is a named subtype
9268 -- or an itype created for a slice) retrieve its range.
9270 if Is_Entity_Name
(Opnd_Index
)
9271 and then Is_Type
(Entity
(Opnd_Index
))
9273 Opnd_Range
:= Scalar_Range
(Entity
(Opnd_Index
));
9275 Opnd_Range
:= Opnd_Index
;
9278 if Nkind
(Opnd_Range
) = N_Range
then
9280 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9281 Assume_Valid
=> True)
9284 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9285 Assume_Valid
=> True)
9289 -- If null range, no check needed
9292 Compile_Time_Known_Value
(High_Bound
(Opnd_Range
))
9294 Compile_Time_Known_Value
(Low_Bound
(Opnd_Range
))
9296 Expr_Value
(High_Bound
(Opnd_Range
)) <
9297 Expr_Value
(Low_Bound
(Opnd_Range
))
9301 elsif Is_Out_Of_Range
9302 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9303 Assume_Valid
=> True)
9306 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9307 Assume_Valid
=> True)
9310 (Compile_Time_Constraint_Error
9311 (Wnode
, "value out of range of}??", T_Typ
));
9317 (Opnd_Range
, Etype
(Targ_Index
)));
9321 Next_Index
(Opnd_Index
);
9322 Next_Index
(Targ_Index
);
9329 -- Construct the test and insert into the tree
9331 if Present
(Cond
) then
9333 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
9337 (Make_Raise_Constraint_Error
(Loc
,
9339 Reason
=> CE_Range_Check_Failed
));
9343 end Selected_Range_Checks
;
9345 -------------------------------
9346 -- Storage_Checks_Suppressed --
9347 -------------------------------
9349 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9351 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9352 return Is_Check_Suppressed
(E
, Storage_Check
);
9354 return Scope_Suppress
.Suppress
(Storage_Check
);
9356 end Storage_Checks_Suppressed
;
9358 ---------------------------
9359 -- Tag_Checks_Suppressed --
9360 ---------------------------
9362 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9365 and then Checks_May_Be_Suppressed
(E
)
9367 return Is_Check_Suppressed
(E
, Tag_Check
);
9370 return Scope_Suppress
.Suppress
(Tag_Check
);
9371 end Tag_Checks_Suppressed
;
9373 --------------------------
9374 -- Validity_Check_Range --
9375 --------------------------
9377 procedure Validity_Check_Range
(N
: Node_Id
) is
9379 if Validity_Checks_On
and Validity_Check_Operands
then
9380 if Nkind
(N
) = N_Range
then
9381 Ensure_Valid
(Low_Bound
(N
));
9382 Ensure_Valid
(High_Bound
(N
));
9385 end Validity_Check_Range
;
9387 --------------------------------
9388 -- Validity_Checks_Suppressed --
9389 --------------------------------
9391 function Validity_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9393 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9394 return Is_Check_Suppressed
(E
, Validity_Check
);
9396 return Scope_Suppress
.Suppress
(Validity_Check
);
9398 end Validity_Checks_Suppressed
;