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 Targparm
; use Targparm
;
62 with Tbuild
; use Tbuild
;
63 with Ttypes
; use Ttypes
;
64 with Urealp
; use Urealp
;
65 with Validsw
; use Validsw
;
67 package body Checks
is
69 -- General note: many of these routines are concerned with generating
70 -- checking code to make sure that constraint error is raised at runtime.
71 -- Clearly this code is only needed if the expander is active, since
72 -- otherwise we will not be generating code or going into the runtime
75 -- We therefore disconnect most of these checks if the expander is
76 -- inactive. This has the additional benefit that we do not need to
77 -- worry about the tree being messed up by previous errors (since errors
78 -- turn off expansion anyway).
80 -- There are a few exceptions to the above rule. For instance routines
81 -- such as Apply_Scalar_Range_Check that do not insert any code can be
82 -- safely called even when the Expander is inactive (but Errors_Detected
83 -- is 0). The benefit of executing this code when expansion is off, is
84 -- the ability to emit constraint error warning for static expressions
85 -- even when we are not generating code.
87 -------------------------------------
88 -- Suppression of Redundant Checks --
89 -------------------------------------
91 -- This unit implements a limited circuit for removal of redundant
92 -- checks. The processing is based on a tracing of simple sequential
93 -- flow. For any sequence of statements, we save expressions that are
94 -- marked to be checked, and then if the same expression appears later
95 -- with the same check, then under certain circumstances, the second
96 -- check can be suppressed.
98 -- Basically, we can suppress the check if we know for certain that
99 -- the previous expression has been elaborated (together with its
100 -- check), and we know that the exception frame is the same, and that
101 -- nothing has happened to change the result of the exception.
103 -- Let us examine each of these three conditions in turn to describe
104 -- how we ensure that this condition is met.
106 -- First, we need to know for certain that the previous expression has
107 -- been executed. This is done principally by the mechanism of calling
108 -- Conditional_Statements_Begin at the start of any statement sequence
109 -- and Conditional_Statements_End at the end. The End call causes all
110 -- checks remembered since the Begin call to be discarded. This does
111 -- miss a few cases, notably the case of a nested BEGIN-END block with
112 -- no exception handlers. But the important thing is to be conservative.
113 -- The other protection is that all checks are discarded if a label
114 -- is encountered, since then the assumption of sequential execution
115 -- is violated, and we don't know enough about the flow.
117 -- Second, we need to know that the exception frame is the same. We
118 -- do this by killing all remembered checks when we enter a new frame.
119 -- Again, that's over-conservative, but generally the cases we can help
120 -- with are pretty local anyway (like the body of a loop for example).
122 -- Third, we must be sure to forget any checks which are no longer valid.
123 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
124 -- used to note any changes to local variables. We only attempt to deal
125 -- with checks involving local variables, so we do not need to worry
126 -- about global variables. Second, a call to any non-global procedure
127 -- causes us to abandon all stored checks, since such a all may affect
128 -- the values of any local variables.
130 -- The following define the data structures used to deal with remembering
131 -- checks so that redundant checks can be eliminated as described above.
133 -- Right now, the only expressions that we deal with are of the form of
134 -- simple local objects (either declared locally, or IN parameters) or
135 -- such objects plus/minus a compile time known constant. We can do
136 -- more later on if it seems worthwhile, but this catches many simple
137 -- cases in practice.
139 -- The following record type reflects a single saved check. An entry
140 -- is made in the stack of saved checks if and only if the expression
141 -- has been elaborated with the indicated checks.
143 type Saved_Check
is record
145 -- Set True if entry is killed by Kill_Checks
148 -- The entity involved in the expression that is checked
151 -- A compile time value indicating the result of adding or
152 -- subtracting a compile time value. This value is to be
153 -- added to the value of the Entity. A value of zero is
154 -- used for the case of a simple entity reference.
156 Check_Type
: Character;
157 -- This is set to 'R' for a range check (in which case Target_Type
158 -- is set to the target type for the range check) or to 'O' for an
159 -- overflow check (in which case Target_Type is set to Empty).
161 Target_Type
: Entity_Id
;
162 -- Used only if Do_Range_Check is set. Records the target type for
163 -- the check. We need this, because a check is a duplicate only if
164 -- it has the same target type (or more accurately one with a
165 -- range that is smaller or equal to the stored target type of a
169 -- The following table keeps track of saved checks. Rather than use an
170 -- extensible table. We just use a table of fixed size, and we discard
171 -- any saved checks that do not fit. That's very unlikely to happen and
172 -- this is only an optimization in any case.
174 Saved_Checks
: array (Int
range 1 .. 200) of Saved_Check
;
175 -- Array of saved checks
177 Num_Saved_Checks
: Nat
:= 0;
178 -- Number of saved checks
180 -- The following stack keeps track of statement ranges. It is treated
181 -- as a stack. When Conditional_Statements_Begin is called, an entry
182 -- is pushed onto this stack containing the value of Num_Saved_Checks
183 -- at the time of the call. Then when Conditional_Statements_End is
184 -- called, this value is popped off and used to reset Num_Saved_Checks.
186 -- Note: again, this is a fixed length stack with a size that should
187 -- always be fine. If the value of the stack pointer goes above the
188 -- limit, then we just forget all saved checks.
190 Saved_Checks_Stack
: array (Int
range 1 .. 100) of Nat
;
191 Saved_Checks_TOS
: Nat
:= 0;
193 -----------------------
194 -- Local Subprograms --
195 -----------------------
197 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
);
198 -- Used to apply arithmetic overflow checks for all cases except operators
199 -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we
200 -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a
201 -- signed integer arithmetic operator (but not an if or case expression).
202 -- It is also called for types other than signed integers.
204 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
);
205 -- Used to apply arithmetic overflow checks for the case where the overflow
206 -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer
207 -- arithmetic op (which includes the case of if and case expressions). Note
208 -- that Do_Overflow_Check may or may not be set for node Op. In these modes
209 -- we have work to do even if overflow checking is suppressed.
211 procedure Apply_Division_Check
216 -- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies
217 -- division checks as required if the Do_Division_Check flag is set.
218 -- Rlo and Rhi give the possible range of the right operand, these values
219 -- can be referenced and trusted only if ROK is set True.
221 procedure Apply_Float_Conversion_Check
223 Target_Typ
: Entity_Id
);
224 -- The checks on a conversion from a floating-point type to an integer
225 -- type are delicate. They have to be performed before conversion, they
226 -- have to raise an exception when the operand is a NaN, and rounding must
227 -- be taken into account to determine the safe bounds of the operand.
229 procedure Apply_Selected_Length_Checks
231 Target_Typ
: Entity_Id
;
232 Source_Typ
: Entity_Id
;
233 Do_Static
: Boolean);
234 -- This is the subprogram that does all the work for Apply_Length_Check
235 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
236 -- described for the above routines. The Do_Static flag indicates that
237 -- only a static check is to be done.
239 procedure Apply_Selected_Range_Checks
241 Target_Typ
: Entity_Id
;
242 Source_Typ
: Entity_Id
;
243 Do_Static
: Boolean);
244 -- This is the subprogram that does all the work for Apply_Range_Check.
245 -- Expr, Target_Typ and Source_Typ are as described for the above
246 -- routine. The Do_Static flag indicates that only a static check is
249 type Check_Type
is new Check_Id
range Access_Check
.. Division_Check
;
250 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean;
251 -- This function is used to see if an access or division by zero check is
252 -- needed. The check is to be applied to a single variable appearing in the
253 -- source, and N is the node for the reference. If N is not of this form,
254 -- True is returned with no further processing. If N is of the right form,
255 -- then further processing determines if the given Check is needed.
257 -- The particular circuit is to see if we have the case of a check that is
258 -- not needed because it appears in the right operand of a short circuited
259 -- conditional where the left operand guards the check. For example:
261 -- if Var = 0 or else Q / Var > 12 then
265 -- In this example, the division check is not required. At the same time
266 -- we can issue warnings for suspicious use of non-short-circuited forms,
269 -- if Var = 0 or Q / Var > 12 then
275 Check_Type
: Character;
276 Target_Type
: Entity_Id
;
277 Entry_OK
: out Boolean;
281 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
282 -- to see if a check is of the form for optimization, and if so, to see
283 -- if it has already been performed. Expr is the expression to check,
284 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
285 -- Target_Type is the target type for a range check, and Empty for an
286 -- overflow check. If the entry is not of the form for optimization,
287 -- then Entry_OK is set to False, and the remaining out parameters
288 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
289 -- entity and offset from the expression. Check_Num is the number of
290 -- a matching saved entry in Saved_Checks, or zero if no such entry
293 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
;
294 -- If a discriminal is used in constraining a prival, Return reference
295 -- to the discriminal of the protected body (which renames the parameter
296 -- of the enclosing protected operation). This clumsy transformation is
297 -- needed because privals are created too late and their actual subtypes
298 -- are not available when analysing the bodies of the protected operations.
299 -- This function is called whenever the bound is an entity and the scope
300 -- indicates a protected operation. If the bound is an in-parameter of
301 -- a protected operation that is not a prival, the function returns the
303 -- To be cleaned up???
305 function Guard_Access
308 Ck_Node
: Node_Id
) return Node_Id
;
309 -- In the access type case, guard the test with a test to ensure
310 -- that the access value is non-null, since the checks do not
311 -- not apply to null access values.
313 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
);
314 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
315 -- Constraint_Error node.
317 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean;
318 -- Returns True if node N is for an arithmetic operation with signed
319 -- integer operands. This includes unary and binary operators, and also
320 -- if and case expression nodes where the dependent expressions are of
321 -- a signed integer type. These are the kinds of nodes for which special
322 -- handling applies in MINIMIZED or ELIMINATED overflow checking mode.
324 function Range_Or_Validity_Checks_Suppressed
325 (Expr
: Node_Id
) return Boolean;
326 -- Returns True if either range or validity checks or both are suppressed
327 -- for the type of the given expression, or, if the expression is the name
328 -- of an entity, if these checks are suppressed for the entity.
330 function Selected_Length_Checks
332 Target_Typ
: Entity_Id
;
333 Source_Typ
: Entity_Id
;
334 Warn_Node
: Node_Id
) return Check_Result
;
335 -- Like Apply_Selected_Length_Checks, except it doesn't modify
336 -- anything, just returns a list of nodes as described in the spec of
337 -- this package for the Range_Check function.
339 function Selected_Range_Checks
341 Target_Typ
: Entity_Id
;
342 Source_Typ
: Entity_Id
;
343 Warn_Node
: Node_Id
) return Check_Result
;
344 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
345 -- just returns a list of nodes as described in the spec of this package
346 -- for the Range_Check function.
348 ------------------------------
349 -- Access_Checks_Suppressed --
350 ------------------------------
352 function Access_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
354 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
355 return Is_Check_Suppressed
(E
, Access_Check
);
357 return Scope_Suppress
.Suppress
(Access_Check
);
359 end Access_Checks_Suppressed
;
361 -------------------------------------
362 -- Accessibility_Checks_Suppressed --
363 -------------------------------------
365 function Accessibility_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
367 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
368 return Is_Check_Suppressed
(E
, Accessibility_Check
);
370 return Scope_Suppress
.Suppress
(Accessibility_Check
);
372 end Accessibility_Checks_Suppressed
;
374 -----------------------------
375 -- Activate_Division_Check --
376 -----------------------------
378 procedure Activate_Division_Check
(N
: Node_Id
) is
380 Set_Do_Division_Check
(N
, True);
381 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
382 end Activate_Division_Check
;
384 -----------------------------
385 -- Activate_Overflow_Check --
386 -----------------------------
388 procedure Activate_Overflow_Check
(N
: Node_Id
) is
390 if not Nkind_In
(N
, N_Op_Rem
, N_Op_Mod
, N_Op_Plus
) then
391 Set_Do_Overflow_Check
(N
, True);
392 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
394 end Activate_Overflow_Check
;
396 --------------------------
397 -- Activate_Range_Check --
398 --------------------------
400 procedure Activate_Range_Check
(N
: Node_Id
) is
402 Set_Do_Range_Check
(N
, True);
403 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
404 end Activate_Range_Check
;
406 ---------------------------------
407 -- Alignment_Checks_Suppressed --
408 ---------------------------------
410 function Alignment_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
412 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
413 return Is_Check_Suppressed
(E
, Alignment_Check
);
415 return Scope_Suppress
.Suppress
(Alignment_Check
);
417 end Alignment_Checks_Suppressed
;
419 -------------------------
420 -- Append_Range_Checks --
421 -------------------------
423 procedure Append_Range_Checks
424 (Checks
: Check_Result
;
426 Suppress_Typ
: Entity_Id
;
427 Static_Sloc
: Source_Ptr
;
430 Internal_Flag_Node
: constant Node_Id
:= Flag_Node
;
431 Internal_Static_Sloc
: constant Source_Ptr
:= Static_Sloc
;
433 Checks_On
: constant Boolean :=
434 (not Index_Checks_Suppressed
(Suppress_Typ
))
435 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
438 -- For now we just return if Checks_On is false, however this should
439 -- be enhanced to check for an always True value in the condition
440 -- and to generate a compilation warning???
442 if not Checks_On
then
447 exit when No
(Checks
(J
));
449 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
450 and then Present
(Condition
(Checks
(J
)))
452 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
453 Append_To
(Stmts
, Checks
(J
));
454 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
460 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
461 Reason
=> CE_Range_Check_Failed
));
464 end Append_Range_Checks
;
466 ------------------------
467 -- Apply_Access_Check --
468 ------------------------
470 procedure Apply_Access_Check
(N
: Node_Id
) is
471 P
: constant Node_Id
:= Prefix
(N
);
474 -- We do not need checks if we are not generating code (i.e. the
475 -- expander is not active). This is not just an optimization, there
476 -- are cases (e.g. with pragma Debug) where generating the checks
477 -- can cause real trouble).
479 if not Full_Expander_Active
then
483 -- No check if short circuiting makes check unnecessary
485 if not Check_Needed
(P
, Access_Check
) then
489 -- No check if accessing the Offset_To_Top component of a dispatch
490 -- table. They are safe by construction.
492 if Tagged_Type_Expansion
493 and then Present
(Etype
(P
))
494 and then RTU_Loaded
(Ada_Tags
)
495 and then RTE_Available
(RE_Offset_To_Top_Ptr
)
496 and then Etype
(P
) = RTE
(RE_Offset_To_Top_Ptr
)
501 -- Otherwise go ahead and install the check
503 Install_Null_Excluding_Check
(P
);
504 end Apply_Access_Check
;
506 -------------------------------
507 -- Apply_Accessibility_Check --
508 -------------------------------
510 procedure Apply_Accessibility_Check
513 Insert_Node
: Node_Id
)
515 Loc
: constant Source_Ptr
:= Sloc
(N
);
516 Param_Ent
: Entity_Id
:= Param_Entity
(N
);
517 Param_Level
: Node_Id
;
518 Type_Level
: Node_Id
;
521 if Ada_Version
>= Ada_2012
522 and then not Present
(Param_Ent
)
523 and then Is_Entity_Name
(N
)
524 and then Ekind_In
(Entity
(N
), E_Constant
, E_Variable
)
525 and then Present
(Effective_Extra_Accessibility
(Entity
(N
)))
527 Param_Ent
:= Entity
(N
);
528 while Present
(Renamed_Object
(Param_Ent
)) loop
530 -- Renamed_Object must return an Entity_Name here
531 -- because of preceding "Present (E_E_A (...))" test.
533 Param_Ent
:= Entity
(Renamed_Object
(Param_Ent
));
537 if Inside_A_Generic
then
540 -- Only apply the run-time check if the access parameter has an
541 -- associated extra access level parameter and when the level of the
542 -- type is less deep than the level of the access parameter, and
543 -- accessibility checks are not suppressed.
545 elsif Present
(Param_Ent
)
546 and then Present
(Extra_Accessibility
(Param_Ent
))
547 and then UI_Gt
(Object_Access_Level
(N
),
548 Deepest_Type_Access_Level
(Typ
))
549 and then not Accessibility_Checks_Suppressed
(Param_Ent
)
550 and then not Accessibility_Checks_Suppressed
(Typ
)
553 New_Occurrence_Of
(Extra_Accessibility
(Param_Ent
), Loc
);
556 Make_Integer_Literal
(Loc
, Deepest_Type_Access_Level
(Typ
));
558 -- Raise Program_Error if the accessibility level of the access
559 -- parameter is deeper than the level of the target access type.
561 Insert_Action
(Insert_Node
,
562 Make_Raise_Program_Error
(Loc
,
565 Left_Opnd
=> Param_Level
,
566 Right_Opnd
=> Type_Level
),
567 Reason
=> PE_Accessibility_Check_Failed
));
569 Analyze_And_Resolve
(N
);
571 end Apply_Accessibility_Check
;
573 --------------------------------
574 -- Apply_Address_Clause_Check --
575 --------------------------------
577 procedure Apply_Address_Clause_Check
(E
: Entity_Id
; N
: Node_Id
) is
578 pragma Assert
(Nkind
(N
) = N_Freeze_Entity
);
580 AC
: constant Node_Id
:= Address_Clause
(E
);
581 Loc
: constant Source_Ptr
:= Sloc
(AC
);
582 Typ
: constant Entity_Id
:= Etype
(E
);
583 Aexp
: constant Node_Id
:= Expression
(AC
);
586 -- Address expression (not necessarily the same as Aexp, for example
587 -- when Aexp is a reference to a constant, in which case Expr gets
588 -- reset to reference the value expression of the constant.
590 procedure Compile_Time_Bad_Alignment
;
591 -- Post error warnings when alignment is known to be incompatible. Note
592 -- that we do not go as far as inserting a raise of Program_Error since
593 -- this is an erroneous case, and it may happen that we are lucky and an
594 -- underaligned address turns out to be OK after all.
596 --------------------------------
597 -- Compile_Time_Bad_Alignment --
598 --------------------------------
600 procedure Compile_Time_Bad_Alignment
is
602 if Address_Clause_Overlay_Warnings
then
604 ("?o?specified address for& may be inconsistent with alignment",
607 ("\?o?program execution may be erroneous (RM 13.3(27))",
609 Set_Address_Warning_Posted
(AC
);
611 end Compile_Time_Bad_Alignment
;
613 -- Start of processing for Apply_Address_Clause_Check
616 -- See if alignment check needed. Note that we never need a check if the
617 -- maximum alignment is one, since the check will always succeed.
619 -- Note: we do not check for checks suppressed here, since that check
620 -- was done in Sem_Ch13 when the address clause was processed. We are
621 -- only called if checks were not suppressed. The reason for this is
622 -- that we have to delay the call to Apply_Alignment_Check till freeze
623 -- time (so that all types etc are elaborated), but we have to check
624 -- the status of check suppressing at the point of the address clause.
627 or else not Check_Address_Alignment
(AC
)
628 or else Maximum_Alignment
= 1
633 -- Obtain expression from address clause
635 Expr
:= Expression
(AC
);
637 -- The following loop digs for the real expression to use in the check
640 -- For constant, get constant expression
642 if Is_Entity_Name
(Expr
)
643 and then Ekind
(Entity
(Expr
)) = E_Constant
645 Expr
:= Constant_Value
(Entity
(Expr
));
647 -- For unchecked conversion, get result to convert
649 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
650 Expr
:= Expression
(Expr
);
652 -- For (common case) of To_Address call, get argument
654 elsif Nkind
(Expr
) = N_Function_Call
655 and then Is_Entity_Name
(Name
(Expr
))
656 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
658 Expr
:= First
(Parameter_Associations
(Expr
));
660 if Nkind
(Expr
) = N_Parameter_Association
then
661 Expr
:= Explicit_Actual_Parameter
(Expr
);
664 -- We finally have the real expression
671 -- See if we know that Expr has a bad alignment at compile time
673 if Compile_Time_Known_Value
(Expr
)
674 and then (Known_Alignment
(E
) or else Known_Alignment
(Typ
))
677 AL
: Uint
:= Alignment
(Typ
);
680 -- The object alignment might be more restrictive than the
683 if Known_Alignment
(E
) then
687 if Expr_Value
(Expr
) mod AL
/= 0 then
688 Compile_Time_Bad_Alignment
;
694 -- If the expression has the form X'Address, then we can find out if
695 -- the object X has an alignment that is compatible with the object E.
696 -- If it hasn't or we don't know, we defer issuing the warning until
697 -- the end of the compilation to take into account back end annotations.
699 elsif Nkind
(Expr
) = N_Attribute_Reference
700 and then Attribute_Name
(Expr
) = Name_Address
701 and then Has_Compatible_Alignment
(E
, Prefix
(Expr
)) = Known_Compatible
706 -- Here we do not know if the value is acceptable. Strictly we don't
707 -- have to do anything, since if the alignment is bad, we have an
708 -- erroneous program. However we are allowed to check for erroneous
709 -- conditions and we decide to do this by default if the check is not
712 -- However, don't do the check if elaboration code is unwanted
714 if Restriction_Active
(No_Elaboration_Code
) then
717 -- Generate a check to raise PE if alignment may be inappropriate
720 -- If the original expression is a non-static constant, use the
721 -- name of the constant itself rather than duplicating its
722 -- defining expression, which was extracted above.
724 -- Note: Expr is empty if the address-clause is applied to in-mode
725 -- actuals (allowed by 13.1(22)).
727 if not Present
(Expr
)
729 (Is_Entity_Name
(Expression
(AC
))
730 and then Ekind
(Entity
(Expression
(AC
))) = E_Constant
731 and then Nkind
(Parent
(Entity
(Expression
(AC
))))
732 = N_Object_Declaration
)
734 Expr
:= New_Copy_Tree
(Expression
(AC
));
736 Remove_Side_Effects
(Expr
);
739 if No
(Actions
(N
)) then
740 Set_Actions
(N
, New_List
);
743 Prepend_To
(Actions
(N
),
744 Make_Raise_Program_Error
(Loc
,
751 (RTE
(RE_Integer_Address
), Expr
),
753 Make_Attribute_Reference
(Loc
,
754 Prefix
=> New_Occurrence_Of
(E
, Loc
),
755 Attribute_Name
=> Name_Alignment
)),
756 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
757 Reason
=> PE_Misaligned_Address_Value
));
758 Analyze
(First
(Actions
(N
)), Suppress
=> All_Checks
);
763 -- If we have some missing run time component in configurable run time
764 -- mode then just skip the check (it is not required in any case).
766 when RE_Not_Available
=>
768 end Apply_Address_Clause_Check
;
770 -------------------------------------
771 -- Apply_Arithmetic_Overflow_Check --
772 -------------------------------------
774 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
776 -- Use old routine in almost all cases (the only case we are treating
777 -- specially is the case of a signed integer arithmetic op with the
778 -- overflow checking mode set to MINIMIZED or ELIMINATED).
780 if Overflow_Check_Mode
= Strict
781 or else not Is_Signed_Integer_Arithmetic_Op
(N
)
783 Apply_Arithmetic_Overflow_Strict
(N
);
785 -- Otherwise use the new routine for the case of a signed integer
786 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
787 -- mode is MINIMIZED or ELIMINATED.
790 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
792 end Apply_Arithmetic_Overflow_Check
;
794 --------------------------------------
795 -- Apply_Arithmetic_Overflow_Strict --
796 --------------------------------------
798 -- This routine is called only if the type is an integer type, and a
799 -- software arithmetic overflow check may be needed for op (add, subtract,
800 -- or multiply). This check is performed only if Software_Overflow_Checking
801 -- is enabled and Do_Overflow_Check is set. In this case we expand the
802 -- operation into a more complex sequence of tests that ensures that
803 -- overflow is properly caught.
805 -- This is used in CHECKED modes. It is identical to the code for this
806 -- cases before the big overflow earthquake, thus ensuring that in this
807 -- modes we have compatible behavior (and reliability) to what was there
808 -- before. It is also called for types other than signed integers, and if
809 -- the Do_Overflow_Check flag is off.
811 -- Note: we also call this routine if we decide in the MINIMIZED case
812 -- to give up and just generate an overflow check without any fuss.
814 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
) is
815 Loc
: constant Source_Ptr
:= Sloc
(N
);
816 Typ
: constant Entity_Id
:= Etype
(N
);
817 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
820 -- Nothing to do if Do_Overflow_Check not set or overflow checks
823 if not Do_Overflow_Check
(N
) then
827 -- An interesting special case. If the arithmetic operation appears as
828 -- the operand of a type conversion:
832 -- and all the following conditions apply:
834 -- arithmetic operation is for a signed integer type
835 -- target type type1 is a static integer subtype
836 -- range of x and y are both included in the range of type1
837 -- range of x op y is included in the range of type1
838 -- size of type1 is at least twice the result size of op
840 -- then we don't do an overflow check in any case, instead we transform
841 -- the operation so that we end up with:
843 -- type1 (type1 (x) op type1 (y))
845 -- This avoids intermediate overflow before the conversion. It is
846 -- explicitly permitted by RM 3.5.4(24):
848 -- For the execution of a predefined operation of a signed integer
849 -- type, the implementation need not raise Constraint_Error if the
850 -- result is outside the base range of the type, so long as the
851 -- correct result is produced.
853 -- It's hard to imagine that any programmer counts on the exception
854 -- being raised in this case, and in any case it's wrong coding to
855 -- have this expectation, given the RM permission. Furthermore, other
856 -- Ada compilers do allow such out of range results.
858 -- Note that we do this transformation even if overflow checking is
859 -- off, since this is precisely about giving the "right" result and
860 -- avoiding the need for an overflow check.
862 -- Note: this circuit is partially redundant with respect to the similar
863 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
864 -- with cases that do not come through here. We still need the following
865 -- processing even with the Exp_Ch4 code in place, since we want to be
866 -- sure not to generate the arithmetic overflow check in these cases
867 -- (Exp_Ch4 would have a hard time removing them once generated).
869 if Is_Signed_Integer_Type
(Typ
)
870 and then Nkind
(Parent
(N
)) = N_Type_Conversion
872 Conversion_Optimization
: declare
873 Target_Type
: constant Entity_Id
:=
874 Base_Type
(Entity
(Subtype_Mark
(Parent
(N
))));
888 if Is_Integer_Type
(Target_Type
)
889 and then RM_Size
(Root_Type
(Target_Type
)) >= 2 * RM_Size
(Rtyp
)
891 Tlo
:= Expr_Value
(Type_Low_Bound
(Target_Type
));
892 Thi
:= Expr_Value
(Type_High_Bound
(Target_Type
));
895 (Left_Opnd
(N
), LOK
, Llo
, Lhi
, Assume_Valid
=> True);
897 (Right_Opnd
(N
), ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
900 and then Tlo
<= Llo
and then Lhi
<= Thi
901 and then Tlo
<= Rlo
and then Rhi
<= Thi
903 Determine_Range
(N
, VOK
, Vlo
, Vhi
, Assume_Valid
=> True);
905 if VOK
and then Tlo
<= Vlo
and then Vhi
<= Thi
then
906 Rewrite
(Left_Opnd
(N
),
907 Make_Type_Conversion
(Loc
,
908 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
909 Expression
=> Relocate_Node
(Left_Opnd
(N
))));
911 Rewrite
(Right_Opnd
(N
),
912 Make_Type_Conversion
(Loc
,
913 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
914 Expression
=> Relocate_Node
(Right_Opnd
(N
))));
916 -- Rewrite the conversion operand so that the original
917 -- node is retained, in order to avoid the warning for
918 -- redundant conversions in Resolve_Type_Conversion.
920 Rewrite
(N
, Relocate_Node
(N
));
922 Set_Etype
(N
, Target_Type
);
924 Analyze_And_Resolve
(Left_Opnd
(N
), Target_Type
);
925 Analyze_And_Resolve
(Right_Opnd
(N
), Target_Type
);
927 -- Given that the target type is twice the size of the
928 -- source type, overflow is now impossible, so we can
929 -- safely kill the overflow check and return.
931 Set_Do_Overflow_Check
(N
, False);
936 end Conversion_Optimization
;
939 -- Now see if an overflow check is required
942 Siz
: constant Int
:= UI_To_Int
(Esize
(Rtyp
));
943 Dsiz
: constant Int
:= Siz
* 2;
950 -- Skip check if back end does overflow checks, or the overflow flag
951 -- is not set anyway, or we are not doing code expansion, or the
952 -- parent node is a type conversion whose operand is an arithmetic
953 -- operation on signed integers on which the expander can promote
954 -- later the operands to type Integer (see Expand_N_Type_Conversion).
956 -- Special case CLI target, where arithmetic overflow checks can be
957 -- performed for integer and long_integer
959 if Backend_Overflow_Checks_On_Target
960 or else not Do_Overflow_Check
(N
)
961 or else not Full_Expander_Active
962 or else (Present
(Parent
(N
))
963 and then Nkind
(Parent
(N
)) = N_Type_Conversion
964 and then Integer_Promotion_Possible
(Parent
(N
)))
966 (VM_Target
= CLI_Target
and then Siz
>= Standard_Integer_Size
)
971 -- Otherwise, generate the full general code for front end overflow
972 -- detection, which works by doing arithmetic in a larger type:
978 -- Typ (Checktyp (x) op Checktyp (y));
980 -- where Typ is the type of the original expression, and Checktyp is
981 -- an integer type of sufficient length to hold the largest possible
984 -- If the size of check type exceeds the size of Long_Long_Integer,
985 -- we use a different approach, expanding to:
987 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
989 -- where xxx is Add, Multiply or Subtract as appropriate
991 -- Find check type if one exists
993 if Dsiz
<= Standard_Integer_Size
then
994 Ctyp
:= Standard_Integer
;
996 elsif Dsiz
<= Standard_Long_Long_Integer_Size
then
997 Ctyp
:= Standard_Long_Long_Integer
;
999 -- No check type exists, use runtime call
1002 if Nkind
(N
) = N_Op_Add
then
1003 Cent
:= RE_Add_With_Ovflo_Check
;
1005 elsif Nkind
(N
) = N_Op_Multiply
then
1006 Cent
:= RE_Multiply_With_Ovflo_Check
;
1009 pragma Assert
(Nkind
(N
) = N_Op_Subtract
);
1010 Cent
:= RE_Subtract_With_Ovflo_Check
;
1015 Make_Function_Call
(Loc
,
1016 Name
=> New_Reference_To
(RTE
(Cent
), Loc
),
1017 Parameter_Associations
=> New_List
(
1018 OK_Convert_To
(RTE
(RE_Integer_64
), Left_Opnd
(N
)),
1019 OK_Convert_To
(RTE
(RE_Integer_64
), Right_Opnd
(N
))))));
1021 Analyze_And_Resolve
(N
, Typ
);
1025 -- If we fall through, we have the case where we do the arithmetic
1026 -- in the next higher type and get the check by conversion. In these
1027 -- cases Ctyp is set to the type to be used as the check type.
1029 Opnod
:= Relocate_Node
(N
);
1031 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
1034 Set_Etype
(Opnd
, Ctyp
);
1035 Set_Analyzed
(Opnd
, True);
1036 Set_Left_Opnd
(Opnod
, Opnd
);
1038 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
1041 Set_Etype
(Opnd
, Ctyp
);
1042 Set_Analyzed
(Opnd
, True);
1043 Set_Right_Opnd
(Opnod
, Opnd
);
1045 -- The type of the operation changes to the base type of the check
1046 -- type, and we reset the overflow check indication, since clearly no
1047 -- overflow is possible now that we are using a double length type.
1048 -- We also set the Analyzed flag to avoid a recursive attempt to
1051 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
1052 Set_Do_Overflow_Check
(Opnod
, False);
1053 Set_Analyzed
(Opnod
, True);
1055 -- Now build the outer conversion
1057 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
1059 Set_Etype
(Opnd
, Typ
);
1061 -- In the discrete type case, we directly generate the range check
1062 -- for the outer operand. This range check will implement the
1063 -- required overflow check.
1065 if Is_Discrete_Type
(Typ
) then
1067 Generate_Range_Check
1068 (Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
1070 -- For other types, we enable overflow checking on the conversion,
1071 -- after setting the node as analyzed to prevent recursive attempts
1072 -- to expand the conversion node.
1075 Set_Analyzed
(Opnd
, True);
1076 Enable_Overflow_Check
(Opnd
);
1081 when RE_Not_Available
=>
1084 end Apply_Arithmetic_Overflow_Strict
;
1086 ----------------------------------------------------
1087 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1088 ----------------------------------------------------
1090 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
) is
1091 pragma Assert
(Is_Signed_Integer_Arithmetic_Op
(Op
));
1093 Loc
: constant Source_Ptr
:= Sloc
(Op
);
1094 P
: constant Node_Id
:= Parent
(Op
);
1096 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
1097 -- Operands and results are of this type when we convert
1099 Result_Type
: constant Entity_Id
:= Etype
(Op
);
1100 -- Original result type
1102 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1103 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
1106 -- Ranges of values for result
1109 -- Nothing to do if our parent is one of the following:
1111 -- Another signed integer arithmetic op
1112 -- A membership operation
1113 -- A comparison operation
1115 -- In all these cases, we will process at the higher level (and then
1116 -- this node will be processed during the downwards recursion that
1117 -- is part of the processing in Minimize_Eliminate_Overflows).
1119 if Is_Signed_Integer_Arithmetic_Op
(P
)
1120 or else Nkind
(P
) in N_Membership_Test
1121 or else Nkind
(P
) in N_Op_Compare
1123 -- This is also true for an alternative in a case expression
1125 or else Nkind
(P
) = N_Case_Expression_Alternative
1127 -- This is also true for a range operand in a membership test
1129 or else (Nkind
(P
) = N_Range
1130 and then Nkind
(Parent
(P
)) in N_Membership_Test
)
1135 -- Otherwise, we have a top level arithmetic operation node, and this
1136 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1137 -- modes. This is the case where we tell the machinery not to move into
1138 -- Bignum mode at this top level (of course the top level operation
1139 -- will still be in Bignum mode if either of its operands are of type
1142 Minimize_Eliminate_Overflows
(Op
, Lo
, Hi
, Top_Level
=> True);
1144 -- That call may but does not necessarily change the result type of Op.
1145 -- It is the job of this routine to undo such changes, so that at the
1146 -- top level, we have the proper type. This "undoing" is a point at
1147 -- which a final overflow check may be applied.
1149 -- If the result type was not fiddled we are all set. We go to base
1150 -- types here because things may have been rewritten to generate the
1151 -- base type of the operand types.
1153 if Base_Type
(Etype
(Op
)) = Base_Type
(Result_Type
) then
1158 elsif Is_RTE
(Etype
(Op
), RE_Bignum
) then
1160 -- We need a sequence that looks like:
1162 -- Rnn : Result_Type;
1165 -- M : Mark_Id := SS_Mark;
1167 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1171 -- This block is inserted (using Insert_Actions), and then the node
1172 -- is replaced with a reference to Rnn.
1174 -- A special case arises if our parent is a conversion node. In this
1175 -- case no point in generating a conversion to Result_Type, we will
1176 -- let the parent handle this. Note that this special case is not
1177 -- just about optimization. Consider
1181 -- X := Long_Long_Integer'Base (A * (B ** C));
1183 -- Now the product may fit in Long_Long_Integer but not in Integer.
1184 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1185 -- overflow exception for this intermediate value.
1188 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
1189 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R', Op
);
1195 RHS
:= Convert_From_Bignum
(Op
);
1197 if Nkind
(P
) /= N_Type_Conversion
then
1198 Convert_To_And_Rewrite
(Result_Type
, RHS
);
1199 Rtype
:= Result_Type
;
1201 -- Interesting question, do we need a check on that conversion
1202 -- operation. Answer, not if we know the result is in range.
1203 -- At the moment we are not taking advantage of this. To be
1204 -- looked at later ???
1211 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
1212 Make_Assignment_Statement
(Loc
,
1213 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
1214 Expression
=> RHS
));
1216 Insert_Actions
(Op
, New_List
(
1217 Make_Object_Declaration
(Loc
,
1218 Defining_Identifier
=> Rnn
,
1219 Object_Definition
=> New_Occurrence_Of
(Rtype
, Loc
)),
1222 Rewrite
(Op
, New_Occurrence_Of
(Rnn
, Loc
));
1223 Analyze_And_Resolve
(Op
);
1226 -- Here we know the result is Long_Long_Integer'Base, of that it has
1227 -- been rewritten because the parent operation is a conversion. See
1228 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1232 (Etype
(Op
) = LLIB
or else Nkind
(Parent
(Op
)) = N_Type_Conversion
);
1234 -- All we need to do here is to convert the result to the proper
1235 -- result type. As explained above for the Bignum case, we can
1236 -- omit this if our parent is a type conversion.
1238 if Nkind
(P
) /= N_Type_Conversion
then
1239 Convert_To_And_Rewrite
(Result_Type
, Op
);
1242 Analyze_And_Resolve
(Op
);
1244 end Apply_Arithmetic_Overflow_Minimized_Eliminated
;
1246 ----------------------------
1247 -- Apply_Constraint_Check --
1248 ----------------------------
1250 procedure Apply_Constraint_Check
1253 No_Sliding
: Boolean := False)
1255 Desig_Typ
: Entity_Id
;
1258 -- No checks inside a generic (check the instantiations)
1260 if Inside_A_Generic
then
1264 -- Apply required constraint checks
1266 if Is_Scalar_Type
(Typ
) then
1267 Apply_Scalar_Range_Check
(N
, Typ
);
1269 elsif Is_Array_Type
(Typ
) then
1271 -- A useful optimization: an aggregate with only an others clause
1272 -- always has the right bounds.
1274 if Nkind
(N
) = N_Aggregate
1275 and then No
(Expressions
(N
))
1277 (First
(Choices
(First
(Component_Associations
(N
)))))
1283 if Is_Constrained
(Typ
) then
1284 Apply_Length_Check
(N
, Typ
);
1287 Apply_Range_Check
(N
, Typ
);
1290 Apply_Range_Check
(N
, Typ
);
1293 elsif (Is_Record_Type
(Typ
) or else Is_Private_Type
(Typ
))
1294 and then Has_Discriminants
(Base_Type
(Typ
))
1295 and then Is_Constrained
(Typ
)
1297 Apply_Discriminant_Check
(N
, Typ
);
1299 elsif Is_Access_Type
(Typ
) then
1301 Desig_Typ
:= Designated_Type
(Typ
);
1303 -- No checks necessary if expression statically null
1305 if Known_Null
(N
) then
1306 if Can_Never_Be_Null
(Typ
) then
1307 Install_Null_Excluding_Check
(N
);
1310 -- No sliding possible on access to arrays
1312 elsif Is_Array_Type
(Desig_Typ
) then
1313 if Is_Constrained
(Desig_Typ
) then
1314 Apply_Length_Check
(N
, Typ
);
1317 Apply_Range_Check
(N
, Typ
);
1319 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
1320 and then Is_Constrained
(Desig_Typ
)
1322 Apply_Discriminant_Check
(N
, Typ
);
1325 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1326 -- this check if the constraint node is illegal, as shown by having
1327 -- an error posted. This additional guard prevents cascaded errors
1328 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1330 if Can_Never_Be_Null
(Typ
)
1331 and then not Can_Never_Be_Null
(Etype
(N
))
1332 and then not Error_Posted
(N
)
1334 Install_Null_Excluding_Check
(N
);
1337 end Apply_Constraint_Check
;
1339 ------------------------------
1340 -- Apply_Discriminant_Check --
1341 ------------------------------
1343 procedure Apply_Discriminant_Check
1346 Lhs
: Node_Id
:= Empty
)
1348 Loc
: constant Source_Ptr
:= Sloc
(N
);
1349 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1350 S_Typ
: Entity_Id
:= Etype
(N
);
1354 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean;
1355 -- A heap object with an indefinite subtype is constrained by its
1356 -- initial value, and assigning to it requires a constraint_check.
1357 -- The target may be an explicit dereference, or a renaming of one.
1359 function Is_Aliased_Unconstrained_Component
return Boolean;
1360 -- It is possible for an aliased component to have a nominal
1361 -- unconstrained subtype (through instantiation). If this is a
1362 -- discriminated component assigned in the expansion of an aggregate
1363 -- in an initialization, the check must be suppressed. This unusual
1364 -- situation requires a predicate of its own.
1366 ----------------------------------
1367 -- Denotes_Explicit_Dereference --
1368 ----------------------------------
1370 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean is
1373 Nkind
(Obj
) = N_Explicit_Dereference
1375 (Is_Entity_Name
(Obj
)
1376 and then Present
(Renamed_Object
(Entity
(Obj
)))
1377 and then Nkind
(Renamed_Object
(Entity
(Obj
))) =
1378 N_Explicit_Dereference
);
1379 end Denotes_Explicit_Dereference
;
1381 ----------------------------------------
1382 -- Is_Aliased_Unconstrained_Component --
1383 ----------------------------------------
1385 function Is_Aliased_Unconstrained_Component
return Boolean is
1390 if Nkind
(Lhs
) /= N_Selected_Component
then
1393 Comp
:= Entity
(Selector_Name
(Lhs
));
1394 Pref
:= Prefix
(Lhs
);
1397 if Ekind
(Comp
) /= E_Component
1398 or else not Is_Aliased
(Comp
)
1403 return not Comes_From_Source
(Pref
)
1404 and then In_Instance
1405 and then not Is_Constrained
(Etype
(Comp
));
1406 end Is_Aliased_Unconstrained_Component
;
1408 -- Start of processing for Apply_Discriminant_Check
1412 T_Typ
:= Designated_Type
(Typ
);
1417 -- Nothing to do if discriminant checks are suppressed or else no code
1418 -- is to be generated
1420 if not Full_Expander_Active
1421 or else Discriminant_Checks_Suppressed
(T_Typ
)
1426 -- No discriminant checks necessary for an access when expression is
1427 -- statically Null. This is not only an optimization, it is fundamental
1428 -- because otherwise discriminant checks may be generated in init procs
1429 -- for types containing an access to a not-yet-frozen record, causing a
1430 -- deadly forward reference.
1432 -- Also, if the expression is of an access type whose designated type is
1433 -- incomplete, then the access value must be null and we suppress the
1436 if Known_Null
(N
) then
1439 elsif Is_Access_Type
(S_Typ
) then
1440 S_Typ
:= Designated_Type
(S_Typ
);
1442 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1447 -- If an assignment target is present, then we need to generate the
1448 -- actual subtype if the target is a parameter or aliased object with
1449 -- an unconstrained nominal subtype.
1451 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1452 -- subtype to the parameter and dereference cases, since other aliased
1453 -- objects are unconstrained (unless the nominal subtype is explicitly
1457 and then (Present
(Param_Entity
(Lhs
))
1458 or else (Ada_Version
< Ada_2005
1459 and then not Is_Constrained
(T_Typ
)
1460 and then Is_Aliased_View
(Lhs
)
1461 and then not Is_Aliased_Unconstrained_Component
)
1462 or else (Ada_Version
>= Ada_2005
1463 and then not Is_Constrained
(T_Typ
)
1464 and then Denotes_Explicit_Dereference
(Lhs
)
1465 and then Nkind
(Original_Node
(Lhs
)) /=
1468 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1471 -- Nothing to do if the type is unconstrained (this is the case where
1472 -- the actual subtype in the RM sense of N is unconstrained and no check
1475 if not Is_Constrained
(T_Typ
) then
1478 -- Ada 2005: nothing to do if the type is one for which there is a
1479 -- partial view that is constrained.
1481 elsif Ada_Version
>= Ada_2005
1482 and then Effectively_Has_Constrained_Partial_View
1483 (Typ
=> Base_Type
(T_Typ
),
1484 Scop
=> Current_Scope
)
1489 -- Nothing to do if the type is an Unchecked_Union
1491 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
1495 -- Suppress checks if the subtypes are the same. the check must be
1496 -- preserved in an assignment to a formal, because the constraint is
1497 -- given by the actual.
1499 if Nkind
(Original_Node
(N
)) /= N_Allocator
1501 or else not Is_Entity_Name
(Lhs
)
1502 or else No
(Param_Entity
(Lhs
)))
1505 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1506 and then not Is_Aliased_View
(Lhs
)
1511 -- We can also eliminate checks on allocators with a subtype mark that
1512 -- coincides with the context type. The context type may be a subtype
1513 -- without a constraint (common case, a generic actual).
1515 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1516 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1519 Alloc_Typ
: constant Entity_Id
:=
1520 Entity
(Expression
(Original_Node
(N
)));
1523 if Alloc_Typ
= T_Typ
1524 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1525 and then Is_Entity_Name
(
1526 Subtype_Indication
(Parent
(T_Typ
)))
1527 and then Alloc_Typ
= Base_Type
(T_Typ
))
1535 -- See if we have a case where the types are both constrained, and all
1536 -- the constraints are constants. In this case, we can do the check
1537 -- successfully at compile time.
1539 -- We skip this check for the case where the node is rewritten`as
1540 -- an allocator, because it already carries the context subtype,
1541 -- and extracting the discriminants from the aggregate is messy.
1543 if Is_Constrained
(S_Typ
)
1544 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1554 -- S_Typ may not have discriminants in the case where it is a
1555 -- private type completed by a default discriminated type. In that
1556 -- case, we need to get the constraints from the underlying_type.
1557 -- If the underlying type is unconstrained (i.e. has no default
1558 -- discriminants) no check is needed.
1560 if Has_Discriminants
(S_Typ
) then
1561 Discr
:= First_Discriminant
(S_Typ
);
1562 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1565 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1568 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1574 -- A further optimization: if T_Typ is derived from S_Typ
1575 -- without imposing a constraint, no check is needed.
1577 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1578 N_Full_Type_Declaration
1581 Type_Def
: constant Node_Id
:=
1582 Type_Definition
(Original_Node
(Parent
(T_Typ
)));
1584 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1585 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1586 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1594 -- Constraint may appear in full view of type
1596 if Ekind
(T_Typ
) = E_Private_Subtype
1597 and then Present
(Full_View
(T_Typ
))
1600 First_Elmt
(Discriminant_Constraint
(Full_View
(T_Typ
)));
1603 First_Elmt
(Discriminant_Constraint
(T_Typ
));
1606 while Present
(Discr
) loop
1607 ItemS
:= Node
(DconS
);
1608 ItemT
:= Node
(DconT
);
1610 -- For a discriminated component type constrained by the
1611 -- current instance of an enclosing type, there is no
1612 -- applicable discriminant check.
1614 if Nkind
(ItemT
) = N_Attribute_Reference
1615 and then Is_Access_Type
(Etype
(ItemT
))
1616 and then Is_Entity_Name
(Prefix
(ItemT
))
1617 and then Is_Type
(Entity
(Prefix
(ItemT
)))
1622 -- If the expressions for the discriminants are identical
1623 -- and it is side-effect free (for now just an entity),
1624 -- this may be a shared constraint, e.g. from a subtype
1625 -- without a constraint introduced as a generic actual.
1626 -- Examine other discriminants if any.
1629 and then Is_Entity_Name
(ItemS
)
1633 elsif not Is_OK_Static_Expression
(ItemS
)
1634 or else not Is_OK_Static_Expression
(ItemT
)
1638 elsif Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1639 if Do_Access
then -- needs run-time check.
1642 Apply_Compile_Time_Constraint_Error
1643 (N
, "incorrect value for discriminant&??",
1644 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1651 Next_Discriminant
(Discr
);
1660 -- Here we need a discriminant check. First build the expression
1661 -- for the comparisons of the discriminants:
1663 -- (n.disc1 /= typ.disc1) or else
1664 -- (n.disc2 /= typ.disc2) or else
1666 -- (n.discn /= typ.discn)
1668 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1670 -- If Lhs is set and is a parameter, then the condition is guarded by:
1671 -- lhs'constrained and then (condition built above)
1673 if Present
(Param_Entity
(Lhs
)) then
1677 Make_Attribute_Reference
(Loc
,
1678 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1679 Attribute_Name
=> Name_Constrained
),
1680 Right_Opnd
=> Cond
);
1684 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1688 Make_Raise_Constraint_Error
(Loc
,
1690 Reason
=> CE_Discriminant_Check_Failed
));
1691 end Apply_Discriminant_Check
;
1693 -------------------------
1694 -- Apply_Divide_Checks --
1695 -------------------------
1697 procedure Apply_Divide_Checks
(N
: Node_Id
) is
1698 Loc
: constant Source_Ptr
:= Sloc
(N
);
1699 Typ
: constant Entity_Id
:= Etype
(N
);
1700 Left
: constant Node_Id
:= Left_Opnd
(N
);
1701 Right
: constant Node_Id
:= Right_Opnd
(N
);
1703 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1704 -- Current overflow checking mode
1714 pragma Warnings
(Off
, Lhi
);
1715 -- Don't actually use this value
1718 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1719 -- operating on signed integer types, then the only thing this routine
1720 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1721 -- procedure will (possibly later on during recursive downward calls),
1722 -- ensure that any needed overflow/division checks are properly applied.
1724 if Mode
in Minimized_Or_Eliminated
1725 and then Is_Signed_Integer_Type
(Typ
)
1727 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
1731 -- Proceed here in SUPPRESSED or CHECKED modes
1733 if Full_Expander_Active
1734 and then not Backend_Divide_Checks_On_Target
1735 and then Check_Needed
(Right
, Division_Check
)
1737 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
1739 -- Deal with division check
1741 if Do_Division_Check
(N
)
1742 and then not Division_Checks_Suppressed
(Typ
)
1744 Apply_Division_Check
(N
, Rlo
, Rhi
, ROK
);
1747 -- Deal with overflow check
1749 if Do_Overflow_Check
(N
)
1750 and then not Overflow_Checks_Suppressed
(Etype
(N
))
1753 -- Test for extremely annoying case of xxx'First divided by -1
1754 -- for division of signed integer types (only overflow case).
1756 if Nkind
(N
) = N_Op_Divide
1757 and then Is_Signed_Integer_Type
(Typ
)
1759 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
1760 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1762 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1764 ((not LOK
) or else (Llo
= LLB
))
1767 Make_Raise_Constraint_Error
(Loc
,
1773 Duplicate_Subexpr_Move_Checks
(Left
),
1774 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1778 Left_Opnd
=> Duplicate_Subexpr
(Right
),
1779 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1))),
1781 Reason
=> CE_Overflow_Check_Failed
));
1786 end Apply_Divide_Checks
;
1788 --------------------------
1789 -- Apply_Division_Check --
1790 --------------------------
1792 procedure Apply_Division_Check
1798 pragma Assert
(Do_Division_Check
(N
));
1800 Loc
: constant Source_Ptr
:= Sloc
(N
);
1801 Right
: constant Node_Id
:= Right_Opnd
(N
);
1804 if Full_Expander_Active
1805 and then not Backend_Divide_Checks_On_Target
1806 and then Check_Needed
(Right
, Division_Check
)
1808 -- See if division by zero possible, and if so generate test. This
1809 -- part of the test is not controlled by the -gnato switch, since
1810 -- it is a Division_Check and not an Overflow_Check.
1812 if Do_Division_Check
(N
) then
1813 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1815 Make_Raise_Constraint_Error
(Loc
,
1818 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1819 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1820 Reason
=> CE_Divide_By_Zero
));
1824 end Apply_Division_Check
;
1826 ----------------------------------
1827 -- Apply_Float_Conversion_Check --
1828 ----------------------------------
1830 -- Let F and I be the source and target types of the conversion. The RM
1831 -- specifies that a floating-point value X is rounded to the nearest
1832 -- integer, with halfway cases being rounded away from zero. The rounded
1833 -- value of X is checked against I'Range.
1835 -- The catch in the above paragraph is that there is no good way to know
1836 -- whether the round-to-integer operation resulted in overflow. A remedy is
1837 -- to perform a range check in the floating-point domain instead, however:
1839 -- (1) The bounds may not be known at compile time
1840 -- (2) The check must take into account rounding or truncation.
1841 -- (3) The range of type I may not be exactly representable in F.
1842 -- (4) For the rounding case, The end-points I'First - 0.5 and
1843 -- I'Last + 0.5 may or may not be in range, depending on the
1844 -- sign of I'First and I'Last.
1845 -- (5) X may be a NaN, which will fail any comparison
1847 -- The following steps correctly convert X with rounding:
1849 -- (1) If either I'First or I'Last is not known at compile time, use
1850 -- I'Base instead of I in the next three steps and perform a
1851 -- regular range check against I'Range after conversion.
1852 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1853 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1854 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1855 -- In other words, take one of the closest floating-point numbers
1856 -- (which is an integer value) to I'First, and see if it is in
1858 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1859 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1860 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1861 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1862 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1864 -- For the truncating case, replace steps (2) and (3) as follows:
1865 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1866 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1868 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1869 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1872 procedure Apply_Float_Conversion_Check
1874 Target_Typ
: Entity_Id
)
1876 LB
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1877 HB
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1878 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1879 Expr_Type
: constant Entity_Id
:= Base_Type
(Etype
(Ck_Node
));
1880 Target_Base
: constant Entity_Id
:=
1881 Implementation_Base_Type
(Target_Typ
);
1883 Par
: constant Node_Id
:= Parent
(Ck_Node
);
1884 pragma Assert
(Nkind
(Par
) = N_Type_Conversion
);
1885 -- Parent of check node, must be a type conversion
1887 Truncate
: constant Boolean := Float_Truncate
(Par
);
1888 Max_Bound
: constant Uint
:=
1890 (Machine_Radix_Value
(Expr_Type
),
1891 Machine_Mantissa_Value
(Expr_Type
) - 1) - 1;
1893 -- Largest bound, so bound plus or minus half is a machine number of F
1895 Ifirst
, Ilast
: Uint
;
1896 -- Bounds of integer type
1899 -- Bounds to check in floating-point domain
1901 Lo_OK
, Hi_OK
: Boolean;
1902 -- True iff Lo resp. Hi belongs to I'Range
1904 Lo_Chk
, Hi_Chk
: Node_Id
;
1905 -- Expressions that are False iff check fails
1907 Reason
: RT_Exception_Code
;
1910 if not Compile_Time_Known_Value
(LB
)
1911 or not Compile_Time_Known_Value
(HB
)
1914 -- First check that the value falls in the range of the base type,
1915 -- to prevent overflow during conversion and then perform a
1916 -- regular range check against the (dynamic) bounds.
1918 pragma Assert
(Target_Base
/= Target_Typ
);
1920 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Par
);
1923 Apply_Float_Conversion_Check
(Ck_Node
, Target_Base
);
1924 Set_Etype
(Temp
, Target_Base
);
1926 Insert_Action
(Parent
(Par
),
1927 Make_Object_Declaration
(Loc
,
1928 Defining_Identifier
=> Temp
,
1929 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
),
1930 Expression
=> New_Copy_Tree
(Par
)),
1931 Suppress
=> All_Checks
);
1934 Make_Raise_Constraint_Error
(Loc
,
1937 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
1938 Right_Opnd
=> New_Occurrence_Of
(Target_Typ
, Loc
)),
1939 Reason
=> CE_Range_Check_Failed
));
1940 Rewrite
(Par
, New_Occurrence_Of
(Temp
, Loc
));
1946 -- Get the (static) bounds of the target type
1948 Ifirst
:= Expr_Value
(LB
);
1949 Ilast
:= Expr_Value
(HB
);
1951 -- A simple optimization: if the expression is a universal literal,
1952 -- we can do the comparison with the bounds and the conversion to
1953 -- an integer type statically. The range checks are unchanged.
1955 if Nkind
(Ck_Node
) = N_Real_Literal
1956 and then Etype
(Ck_Node
) = Universal_Real
1957 and then Is_Integer_Type
(Target_Typ
)
1958 and then Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
1961 Int_Val
: constant Uint
:= UR_To_Uint
(Realval
(Ck_Node
));
1964 if Int_Val
<= Ilast
and then Int_Val
>= Ifirst
then
1966 -- Conversion is safe
1968 Rewrite
(Parent
(Ck_Node
),
1969 Make_Integer_Literal
(Loc
, UI_To_Int
(Int_Val
)));
1970 Analyze_And_Resolve
(Parent
(Ck_Node
), Target_Typ
);
1976 -- Check against lower bound
1978 if Truncate
and then Ifirst
> 0 then
1979 Lo
:= Pred
(Expr_Type
, UR_From_Uint
(Ifirst
));
1983 Lo
:= Succ
(Expr_Type
, UR_From_Uint
(Ifirst
- 1));
1986 elsif abs (Ifirst
) < Max_Bound
then
1987 Lo
:= UR_From_Uint
(Ifirst
) - Ureal_Half
;
1988 Lo_OK
:= (Ifirst
> 0);
1991 Lo
:= Machine
(Expr_Type
, UR_From_Uint
(Ifirst
), Round_Even
, Ck_Node
);
1992 Lo_OK
:= (Lo
>= UR_From_Uint
(Ifirst
));
1997 -- Lo_Chk := (X >= Lo)
1999 Lo_Chk
:= Make_Op_Ge
(Loc
,
2000 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2001 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2004 -- Lo_Chk := (X > Lo)
2006 Lo_Chk
:= Make_Op_Gt
(Loc
,
2007 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2008 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2011 -- Check against higher bound
2013 if Truncate
and then Ilast
< 0 then
2014 Hi
:= Succ
(Expr_Type
, UR_From_Uint
(Ilast
));
2018 Hi
:= Pred
(Expr_Type
, UR_From_Uint
(Ilast
+ 1));
2021 elsif abs (Ilast
) < Max_Bound
then
2022 Hi
:= UR_From_Uint
(Ilast
) + Ureal_Half
;
2023 Hi_OK
:= (Ilast
< 0);
2025 Hi
:= Machine
(Expr_Type
, UR_From_Uint
(Ilast
), Round_Even
, Ck_Node
);
2026 Hi_OK
:= (Hi
<= UR_From_Uint
(Ilast
));
2031 -- Hi_Chk := (X <= Hi)
2033 Hi_Chk
:= Make_Op_Le
(Loc
,
2034 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2035 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2038 -- Hi_Chk := (X < Hi)
2040 Hi_Chk
:= Make_Op_Lt
(Loc
,
2041 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2042 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2045 -- If the bounds of the target type are the same as those of the base
2046 -- type, the check is an overflow check as a range check is not
2047 -- performed in these cases.
2049 if Expr_Value
(Type_Low_Bound
(Target_Base
)) = Ifirst
2050 and then Expr_Value
(Type_High_Bound
(Target_Base
)) = Ilast
2052 Reason
:= CE_Overflow_Check_Failed
;
2054 Reason
:= CE_Range_Check_Failed
;
2057 -- Raise CE if either conditions does not hold
2059 Insert_Action
(Ck_Node
,
2060 Make_Raise_Constraint_Error
(Loc
,
2061 Condition
=> Make_Op_Not
(Loc
, Make_And_Then
(Loc
, Lo_Chk
, Hi_Chk
)),
2063 end Apply_Float_Conversion_Check
;
2065 ------------------------
2066 -- Apply_Length_Check --
2067 ------------------------
2069 procedure Apply_Length_Check
2071 Target_Typ
: Entity_Id
;
2072 Source_Typ
: Entity_Id
:= Empty
)
2075 Apply_Selected_Length_Checks
2076 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2077 end Apply_Length_Check
;
2079 -------------------------------------
2080 -- Apply_Parameter_Aliasing_Checks --
2081 -------------------------------------
2083 procedure Apply_Parameter_Aliasing_Checks
2087 function May_Cause_Aliasing
2088 (Formal_1
: Entity_Id
;
2089 Formal_2
: Entity_Id
) return Boolean;
2090 -- Determine whether two formal parameters can alias each other
2091 -- depending on their modes.
2093 function Original_Actual
(N
: Node_Id
) return Node_Id
;
2094 -- The expander may replace an actual with a temporary for the sake of
2095 -- side effect removal. The temporary may hide a potential aliasing as
2096 -- it does not share the address of the actual. This routine attempts
2097 -- to retrieve the original actual.
2099 ------------------------
2100 -- May_Cause_Aliasing --
2101 ------------------------
2103 function May_Cause_Aliasing
2104 (Formal_1
: Entity_Id
;
2105 Formal_2
: Entity_Id
) return Boolean
2108 -- The following combination cannot lead to aliasing
2110 -- Formal 1 Formal 2
2113 if Ekind
(Formal_1
) = E_In_Parameter
2115 Ekind
(Formal_2
) = E_In_Parameter
2119 -- The following combinations may lead to aliasing
2121 -- Formal 1 Formal 2
2131 end May_Cause_Aliasing
;
2133 ---------------------
2134 -- Original_Actual --
2135 ---------------------
2137 function Original_Actual
(N
: Node_Id
) return Node_Id
is
2139 if Nkind
(N
) = N_Type_Conversion
then
2140 return Expression
(N
);
2142 -- The expander created a temporary to capture the result of a type
2143 -- conversion where the expression is the real actual.
2145 elsif Nkind
(N
) = N_Identifier
2146 and then Present
(Original_Node
(N
))
2147 and then Nkind
(Original_Node
(N
)) = N_Type_Conversion
2149 return Expression
(Original_Node
(N
));
2153 end Original_Actual
;
2157 Loc
: constant Source_Ptr
:= Sloc
(Call
);
2162 Formal_1
: Entity_Id
;
2163 Formal_2
: Entity_Id
;
2165 -- Start of processing for Apply_Parameter_Aliasing_Checks
2170 Actual_1
:= First_Actual
(Call
);
2171 Formal_1
:= First_Formal
(Subp
);
2172 while Present
(Actual_1
) and then Present
(Formal_1
) loop
2174 -- Ensure that the actual is an object that is not passed by value.
2175 -- Elementary types are always passed by value, therefore actuals of
2176 -- such types cannot lead to aliasing.
2178 if Is_Object_Reference
(Original_Actual
(Actual_1
))
2179 and then not Is_Elementary_Type
(Etype
(Original_Actual
(Actual_1
)))
2181 Actual_2
:= Next_Actual
(Actual_1
);
2182 Formal_2
:= Next_Formal
(Formal_1
);
2183 while Present
(Actual_2
) and then Present
(Formal_2
) loop
2185 -- The other actual we are testing against must also denote
2186 -- a non pass-by-value object. Generate the check only when
2187 -- the mode of the two formals may lead to aliasing.
2189 if Is_Object_Reference
(Original_Actual
(Actual_2
))
2191 Is_Elementary_Type
(Etype
(Original_Actual
(Actual_2
)))
2192 and then May_Cause_Aliasing
(Formal_1
, Formal_2
)
2195 -- Actual_1'Overlaps_Storage (Actual_2)
2198 Make_Attribute_Reference
(Loc
,
2200 New_Copy_Tree
(Original_Actual
(Actual_1
)),
2201 Attribute_Name
=> Name_Overlaps_Storage
,
2203 New_List
(New_Copy_Tree
(Original_Actual
(Actual_2
))));
2211 Right_Opnd
=> Check
);
2215 Next_Actual
(Actual_2
);
2216 Next_Formal
(Formal_2
);
2220 Next_Actual
(Actual_1
);
2221 Next_Formal
(Formal_1
);
2224 -- Place the check right before the call
2226 if Present
(Cond
) then
2227 Insert_Action
(Call
,
2228 Make_Raise_Program_Error
(Loc
,
2230 Reason
=> PE_Explicit_Raise
));
2232 end Apply_Parameter_Aliasing_Checks
;
2234 -------------------------------------
2235 -- Apply_Parameter_Validity_Checks --
2236 -------------------------------------
2238 procedure Apply_Parameter_Validity_Checks
(Subp
: Entity_Id
) is
2239 Subp_Decl
: Node_Id
;
2241 procedure Add_Validity_Check
2242 (Context
: Entity_Id
;
2244 For_Result
: Boolean := False);
2245 -- Add a single 'Valid[_Scalar] check which verifies the initialization
2246 -- of Context. PPC_Nam denotes the pre or post condition pragma name.
2247 -- Set flag For_Result when to verify the result of a function.
2249 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
);
2250 -- Create a pre or post condition pragma with name PPC_Nam which
2251 -- tests expression Check.
2253 ------------------------
2254 -- Add_Validity_Check --
2255 ------------------------
2257 procedure Add_Validity_Check
2258 (Context
: Entity_Id
;
2260 For_Result
: Boolean := False)
2262 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2263 Typ
: constant Entity_Id
:= Etype
(Context
);
2268 -- Pick the proper version of 'Valid depending on the type of the
2269 -- context. If the context is not eligible for such a check, return.
2271 if Is_Scalar_Type
(Typ
) then
2273 elsif not No_Scalar_Parts
(Typ
) then
2274 Nam
:= Name_Valid_Scalars
;
2279 -- Step 1: Create the expression to verify the validity of the
2282 Check
:= New_Reference_To
(Context
, Loc
);
2284 -- When processing a function result, use 'Result. Generate
2289 Make_Attribute_Reference
(Loc
,
2291 Attribute_Name
=> Name_Result
);
2295 -- Context['Result]'Valid[_Scalars]
2298 Make_Attribute_Reference
(Loc
,
2300 Attribute_Name
=> Nam
);
2302 -- Step 2: Create a pre or post condition pragma
2304 Build_PPC_Pragma
(PPC_Nam
, Check
);
2305 end Add_Validity_Check
;
2307 ----------------------
2308 -- Build_PPC_Pragma --
2309 ----------------------
2311 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
) is
2312 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2319 Pragma_Identifier
=> Make_Identifier
(Loc
, PPC_Nam
),
2320 Pragma_Argument_Associations
=> New_List
(
2321 Make_Pragma_Argument_Association
(Loc
,
2322 Chars
=> Name_Check
,
2323 Expression
=> Check
)));
2325 -- Add a message unless exception messages are suppressed
2327 if not Exception_Locations_Suppressed
then
2328 Append_To
(Pragma_Argument_Associations
(Prag
),
2329 Make_Pragma_Argument_Association
(Loc
,
2330 Chars
=> Name_Message
,
2332 Make_String_Literal
(Loc
,
2333 Strval
=> "failed " & Get_Name_String
(PPC_Nam
) &
2334 " from " & Build_Location_String
(Loc
))));
2337 -- Insert the pragma in the tree
2339 if Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
then
2340 Add_Global_Declaration
(Prag
);
2343 -- PPC pragmas associated with subprogram bodies must be inserted in
2344 -- the declarative part of the body.
2346 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
then
2347 Decls
:= Declarations
(Subp_Decl
);
2351 Set_Declarations
(Subp_Decl
, Decls
);
2354 Prepend_To
(Decls
, Prag
);
2356 -- Ensure the proper visibility of the subprogram body and its
2363 -- For subprogram declarations insert the PPC pragma right after the
2364 -- declarative node.
2367 Insert_After_And_Analyze
(Subp_Decl
, Prag
);
2369 end Build_PPC_Pragma
;
2374 Subp_Spec
: Node_Id
;
2376 -- Start of processing for Apply_Parameter_Validity_Checks
2379 -- Extract the subprogram specification and declaration nodes
2381 Subp_Spec
:= Parent
(Subp
);
2383 if Nkind
(Subp_Spec
) = N_Defining_Program_Unit_Name
then
2384 Subp_Spec
:= Parent
(Subp_Spec
);
2387 Subp_Decl
:= Parent
(Subp_Spec
);
2389 if not Comes_From_Source
(Subp
)
2391 -- Do not process formal subprograms because the corresponding actual
2392 -- will receive the proper checks when the instance is analyzed.
2394 or else Is_Formal_Subprogram
(Subp
)
2396 -- Do not process imported subprograms since pre and post conditions
2397 -- are never verified on routines coming from a different language.
2399 or else Is_Imported
(Subp
)
2400 or else Is_Intrinsic_Subprogram
(Subp
)
2402 -- The PPC pragmas generated by this routine do not correspond to
2403 -- source aspects, therefore they cannot be applied to abstract
2406 or else Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
2408 -- Do not consider subprogram renaminds because the renamed entity
2409 -- already has the proper PPC pragmas.
2411 or else Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
2413 -- Do not process null procedures because there is no benefit of
2414 -- adding the checks to a no action routine.
2416 or else (Nkind
(Subp_Spec
) = N_Procedure_Specification
2417 and then Null_Present
(Subp_Spec
))
2422 -- Inspect all the formals applying aliasing and scalar initialization
2423 -- checks where applicable.
2425 Formal
:= First_Formal
(Subp
);
2426 while Present
(Formal
) loop
2428 -- Generate the following scalar initialization checks for each
2429 -- formal parameter:
2431 -- mode IN - Pre => Formal'Valid[_Scalars]
2432 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2433 -- mode OUT - Post => Formal'Valid[_Scalars]
2435 if Check_Validity_Of_Parameters
then
2436 if Ekind_In
(Formal
, E_In_Parameter
, E_In_Out_Parameter
) then
2437 Add_Validity_Check
(Formal
, Name_Precondition
, False);
2440 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
2441 Add_Validity_Check
(Formal
, Name_Postcondition
, False);
2445 Next_Formal
(Formal
);
2448 -- Generate following scalar initialization check for function result:
2450 -- Post => Subp'Result'Valid[_Scalars]
2452 if Check_Validity_Of_Parameters
and then Ekind
(Subp
) = E_Function
then
2453 Add_Validity_Check
(Subp
, Name_Postcondition
, True);
2455 end Apply_Parameter_Validity_Checks
;
2457 ---------------------------
2458 -- Apply_Predicate_Check --
2459 ---------------------------
2461 procedure Apply_Predicate_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
2465 if Present
(Predicate_Function
(Typ
)) then
2467 -- A predicate check does not apply within internally generated
2468 -- subprograms, such as TSS functions.
2471 while Present
(S
) and then not Is_Subprogram
(S
) loop
2475 if Present
(S
) and then Get_TSS_Name
(S
) /= TSS_Null
then
2478 -- If the check appears within the predicate function itself, it
2479 -- means that the user specified a check whose formal is the
2480 -- predicated subtype itself, rather than some covering type. This
2481 -- is likely to be a common error, and thus deserves a warning.
2483 elsif S
= Predicate_Function
(Typ
) then
2485 ("predicate check includes a function call that "
2486 & "requires a predicate check??", Parent
(N
));
2488 ("\this will result in infinite recursion??", Parent
(N
));
2490 Make_Raise_Storage_Error
(Sloc
(N
),
2491 Reason
=> SE_Infinite_Recursion
));
2493 -- Here for normal case of predicate active.
2496 -- If the predicate is a static predicate and the operand is
2497 -- static, the predicate must be evaluated statically. If the
2498 -- evaluation fails this is a static constraint error. This check
2499 -- is disabled in -gnatc mode, because the compiler is incapable
2500 -- of evaluating static expressions in that case.
2502 if Is_OK_Static_Expression
(N
) then
2503 if Present
(Static_Predicate
(Typ
)) then
2504 if Operating_Mode
< Generate_Code
2505 or else Eval_Static_Predicate_Check
(N
, Typ
)
2510 ("static expression fails static predicate check on&",
2517 Make_Predicate_Check
(Typ
, Duplicate_Subexpr
(N
)));
2520 end Apply_Predicate_Check
;
2522 -----------------------
2523 -- Apply_Range_Check --
2524 -----------------------
2526 procedure Apply_Range_Check
2528 Target_Typ
: Entity_Id
;
2529 Source_Typ
: Entity_Id
:= Empty
)
2532 Apply_Selected_Range_Checks
2533 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2534 end Apply_Range_Check
;
2536 ------------------------------
2537 -- Apply_Scalar_Range_Check --
2538 ------------------------------
2540 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
2541 -- off if it is already set on.
2543 procedure Apply_Scalar_Range_Check
2545 Target_Typ
: Entity_Id
;
2546 Source_Typ
: Entity_Id
:= Empty
;
2547 Fixed_Int
: Boolean := False)
2549 Parnt
: constant Node_Id
:= Parent
(Expr
);
2551 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
2552 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
2555 Is_Subscr_Ref
: Boolean;
2556 -- Set true if Expr is a subscript
2558 Is_Unconstrained_Subscr_Ref
: Boolean;
2559 -- Set true if Expr is a subscript of an unconstrained array. In this
2560 -- case we do not attempt to do an analysis of the value against the
2561 -- range of the subscript, since we don't know the actual subtype.
2564 -- Set to True if Expr should be regarded as a real value even though
2565 -- the type of Expr might be discrete.
2567 procedure Bad_Value
;
2568 -- Procedure called if value is determined to be out of range
2574 procedure Bad_Value
is
2576 Apply_Compile_Time_Constraint_Error
2577 (Expr
, "value not in range of}??", CE_Range_Check_Failed
,
2582 -- Start of processing for Apply_Scalar_Range_Check
2585 -- Return if check obviously not needed
2588 -- Not needed inside generic
2592 -- Not needed if previous error
2594 or else Target_Typ
= Any_Type
2595 or else Nkind
(Expr
) = N_Error
2597 -- Not needed for non-scalar type
2599 or else not Is_Scalar_Type
(Target_Typ
)
2601 -- Not needed if we know node raises CE already
2603 or else Raises_Constraint_Error
(Expr
)
2608 -- Now, see if checks are suppressed
2611 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
2613 if Is_Subscr_Ref
then
2614 Arr
:= Prefix
(Parnt
);
2615 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
2617 if Is_Access_Type
(Arr_Typ
) then
2618 Arr_Typ
:= Designated_Type
(Arr_Typ
);
2622 if not Do_Range_Check
(Expr
) then
2624 -- Subscript reference. Check for Index_Checks suppressed
2626 if Is_Subscr_Ref
then
2628 -- Check array type and its base type
2630 if Index_Checks_Suppressed
(Arr_Typ
)
2631 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
2635 -- Check array itself if it is an entity name
2637 elsif Is_Entity_Name
(Arr
)
2638 and then Index_Checks_Suppressed
(Entity
(Arr
))
2642 -- Check expression itself if it is an entity name
2644 elsif Is_Entity_Name
(Expr
)
2645 and then Index_Checks_Suppressed
(Entity
(Expr
))
2650 -- All other cases, check for Range_Checks suppressed
2653 -- Check target type and its base type
2655 if Range_Checks_Suppressed
(Target_Typ
)
2656 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
2660 -- Check expression itself if it is an entity name
2662 elsif Is_Entity_Name
(Expr
)
2663 and then Range_Checks_Suppressed
(Entity
(Expr
))
2667 -- If Expr is part of an assignment statement, then check left
2668 -- side of assignment if it is an entity name.
2670 elsif Nkind
(Parnt
) = N_Assignment_Statement
2671 and then Is_Entity_Name
(Name
(Parnt
))
2672 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
2679 -- Do not set range checks if they are killed
2681 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
2682 and then Kill_Range_Check
(Expr
)
2687 -- Do not set range checks for any values from System.Scalar_Values
2688 -- since the whole idea of such values is to avoid checking them!
2690 if Is_Entity_Name
(Expr
)
2691 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
2696 -- Now see if we need a check
2698 if No
(Source_Typ
) then
2699 S_Typ
:= Etype
(Expr
);
2701 S_Typ
:= Source_Typ
;
2704 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
2708 Is_Unconstrained_Subscr_Ref
:=
2709 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
2711 -- Special checks for floating-point type
2713 if Is_Floating_Point_Type
(S_Typ
) then
2715 -- Always do a range check if the source type includes infinities and
2716 -- the target type does not include infinities. We do not do this if
2717 -- range checks are killed.
2719 if Has_Infinities
(S_Typ
)
2720 and then not Has_Infinities
(Target_Typ
)
2722 Enable_Range_Check
(Expr
);
2724 -- Always do a range check for operators if option set
2726 elsif Check_Float_Overflow
and then Nkind
(Expr
) in N_Op
then
2727 Enable_Range_Check
(Expr
);
2731 -- Return if we know expression is definitely in the range of the target
2732 -- type as determined by Determine_Range. Right now we only do this for
2733 -- discrete types, and not fixed-point or floating-point types.
2735 -- The additional less-precise tests below catch these cases
2737 -- Note: skip this if we are given a source_typ, since the point of
2738 -- supplying a Source_Typ is to stop us looking at the expression.
2739 -- We could sharpen this test to be out parameters only ???
2741 if Is_Discrete_Type
(Target_Typ
)
2742 and then Is_Discrete_Type
(Etype
(Expr
))
2743 and then not Is_Unconstrained_Subscr_Ref
2744 and then No
(Source_Typ
)
2747 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
2748 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
2753 if Compile_Time_Known_Value
(Tlo
)
2754 and then Compile_Time_Known_Value
(Thi
)
2757 Lov
: constant Uint
:= Expr_Value
(Tlo
);
2758 Hiv
: constant Uint
:= Expr_Value
(Thi
);
2761 -- If range is null, we for sure have a constraint error
2762 -- (we don't even need to look at the value involved,
2763 -- since all possible values will raise CE).
2770 -- Otherwise determine range of value
2772 Determine_Range
(Expr
, OK
, Lo
, Hi
, Assume_Valid
=> True);
2776 -- If definitely in range, all OK
2778 if Lo
>= Lov
and then Hi
<= Hiv
then
2781 -- If definitely not in range, warn
2783 elsif Lov
> Hi
or else Hiv
< Lo
then
2787 -- Otherwise we don't know
2799 Is_Floating_Point_Type
(S_Typ
)
2800 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
2802 -- Check if we can determine at compile time whether Expr is in the
2803 -- range of the target type. Note that if S_Typ is within the bounds
2804 -- of Target_Typ then this must be the case. This check is meaningful
2805 -- only if this is not a conversion between integer and real types.
2807 if not Is_Unconstrained_Subscr_Ref
2808 and then Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
2810 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
2812 Is_In_Range
(Expr
, Target_Typ
,
2813 Assume_Valid
=> True,
2814 Fixed_Int
=> Fixed_Int
,
2815 Int_Real
=> Int_Real
))
2819 elsif Is_Out_Of_Range
(Expr
, Target_Typ
,
2820 Assume_Valid
=> True,
2821 Fixed_Int
=> Fixed_Int
,
2822 Int_Real
=> Int_Real
)
2827 -- Floating-point case
2828 -- In the floating-point case, we only do range checks if the type is
2829 -- constrained. We definitely do NOT want range checks for unconstrained
2830 -- types, since we want to have infinities
2832 elsif Is_Floating_Point_Type
(S_Typ
) then
2834 -- Normally, we only do range checks if the type is constrained. We do
2835 -- NOT want range checks for unconstrained types, since we want to have
2836 -- infinities. Override this decision in Check_Float_Overflow mode.
2838 if Is_Constrained
(S_Typ
) or else Check_Float_Overflow
then
2839 Enable_Range_Check
(Expr
);
2842 -- For all other cases we enable a range check unconditionally
2845 Enable_Range_Check
(Expr
);
2848 end Apply_Scalar_Range_Check
;
2850 ----------------------------------
2851 -- Apply_Selected_Length_Checks --
2852 ----------------------------------
2854 procedure Apply_Selected_Length_Checks
2856 Target_Typ
: Entity_Id
;
2857 Source_Typ
: Entity_Id
;
2858 Do_Static
: Boolean)
2861 R_Result
: Check_Result
;
2864 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
2865 Checks_On
: constant Boolean :=
2866 (not Index_Checks_Suppressed
(Target_Typ
))
2867 or else (not Length_Checks_Suppressed
(Target_Typ
));
2870 if not Full_Expander_Active
then
2875 Selected_Length_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
2877 for J
in 1 .. 2 loop
2878 R_Cno
:= R_Result
(J
);
2879 exit when No
(R_Cno
);
2881 -- A length check may mention an Itype which is attached to a
2882 -- subsequent node. At the top level in a package this can cause
2883 -- an order-of-elaboration problem, so we make sure that the itype
2884 -- is referenced now.
2886 if Ekind
(Current_Scope
) = E_Package
2887 and then Is_Compilation_Unit
(Current_Scope
)
2889 Ensure_Defined
(Target_Typ
, Ck_Node
);
2891 if Present
(Source_Typ
) then
2892 Ensure_Defined
(Source_Typ
, Ck_Node
);
2894 elsif Is_Itype
(Etype
(Ck_Node
)) then
2895 Ensure_Defined
(Etype
(Ck_Node
), Ck_Node
);
2899 -- If the item is a conditional raise of constraint error, then have
2900 -- a look at what check is being performed and ???
2902 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
2903 and then Present
(Condition
(R_Cno
))
2905 Cond
:= Condition
(R_Cno
);
2907 -- Case where node does not now have a dynamic check
2909 if not Has_Dynamic_Length_Check
(Ck_Node
) then
2911 -- If checks are on, just insert the check
2914 Insert_Action
(Ck_Node
, R_Cno
);
2916 if not Do_Static
then
2917 Set_Has_Dynamic_Length_Check
(Ck_Node
);
2920 -- If checks are off, then analyze the length check after
2921 -- temporarily attaching it to the tree in case the relevant
2922 -- condition can be evaluated at compile time. We still want a
2923 -- compile time warning in this case.
2926 Set_Parent
(R_Cno
, Ck_Node
);
2931 -- Output a warning if the condition is known to be True
2933 if Is_Entity_Name
(Cond
)
2934 and then Entity
(Cond
) = Standard_True
2936 Apply_Compile_Time_Constraint_Error
2937 (Ck_Node
, "wrong length for array of}??",
2938 CE_Length_Check_Failed
,
2942 -- If we were only doing a static check, or if checks are not
2943 -- on, then we want to delete the check, since it is not needed.
2944 -- We do this by replacing the if statement by a null statement
2946 elsif Do_Static
or else not Checks_On
then
2947 Remove_Warning_Messages
(R_Cno
);
2948 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
2952 Install_Static_Check
(R_Cno
, Loc
);
2955 end Apply_Selected_Length_Checks
;
2957 ---------------------------------
2958 -- Apply_Selected_Range_Checks --
2959 ---------------------------------
2961 procedure Apply_Selected_Range_Checks
2963 Target_Typ
: Entity_Id
;
2964 Source_Typ
: Entity_Id
;
2965 Do_Static
: Boolean)
2968 R_Result
: Check_Result
;
2971 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
2972 Checks_On
: constant Boolean :=
2973 (not Index_Checks_Suppressed
(Target_Typ
))
2974 or else (not Range_Checks_Suppressed
(Target_Typ
));
2977 if not Full_Expander_Active
or else not Checks_On
then
2982 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
2984 for J
in 1 .. 2 loop
2986 R_Cno
:= R_Result
(J
);
2987 exit when No
(R_Cno
);
2989 -- If the item is a conditional raise of constraint error, then have
2990 -- a look at what check is being performed and ???
2992 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
2993 and then Present
(Condition
(R_Cno
))
2995 Cond
:= Condition
(R_Cno
);
2997 if not Has_Dynamic_Range_Check
(Ck_Node
) then
2998 Insert_Action
(Ck_Node
, R_Cno
);
3000 if not Do_Static
then
3001 Set_Has_Dynamic_Range_Check
(Ck_Node
);
3005 -- Output a warning if the condition is known to be True
3007 if Is_Entity_Name
(Cond
)
3008 and then Entity
(Cond
) = Standard_True
3010 -- Since an N_Range is technically not an expression, we have
3011 -- to set one of the bounds to C_E and then just flag the
3012 -- N_Range. The warning message will point to the lower bound
3013 -- and complain about a range, which seems OK.
3015 if Nkind
(Ck_Node
) = N_Range
then
3016 Apply_Compile_Time_Constraint_Error
3017 (Low_Bound
(Ck_Node
), "static range out of bounds of}??",
3018 CE_Range_Check_Failed
,
3022 Set_Raises_Constraint_Error
(Ck_Node
);
3025 Apply_Compile_Time_Constraint_Error
3026 (Ck_Node
, "static value out of range of}?",
3027 CE_Range_Check_Failed
,
3032 -- If we were only doing a static check, or if checks are not
3033 -- on, then we want to delete the check, since it is not needed.
3034 -- We do this by replacing the if statement by a null statement
3036 elsif Do_Static
or else not Checks_On
then
3037 Remove_Warning_Messages
(R_Cno
);
3038 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3042 Install_Static_Check
(R_Cno
, Loc
);
3045 end Apply_Selected_Range_Checks
;
3047 -------------------------------
3048 -- Apply_Static_Length_Check --
3049 -------------------------------
3051 procedure Apply_Static_Length_Check
3053 Target_Typ
: Entity_Id
;
3054 Source_Typ
: Entity_Id
:= Empty
)
3057 Apply_Selected_Length_Checks
3058 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
3059 end Apply_Static_Length_Check
;
3061 -------------------------------------
3062 -- Apply_Subscript_Validity_Checks --
3063 -------------------------------------
3065 procedure Apply_Subscript_Validity_Checks
(Expr
: Node_Id
) is
3069 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
3071 -- Loop through subscripts
3073 Sub
:= First
(Expressions
(Expr
));
3074 while Present
(Sub
) loop
3076 -- Check one subscript. Note that we do not worry about enumeration
3077 -- type with holes, since we will convert the value to a Pos value
3078 -- for the subscript, and that convert will do the necessary validity
3081 Ensure_Valid
(Sub
, Holes_OK
=> True);
3083 -- Move to next subscript
3087 end Apply_Subscript_Validity_Checks
;
3089 ----------------------------------
3090 -- Apply_Type_Conversion_Checks --
3091 ----------------------------------
3093 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
3094 Target_Type
: constant Entity_Id
:= Etype
(N
);
3095 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
3096 Expr
: constant Node_Id
:= Expression
(N
);
3098 Expr_Type
: constant Entity_Id
:= Underlying_Type
(Etype
(Expr
));
3099 -- Note: if Etype (Expr) is a private type without discriminants, its
3100 -- full view might have discriminants with defaults, so we need the
3101 -- full view here to retrieve the constraints.
3104 if Inside_A_Generic
then
3107 -- Skip these checks if serious errors detected, there are some nasty
3108 -- situations of incomplete trees that blow things up.
3110 elsif Serious_Errors_Detected
> 0 then
3113 -- Scalar type conversions of the form Target_Type (Expr) require a
3114 -- range check if we cannot be sure that Expr is in the base type of
3115 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3116 -- are not quite the same condition from an implementation point of
3117 -- view, but clearly the second includes the first.
3119 elsif Is_Scalar_Type
(Target_Type
) then
3121 Conv_OK
: constant Boolean := Conversion_OK
(N
);
3122 -- If the Conversion_OK flag on the type conversion is set and no
3123 -- floating point type is involved in the type conversion then
3124 -- fixed point values must be read as integral values.
3126 Float_To_Int
: constant Boolean :=
3127 Is_Floating_Point_Type
(Expr_Type
)
3128 and then Is_Integer_Type
(Target_Type
);
3131 if not Overflow_Checks_Suppressed
(Target_Base
)
3132 and then not Overflow_Checks_Suppressed
(Target_Type
)
3134 In_Subrange_Of
(Expr_Type
, Target_Base
, Fixed_Int
=> Conv_OK
)
3135 and then not Float_To_Int
3137 Activate_Overflow_Check
(N
);
3140 if not Range_Checks_Suppressed
(Target_Type
)
3141 and then not Range_Checks_Suppressed
(Expr_Type
)
3143 if Float_To_Int
then
3144 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
3146 Apply_Scalar_Range_Check
3147 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
3149 -- If the target type has predicates, we need to indicate
3150 -- the need for a check, even if Determine_Range finds
3151 -- that the value is within bounds. This may be the case
3152 -- e.g for a division with a constant denominator.
3154 if Has_Predicates
(Target_Type
) then
3155 Enable_Range_Check
(Expr
);
3161 elsif Comes_From_Source
(N
)
3162 and then not Discriminant_Checks_Suppressed
(Target_Type
)
3163 and then Is_Record_Type
(Target_Type
)
3164 and then Is_Derived_Type
(Target_Type
)
3165 and then not Is_Tagged_Type
(Target_Type
)
3166 and then not Is_Constrained
(Target_Type
)
3167 and then Present
(Stored_Constraint
(Target_Type
))
3169 -- An unconstrained derived type may have inherited discriminant.
3170 -- Build an actual discriminant constraint list using the stored
3171 -- constraint, to verify that the expression of the parent type
3172 -- satisfies the constraints imposed by the (unconstrained!)
3173 -- derived type. This applies to value conversions, not to view
3174 -- conversions of tagged types.
3177 Loc
: constant Source_Ptr
:= Sloc
(N
);
3179 Constraint
: Elmt_Id
;
3180 Discr_Value
: Node_Id
;
3183 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
3184 Old_Constraints
: constant Elist_Id
:=
3185 Discriminant_Constraint
(Expr_Type
);
3188 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
3189 while Present
(Constraint
) loop
3190 Discr_Value
:= Node
(Constraint
);
3192 if Is_Entity_Name
(Discr_Value
)
3193 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
3195 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
3198 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
3200 -- Parent is constrained by new discriminant. Obtain
3201 -- Value of original discriminant in expression. If the
3202 -- new discriminant has been used to constrain more than
3203 -- one of the stored discriminants, this will provide the
3204 -- required consistency check.
3207 (Make_Selected_Component
(Loc
,
3209 Duplicate_Subexpr_No_Checks
3210 (Expr
, Name_Req
=> True),
3212 Make_Identifier
(Loc
, Chars
(Discr
))),
3216 -- Discriminant of more remote ancestor ???
3221 -- Derived type definition has an explicit value for this
3222 -- stored discriminant.
3226 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
3230 Next_Elmt
(Constraint
);
3233 -- Use the unconstrained expression type to retrieve the
3234 -- discriminants of the parent, and apply momentarily the
3235 -- discriminant constraint synthesized above.
3237 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
3238 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
3239 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
3242 Make_Raise_Constraint_Error
(Loc
,
3244 Reason
=> CE_Discriminant_Check_Failed
));
3247 -- For arrays, conversions are applied during expansion, to take into
3248 -- accounts changes of representation. The checks become range checks on
3249 -- the base type or length checks on the subtype, depending on whether
3250 -- the target type is unconstrained or constrained.
3255 end Apply_Type_Conversion_Checks
;
3257 ----------------------------------------------
3258 -- Apply_Universal_Integer_Attribute_Checks --
3259 ----------------------------------------------
3261 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
3262 Loc
: constant Source_Ptr
:= Sloc
(N
);
3263 Typ
: constant Entity_Id
:= Etype
(N
);
3266 if Inside_A_Generic
then
3269 -- Nothing to do if checks are suppressed
3271 elsif Range_Checks_Suppressed
(Typ
)
3272 and then Overflow_Checks_Suppressed
(Typ
)
3276 -- Nothing to do if the attribute does not come from source. The
3277 -- internal attributes we generate of this type do not need checks,
3278 -- and furthermore the attempt to check them causes some circular
3279 -- elaboration orders when dealing with packed types.
3281 elsif not Comes_From_Source
(N
) then
3284 -- If the prefix is a selected component that depends on a discriminant
3285 -- the check may improperly expose a discriminant instead of using
3286 -- the bounds of the object itself. Set the type of the attribute to
3287 -- the base type of the context, so that a check will be imposed when
3288 -- needed (e.g. if the node appears as an index).
3290 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
3291 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
3292 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
3294 Set_Etype
(N
, Base_Type
(Typ
));
3296 -- Otherwise, replace the attribute node with a type conversion node
3297 -- whose expression is the attribute, retyped to universal integer, and
3298 -- whose subtype mark is the target type. The call to analyze this
3299 -- conversion will set range and overflow checks as required for proper
3300 -- detection of an out of range value.
3303 Set_Etype
(N
, Universal_Integer
);
3304 Set_Analyzed
(N
, True);
3307 Make_Type_Conversion
(Loc
,
3308 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
3309 Expression
=> Relocate_Node
(N
)));
3311 Analyze_And_Resolve
(N
, Typ
);
3314 end Apply_Universal_Integer_Attribute_Checks
;
3316 -------------------------------------
3317 -- Atomic_Synchronization_Disabled --
3318 -------------------------------------
3320 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3321 -- using a bogus check called Atomic_Synchronization. This is to make it
3322 -- more convenient to get exactly the same semantics as [Un]Suppress.
3324 function Atomic_Synchronization_Disabled
(E
: Entity_Id
) return Boolean is
3326 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3327 -- looks enabled, since it is never disabled.
3329 if Debug_Flag_Dot_E
then
3332 -- If debug flag d.d is set then always return True, i.e. all atomic
3333 -- sync looks disabled, since it always tests True.
3335 elsif Debug_Flag_Dot_D
then
3338 -- If entity present, then check result for that entity
3340 elsif Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3341 return Is_Check_Suppressed
(E
, Atomic_Synchronization
);
3343 -- Otherwise result depends on current scope setting
3346 return Scope_Suppress
.Suppress
(Atomic_Synchronization
);
3348 end Atomic_Synchronization_Disabled
;
3350 -------------------------------
3351 -- Build_Discriminant_Checks --
3352 -------------------------------
3354 function Build_Discriminant_Checks
3356 T_Typ
: Entity_Id
) return Node_Id
3358 Loc
: constant Source_Ptr
:= Sloc
(N
);
3361 Disc_Ent
: Entity_Id
;
3365 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
;
3367 ----------------------------------
3368 -- Aggregate_Discriminant_Value --
3369 ----------------------------------
3371 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
is
3375 -- The aggregate has been normalized with named associations. We use
3376 -- the Chars field to locate the discriminant to take into account
3377 -- discriminants in derived types, which carry the same name as those
3380 Assoc
:= First
(Component_Associations
(N
));
3381 while Present
(Assoc
) loop
3382 if Chars
(First
(Choices
(Assoc
))) = Chars
(Disc
) then
3383 return Expression
(Assoc
);
3389 -- Discriminant must have been found in the loop above
3391 raise Program_Error
;
3392 end Aggregate_Discriminant_Val
;
3394 -- Start of processing for Build_Discriminant_Checks
3397 -- Loop through discriminants evolving the condition
3400 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
3402 -- For a fully private type, use the discriminants of the parent type
3404 if Is_Private_Type
(T_Typ
)
3405 and then No
(Full_View
(T_Typ
))
3407 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
3409 Disc_Ent
:= First_Discriminant
(T_Typ
);
3412 while Present
(Disc
) loop
3413 Dval
:= Node
(Disc
);
3415 if Nkind
(Dval
) = N_Identifier
3416 and then Ekind
(Entity
(Dval
)) = E_Discriminant
3418 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
3420 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
3423 -- If we have an Unchecked_Union node, we can infer the discriminants
3426 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
3428 Get_Discriminant_Value
(
3429 First_Discriminant
(T_Typ
),
3431 Stored_Constraint
(T_Typ
)));
3433 elsif Nkind
(N
) = N_Aggregate
then
3435 Duplicate_Subexpr_No_Checks
3436 (Aggregate_Discriminant_Val
(Disc_Ent
));
3440 Make_Selected_Component
(Loc
,
3442 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
3444 Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
3446 Set_Is_In_Discriminant_Check
(Dref
);
3449 Evolve_Or_Else
(Cond
,
3452 Right_Opnd
=> Dval
));
3455 Next_Discriminant
(Disc_Ent
);
3459 end Build_Discriminant_Checks
;
3465 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
3473 -- Always check if not simple entity
3475 if Nkind
(Nod
) not in N_Has_Entity
3476 or else not Comes_From_Source
(Nod
)
3481 -- Look up tree for short circuit
3488 -- Done if out of subexpression (note that we allow generated stuff
3489 -- such as itype declarations in this context, to keep the loop going
3490 -- since we may well have generated such stuff in complex situations.
3491 -- Also done if no parent (probably an error condition, but no point
3492 -- in behaving nasty if we find it!)
3495 or else (K
not in N_Subexpr
and then Comes_From_Source
(P
))
3499 -- Or/Or Else case, where test is part of the right operand, or is
3500 -- part of one of the actions associated with the right operand, and
3501 -- the left operand is an equality test.
3503 elsif K
= N_Op_Or
then
3504 exit when N
= Right_Opnd
(P
)
3505 and then Nkind
(Left_Opnd
(P
)) = N_Op_Eq
;
3507 elsif K
= N_Or_Else
then
3508 exit when (N
= Right_Opnd
(P
)
3511 and then List_Containing
(N
) = Actions
(P
)))
3512 and then Nkind
(Left_Opnd
(P
)) = N_Op_Eq
;
3514 -- Similar test for the And/And then case, where the left operand
3515 -- is an inequality test.
3517 elsif K
= N_Op_And
then
3518 exit when N
= Right_Opnd
(P
)
3519 and then Nkind
(Left_Opnd
(P
)) = N_Op_Ne
;
3521 elsif K
= N_And_Then
then
3522 exit when (N
= Right_Opnd
(P
)
3525 and then List_Containing
(N
) = Actions
(P
)))
3526 and then Nkind
(Left_Opnd
(P
)) = N_Op_Ne
;
3532 -- If we fall through the loop, then we have a conditional with an
3533 -- appropriate test as its left operand. So test further.
3536 R
:= Right_Opnd
(L
);
3539 -- Left operand of test must match original variable
3541 if Nkind
(L
) not in N_Has_Entity
3542 or else Entity
(L
) /= Entity
(Nod
)
3547 -- Right operand of test must be key value (zero or null)
3550 when Access_Check
=>
3551 if not Known_Null
(R
) then
3555 when Division_Check
=>
3556 if not Compile_Time_Known_Value
(R
)
3557 or else Expr_Value
(R
) /= Uint_0
3563 raise Program_Error
;
3566 -- Here we have the optimizable case, warn if not short-circuited
3568 if K
= N_Op_And
or else K
= N_Op_Or
then
3570 when Access_Check
=>
3572 ("Constraint_Error may be raised (access check)??",
3574 when Division_Check
=>
3576 ("Constraint_Error may be raised (zero divide)??",
3580 raise Program_Error
;
3583 if K
= N_Op_And
then
3584 Error_Msg_N
-- CODEFIX
3585 ("use `AND THEN` instead of AND??", P
);
3587 Error_Msg_N
-- CODEFIX
3588 ("use `OR ELSE` instead of OR??", P
);
3591 -- If not short-circuited, we need the check
3595 -- If short-circuited, we can omit the check
3602 -----------------------------------
3603 -- Check_Valid_Lvalue_Subscripts --
3604 -----------------------------------
3606 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
3608 -- Skip this if range checks are suppressed
3610 if Range_Checks_Suppressed
(Etype
(Expr
)) then
3613 -- Only do this check for expressions that come from source. We assume
3614 -- that expander generated assignments explicitly include any necessary
3615 -- checks. Note that this is not just an optimization, it avoids
3616 -- infinite recursions!
3618 elsif not Comes_From_Source
(Expr
) then
3621 -- For a selected component, check the prefix
3623 elsif Nkind
(Expr
) = N_Selected_Component
then
3624 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3627 -- Case of indexed component
3629 elsif Nkind
(Expr
) = N_Indexed_Component
then
3630 Apply_Subscript_Validity_Checks
(Expr
);
3632 -- Prefix may itself be or contain an indexed component, and these
3633 -- subscripts need checking as well.
3635 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3637 end Check_Valid_Lvalue_Subscripts
;
3639 ----------------------------------
3640 -- Null_Exclusion_Static_Checks --
3641 ----------------------------------
3643 procedure Null_Exclusion_Static_Checks
(N
: Node_Id
) is
3644 Error_Node
: Node_Id
;
3646 Has_Null
: constant Boolean := Has_Null_Exclusion
(N
);
3647 K
: constant Node_Kind
:= Nkind
(N
);
3652 (K
= N_Component_Declaration
3653 or else K
= N_Discriminant_Specification
3654 or else K
= N_Function_Specification
3655 or else K
= N_Object_Declaration
3656 or else K
= N_Parameter_Specification
);
3658 if K
= N_Function_Specification
then
3659 Typ
:= Etype
(Defining_Entity
(N
));
3661 Typ
:= Etype
(Defining_Identifier
(N
));
3665 when N_Component_Declaration
=>
3666 if Present
(Access_Definition
(Component_Definition
(N
))) then
3667 Error_Node
:= Component_Definition
(N
);
3669 Error_Node
:= Subtype_Indication
(Component_Definition
(N
));
3672 when N_Discriminant_Specification
=>
3673 Error_Node
:= Discriminant_Type
(N
);
3675 when N_Function_Specification
=>
3676 Error_Node
:= Result_Definition
(N
);
3678 when N_Object_Declaration
=>
3679 Error_Node
:= Object_Definition
(N
);
3681 when N_Parameter_Specification
=>
3682 Error_Node
:= Parameter_Type
(N
);
3685 raise Program_Error
;
3690 -- Enforce legality rule 3.10 (13): A null exclusion can only be
3691 -- applied to an access [sub]type.
3693 if not Is_Access_Type
(Typ
) then
3695 ("`NOT NULL` allowed only for an access type", Error_Node
);
3697 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
3698 -- be applied to a [sub]type that does not exclude null already.
3700 elsif Can_Never_Be_Null
(Typ
)
3701 and then Comes_From_Source
(Typ
)
3704 ("`NOT NULL` not allowed (& already excludes null)",
3709 -- Check that null-excluding objects are always initialized, except for
3710 -- deferred constants, for which the expression will appear in the full
3713 if K
= N_Object_Declaration
3714 and then No
(Expression
(N
))
3715 and then not Constant_Present
(N
)
3716 and then not No_Initialization
(N
)
3718 -- Add an expression that assigns null. This node is needed by
3719 -- Apply_Compile_Time_Constraint_Error, which will replace this with
3720 -- a Constraint_Error node.
3722 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
3723 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
3725 Apply_Compile_Time_Constraint_Error
3726 (N
=> Expression
(N
),
3728 "(Ada 2005) null-excluding objects must be initialized??",
3729 Reason
=> CE_Null_Not_Allowed
);
3732 -- Check that a null-excluding component, formal or object is not being
3733 -- assigned a null value. Otherwise generate a warning message and
3734 -- replace Expression (N) by an N_Constraint_Error node.
3736 if K
/= N_Function_Specification
then
3737 Expr
:= Expression
(N
);
3739 if Present
(Expr
) and then Known_Null
(Expr
) then
3741 when N_Component_Declaration |
3742 N_Discriminant_Specification
=>
3743 Apply_Compile_Time_Constraint_Error
3745 Msg
=> "(Ada 2005) null not allowed " &
3746 "in null-excluding components??",
3747 Reason
=> CE_Null_Not_Allowed
);
3749 when N_Object_Declaration
=>
3750 Apply_Compile_Time_Constraint_Error
3752 Msg
=> "(Ada 2005) null not allowed " &
3753 "in null-excluding objects?",
3754 Reason
=> CE_Null_Not_Allowed
);
3756 when N_Parameter_Specification
=>
3757 Apply_Compile_Time_Constraint_Error
3759 Msg
=> "(Ada 2005) null not allowed " &
3760 "in null-excluding formals??",
3761 Reason
=> CE_Null_Not_Allowed
);
3768 end Null_Exclusion_Static_Checks
;
3770 ----------------------------------
3771 -- Conditional_Statements_Begin --
3772 ----------------------------------
3774 procedure Conditional_Statements_Begin
is
3776 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
3778 -- If stack overflows, kill all checks, that way we know to simply reset
3779 -- the number of saved checks to zero on return. This should never occur
3782 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
3785 -- In the normal case, we just make a new stack entry saving the current
3786 -- number of saved checks for a later restore.
3789 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
3791 if Debug_Flag_CC
then
3792 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
3796 end Conditional_Statements_Begin
;
3798 --------------------------------
3799 -- Conditional_Statements_End --
3800 --------------------------------
3802 procedure Conditional_Statements_End
is
3804 pragma Assert
(Saved_Checks_TOS
> 0);
3806 -- If the saved checks stack overflowed, then we killed all checks, so
3807 -- setting the number of saved checks back to zero is correct. This
3808 -- should never occur in practice.
3810 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
3811 Num_Saved_Checks
:= 0;
3813 -- In the normal case, restore the number of saved checks from the top
3817 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
3818 if Debug_Flag_CC
then
3819 w
("Conditional_Statements_End: Num_Saved_Checks = ",
3824 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
3825 end Conditional_Statements_End
;
3827 -------------------------
3828 -- Convert_From_Bignum --
3829 -------------------------
3831 function Convert_From_Bignum
(N
: Node_Id
) return Node_Id
is
3832 Loc
: constant Source_Ptr
:= Sloc
(N
);
3835 pragma Assert
(Is_RTE
(Etype
(N
), RE_Bignum
));
3837 -- Construct call From Bignum
3840 Make_Function_Call
(Loc
,
3842 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3843 Parameter_Associations
=> New_List
(Relocate_Node
(N
)));
3844 end Convert_From_Bignum
;
3846 -----------------------
3847 -- Convert_To_Bignum --
3848 -----------------------
3850 function Convert_To_Bignum
(N
: Node_Id
) return Node_Id
is
3851 Loc
: constant Source_Ptr
:= Sloc
(N
);
3854 -- Nothing to do if Bignum already except call Relocate_Node
3856 if Is_RTE
(Etype
(N
), RE_Bignum
) then
3857 return Relocate_Node
(N
);
3859 -- Otherwise construct call to To_Bignum, converting the operand to the
3860 -- required Long_Long_Integer form.
3863 pragma Assert
(Is_Signed_Integer_Type
(Etype
(N
)));
3865 Make_Function_Call
(Loc
,
3867 New_Occurrence_Of
(RTE
(RE_To_Bignum
), Loc
),
3868 Parameter_Associations
=> New_List
(
3869 Convert_To
(Standard_Long_Long_Integer
, Relocate_Node
(N
))));
3871 end Convert_To_Bignum
;
3873 ---------------------
3874 -- Determine_Range --
3875 ---------------------
3877 Cache_Size
: constant := 2 ** 10;
3878 type Cache_Index
is range 0 .. Cache_Size
- 1;
3879 -- Determine size of below cache (power of 2 is more efficient!)
3881 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
3882 Determine_Range_Cache_V
: array (Cache_Index
) of Boolean;
3883 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
3884 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
3885 -- The above arrays are used to implement a small direct cache for
3886 -- Determine_Range calls. Because of the way Determine_Range recursively
3887 -- traces subexpressions, and because overflow checking calls the routine
3888 -- on the way up the tree, a quadratic behavior can otherwise be
3889 -- encountered in large expressions. The cache entry for node N is stored
3890 -- in the (N mod Cache_Size) entry, and can be validated by checking the
3891 -- actual node value stored there. The Range_Cache_V array records the
3892 -- setting of Assume_Valid for the cache entry.
3894 procedure Determine_Range
3899 Assume_Valid
: Boolean := False)
3901 Typ
: Entity_Id
:= Etype
(N
);
3902 -- Type to use, may get reset to base type for possibly invalid entity
3906 -- Lo and Hi bounds of left operand
3910 -- Lo and Hi bounds of right (or only) operand
3913 -- Temp variable used to hold a bound node
3916 -- High bound of base type of expression
3920 -- Refined values for low and high bounds, after tightening
3923 -- Used in lower level calls to indicate if call succeeded
3925 Cindex
: Cache_Index
;
3926 -- Used to search cache
3931 function OK_Operands
return Boolean;
3932 -- Used for binary operators. Determines the ranges of the left and
3933 -- right operands, and if they are both OK, returns True, and puts
3934 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
3940 function OK_Operands
return Boolean is
3943 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
3950 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
3954 -- Start of processing for Determine_Range
3957 -- For temporary constants internally generated to remove side effects
3958 -- we must use the corresponding expression to determine the range of
3961 if Is_Entity_Name
(N
)
3962 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3963 and then Ekind
(Entity
(N
)) = E_Constant
3964 and then Is_Internal_Name
(Chars
(Entity
(N
)))
3967 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
3971 -- Prevent junk warnings by initializing range variables
3978 -- If type is not defined, we can't determine its range
3982 -- We don't deal with anything except discrete types
3984 or else not Is_Discrete_Type
(Typ
)
3986 -- Ignore type for which an error has been posted, since range in
3987 -- this case may well be a bogosity deriving from the error. Also
3988 -- ignore if error posted on the reference node.
3990 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
3996 -- For all other cases, we can determine the range
4000 -- If value is compile time known, then the possible range is the one
4001 -- value that we know this expression definitely has!
4003 if Compile_Time_Known_Value
(N
) then
4004 Lo
:= Expr_Value
(N
);
4009 -- Return if already in the cache
4011 Cindex
:= Cache_Index
(N
mod Cache_Size
);
4013 if Determine_Range_Cache_N
(Cindex
) = N
4015 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
4017 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
4018 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
4022 -- Otherwise, start by finding the bounds of the type of the expression,
4023 -- the value cannot be outside this range (if it is, then we have an
4024 -- overflow situation, which is a separate check, we are talking here
4025 -- only about the expression value).
4027 -- First a check, never try to find the bounds of a generic type, since
4028 -- these bounds are always junk values, and it is only valid to look at
4029 -- the bounds in an instance.
4031 if Is_Generic_Type
(Typ
) then
4036 -- First step, change to use base type unless we know the value is valid
4038 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
4039 or else Assume_No_Invalid_Values
4040 or else Assume_Valid
4044 Typ
:= Underlying_Type
(Base_Type
(Typ
));
4047 -- Retrieve the base type. Handle the case where the base type is a
4048 -- private enumeration type.
4050 Btyp
:= Base_Type
(Typ
);
4052 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
4053 Btyp
:= Full_View
(Btyp
);
4056 -- We use the actual bound unless it is dynamic, in which case use the
4057 -- corresponding base type bound if possible. If we can't get a bound
4058 -- then we figure we can't determine the range (a peculiar case, that
4059 -- perhaps cannot happen, but there is no point in bombing in this
4060 -- optimization circuit.
4062 -- First the low bound
4064 Bound
:= Type_Low_Bound
(Typ
);
4066 if Compile_Time_Known_Value
(Bound
) then
4067 Lo
:= Expr_Value
(Bound
);
4069 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
4070 Lo
:= Expr_Value
(Type_Low_Bound
(Btyp
));
4077 -- Now the high bound
4079 Bound
:= Type_High_Bound
(Typ
);
4081 -- We need the high bound of the base type later on, and this should
4082 -- always be compile time known. Again, it is not clear that this
4083 -- can ever be false, but no point in bombing.
4085 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
4086 Hbound
:= Expr_Value
(Type_High_Bound
(Btyp
));
4094 -- If we have a static subtype, then that may have a tighter bound so
4095 -- use the upper bound of the subtype instead in this case.
4097 if Compile_Time_Known_Value
(Bound
) then
4098 Hi
:= Expr_Value
(Bound
);
4101 -- We may be able to refine this value in certain situations. If any
4102 -- refinement is possible, then Lor and Hir are set to possibly tighter
4103 -- bounds, and OK1 is set to True.
4107 -- For unary plus, result is limited by range of operand
4111 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4113 -- For unary minus, determine range of operand, and negate it
4117 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4124 -- For binary addition, get range of each operand and do the
4125 -- addition to get the result range.
4129 Lor
:= Lo_Left
+ Lo_Right
;
4130 Hir
:= Hi_Left
+ Hi_Right
;
4133 -- Division is tricky. The only case we consider is where the right
4134 -- operand is a positive constant, and in this case we simply divide
4135 -- the bounds of the left operand
4139 if Lo_Right
= Hi_Right
4140 and then Lo_Right
> 0
4142 Lor
:= Lo_Left
/ Lo_Right
;
4143 Hir
:= Hi_Left
/ Lo_Right
;
4150 -- For binary subtraction, get range of each operand and do the worst
4151 -- case subtraction to get the result range.
4153 when N_Op_Subtract
=>
4155 Lor
:= Lo_Left
- Hi_Right
;
4156 Hir
:= Hi_Left
- Lo_Right
;
4159 -- For MOD, if right operand is a positive constant, then result must
4160 -- be in the allowable range of mod results.
4164 if Lo_Right
= Hi_Right
4165 and then Lo_Right
/= 0
4167 if Lo_Right
> 0 then
4169 Hir
:= Lo_Right
- 1;
4171 else -- Lo_Right < 0
4172 Lor
:= Lo_Right
+ 1;
4181 -- For REM, if right operand is a positive constant, then result must
4182 -- be in the allowable range of mod results.
4186 if Lo_Right
= Hi_Right
4187 and then Lo_Right
/= 0
4190 Dval
: constant Uint
:= (abs Lo_Right
) - 1;
4193 -- The sign of the result depends on the sign of the
4194 -- dividend (but not on the sign of the divisor, hence
4195 -- the abs operation above).
4215 -- Attribute reference cases
4217 when N_Attribute_Reference
=>
4218 case Attribute_Name
(N
) is
4220 -- For Pos/Val attributes, we can refine the range using the
4221 -- possible range of values of the attribute expression.
4223 when Name_Pos | Name_Val
=>
4225 (First
(Expressions
(N
)), OK1
, Lor
, Hir
, Assume_Valid
);
4227 -- For Length attribute, use the bounds of the corresponding
4228 -- index type to refine the range.
4232 Atyp
: Entity_Id
:= Etype
(Prefix
(N
));
4240 if Is_Access_Type
(Atyp
) then
4241 Atyp
:= Designated_Type
(Atyp
);
4244 -- For string literal, we know exact value
4246 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
4248 Lo
:= String_Literal_Length
(Atyp
);
4249 Hi
:= String_Literal_Length
(Atyp
);
4253 -- Otherwise check for expression given
4255 if No
(Expressions
(N
)) then
4259 UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
4262 Indx
:= First_Index
(Atyp
);
4263 for J
in 2 .. Inum
loop
4264 Indx
:= Next_Index
(Indx
);
4267 -- If the index type is a formal type or derived from
4268 -- one, the bounds are not static.
4270 if Is_Generic_Type
(Root_Type
(Etype
(Indx
))) then
4276 (Type_Low_Bound
(Etype
(Indx
)), OK1
, LL
, LU
,
4281 (Type_High_Bound
(Etype
(Indx
)), OK1
, UL
, UU
,
4286 -- The maximum value for Length is the biggest
4287 -- possible gap between the values of the bounds.
4288 -- But of course, this value cannot be negative.
4290 Hir
:= UI_Max
(Uint_0
, UU
- LL
+ 1);
4292 -- For constrained arrays, the minimum value for
4293 -- Length is taken from the actual value of the
4294 -- bounds, since the index will be exactly of this
4297 if Is_Constrained
(Atyp
) then
4298 Lor
:= UI_Max
(Uint_0
, UL
- LU
+ 1);
4300 -- For an unconstrained array, the minimum value
4301 -- for length is always zero.
4310 -- No special handling for other attributes
4311 -- Probably more opportunities exist here???
4318 -- For type conversion from one discrete type to another, we can
4319 -- refine the range using the converted value.
4321 when N_Type_Conversion
=>
4322 Determine_Range
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4324 -- Nothing special to do for all other expression kinds
4332 -- At this stage, if OK1 is true, then we know that the actual result of
4333 -- the computed expression is in the range Lor .. Hir. We can use this
4334 -- to restrict the possible range of results.
4338 -- If the refined value of the low bound is greater than the type
4339 -- high bound, then reset it to the more restrictive value. However,
4340 -- we do NOT do this for the case of a modular type where the
4341 -- possible upper bound on the value is above the base type high
4342 -- bound, because that means the result could wrap.
4345 and then not (Is_Modular_Integer_Type
(Typ
) and then Hir
> Hbound
)
4350 -- Similarly, if the refined value of the high bound is less than the
4351 -- value so far, then reset it to the more restrictive value. Again,
4352 -- we do not do this if the refined low bound is negative for a
4353 -- modular type, since this would wrap.
4356 and then not (Is_Modular_Integer_Type
(Typ
) and then Lor
< Uint_0
)
4362 -- Set cache entry for future call and we are all done
4364 Determine_Range_Cache_N
(Cindex
) := N
;
4365 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
4366 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
4367 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
4370 -- If any exception occurs, it means that we have some bug in the compiler,
4371 -- possibly triggered by a previous error, or by some unforeseen peculiar
4372 -- occurrence. However, this is only an optimization attempt, so there is
4373 -- really no point in crashing the compiler. Instead we just decide, too
4374 -- bad, we can't figure out a range in this case after all.
4379 -- Debug flag K disables this behavior (useful for debugging)
4381 if Debug_Flag_K
then
4389 end Determine_Range
;
4391 ------------------------------------
4392 -- Discriminant_Checks_Suppressed --
4393 ------------------------------------
4395 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4398 if Is_Unchecked_Union
(E
) then
4400 elsif Checks_May_Be_Suppressed
(E
) then
4401 return Is_Check_Suppressed
(E
, Discriminant_Check
);
4405 return Scope_Suppress
.Suppress
(Discriminant_Check
);
4406 end Discriminant_Checks_Suppressed
;
4408 --------------------------------
4409 -- Division_Checks_Suppressed --
4410 --------------------------------
4412 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4414 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4415 return Is_Check_Suppressed
(E
, Division_Check
);
4417 return Scope_Suppress
.Suppress
(Division_Check
);
4419 end Division_Checks_Suppressed
;
4421 -----------------------------------
4422 -- Elaboration_Checks_Suppressed --
4423 -----------------------------------
4425 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4427 -- The complication in this routine is that if we are in the dynamic
4428 -- model of elaboration, we also check All_Checks, since All_Checks
4429 -- does not set Elaboration_Check explicitly.
4432 if Kill_Elaboration_Checks
(E
) then
4435 elsif Checks_May_Be_Suppressed
(E
) then
4436 if Is_Check_Suppressed
(E
, Elaboration_Check
) then
4438 elsif Dynamic_Elaboration_Checks
then
4439 return Is_Check_Suppressed
(E
, All_Checks
);
4446 if Scope_Suppress
.Suppress
(Elaboration_Check
) then
4448 elsif Dynamic_Elaboration_Checks
then
4449 return Scope_Suppress
.Suppress
(All_Checks
);
4453 end Elaboration_Checks_Suppressed
;
4455 ---------------------------
4456 -- Enable_Overflow_Check --
4457 ---------------------------
4459 procedure Enable_Overflow_Check
(N
: Node_Id
) is
4460 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
4461 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
4470 if Debug_Flag_CC
then
4471 w
("Enable_Overflow_Check for node ", Int
(N
));
4472 Write_Str
(" Source location = ");
4477 -- No check if overflow checks suppressed for type of node
4479 if Overflow_Checks_Suppressed
(Etype
(N
)) then
4482 -- Nothing to do for unsigned integer types, which do not overflow
4484 elsif Is_Modular_Integer_Type
(Typ
) then
4488 -- This is the point at which processing for STRICT mode diverges
4489 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
4490 -- probably more extreme that it needs to be, but what is going on here
4491 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
4492 -- to leave the processing for STRICT mode untouched. There were
4493 -- two reasons for this. First it avoided any incompatible change of
4494 -- behavior. Second, it guaranteed that STRICT mode continued to be
4497 -- The big difference is that in STRICT mode there is a fair amount of
4498 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
4499 -- know that no check is needed. We skip all that in the two new modes,
4500 -- since really overflow checking happens over a whole subtree, and we
4501 -- do the corresponding optimizations later on when applying the checks.
4503 if Mode
in Minimized_Or_Eliminated
then
4504 if not (Overflow_Checks_Suppressed
(Etype
(N
)))
4505 and then not (Is_Entity_Name
(N
)
4506 and then Overflow_Checks_Suppressed
(Entity
(N
)))
4508 Activate_Overflow_Check
(N
);
4511 if Debug_Flag_CC
then
4512 w
("Minimized/Eliminated mode");
4518 -- Remainder of processing is for STRICT case, and is unchanged from
4519 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
4521 -- Nothing to do if the range of the result is known OK. We skip this
4522 -- for conversions, since the caller already did the check, and in any
4523 -- case the condition for deleting the check for a type conversion is
4526 if Nkind
(N
) /= N_Type_Conversion
then
4527 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
4529 -- Note in the test below that we assume that the range is not OK
4530 -- if a bound of the range is equal to that of the type. That's not
4531 -- quite accurate but we do this for the following reasons:
4533 -- a) The way that Determine_Range works, it will typically report
4534 -- the bounds of the value as being equal to the bounds of the
4535 -- type, because it either can't tell anything more precise, or
4536 -- does not think it is worth the effort to be more precise.
4538 -- b) It is very unusual to have a situation in which this would
4539 -- generate an unnecessary overflow check (an example would be
4540 -- a subtype with a range 0 .. Integer'Last - 1 to which the
4541 -- literal value one is added).
4543 -- c) The alternative is a lot of special casing in this routine
4544 -- which would partially duplicate Determine_Range processing.
4547 and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
4548 and then Hi
< Expr_Value
(Type_High_Bound
(Typ
))
4550 if Debug_Flag_CC
then
4551 w
("No overflow check required");
4558 -- If not in optimizing mode, set flag and we are done. We are also done
4559 -- (and just set the flag) if the type is not a discrete type, since it
4560 -- is not worth the effort to eliminate checks for other than discrete
4561 -- types. In addition, we take this same path if we have stored the
4562 -- maximum number of checks possible already (a very unlikely situation,
4563 -- but we do not want to blow up!)
4565 if Optimization_Level
= 0
4566 or else not Is_Discrete_Type
(Etype
(N
))
4567 or else Num_Saved_Checks
= Saved_Checks
'Last
4569 Activate_Overflow_Check
(N
);
4571 if Debug_Flag_CC
then
4572 w
("Optimization off");
4578 -- Otherwise evaluate and check the expression
4583 Target_Type
=> Empty
,
4589 if Debug_Flag_CC
then
4590 w
("Called Find_Check");
4594 w
(" Check_Num = ", Chk
);
4595 w
(" Ent = ", Int
(Ent
));
4596 Write_Str
(" Ofs = ");
4601 -- If check is not of form to optimize, then set flag and we are done
4604 Activate_Overflow_Check
(N
);
4608 -- If check is already performed, then return without setting flag
4611 if Debug_Flag_CC
then
4612 w
("Check suppressed!");
4618 -- Here we will make a new entry for the new check
4620 Activate_Overflow_Check
(N
);
4621 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
4622 Saved_Checks
(Num_Saved_Checks
) :=
4627 Target_Type
=> Empty
);
4629 if Debug_Flag_CC
then
4630 w
("Make new entry, check number = ", Num_Saved_Checks
);
4631 w
(" Entity = ", Int
(Ent
));
4632 Write_Str
(" Offset = ");
4634 w
(" Check_Type = O");
4635 w
(" Target_Type = Empty");
4638 -- If we get an exception, then something went wrong, probably because of
4639 -- an error in the structure of the tree due to an incorrect program. Or it
4640 -- may be a bug in the optimization circuit. In either case the safest
4641 -- thing is simply to set the check flag unconditionally.
4645 Activate_Overflow_Check
(N
);
4647 if Debug_Flag_CC
then
4648 w
(" exception occurred, overflow flag set");
4652 end Enable_Overflow_Check
;
4654 ------------------------
4655 -- Enable_Range_Check --
4656 ------------------------
4658 procedure Enable_Range_Check
(N
: Node_Id
) is
4667 -- Return if unchecked type conversion with range check killed. In this
4668 -- case we never set the flag (that's what Kill_Range_Check is about!)
4670 if Nkind
(N
) = N_Unchecked_Type_Conversion
4671 and then Kill_Range_Check
(N
)
4676 -- Do not set range check flag if parent is assignment statement or
4677 -- object declaration with Suppress_Assignment_Checks flag set
4679 if Nkind_In
(Parent
(N
), N_Assignment_Statement
, N_Object_Declaration
)
4680 and then Suppress_Assignment_Checks
(Parent
(N
))
4685 -- Check for various cases where we should suppress the range check
4687 -- No check if range checks suppressed for type of node
4689 if Present
(Etype
(N
))
4690 and then Range_Checks_Suppressed
(Etype
(N
))
4694 -- No check if node is an entity name, and range checks are suppressed
4695 -- for this entity, or for the type of this entity.
4697 elsif Is_Entity_Name
(N
)
4698 and then (Range_Checks_Suppressed
(Entity
(N
))
4699 or else Range_Checks_Suppressed
(Etype
(Entity
(N
))))
4703 -- No checks if index of array, and index checks are suppressed for
4704 -- the array object or the type of the array.
4706 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
then
4708 Pref
: constant Node_Id
:= Prefix
(Parent
(N
));
4710 if Is_Entity_Name
(Pref
)
4711 and then Index_Checks_Suppressed
(Entity
(Pref
))
4714 elsif Index_Checks_Suppressed
(Etype
(Pref
)) then
4720 -- Debug trace output
4722 if Debug_Flag_CC
then
4723 w
("Enable_Range_Check for node ", Int
(N
));
4724 Write_Str
(" Source location = ");
4729 -- If not in optimizing mode, set flag and we are done. We are also done
4730 -- (and just set the flag) if the type is not a discrete type, since it
4731 -- is not worth the effort to eliminate checks for other than discrete
4732 -- types. In addition, we take this same path if we have stored the
4733 -- maximum number of checks possible already (a very unlikely situation,
4734 -- but we do not want to blow up!)
4736 if Optimization_Level
= 0
4737 or else No
(Etype
(N
))
4738 or else not Is_Discrete_Type
(Etype
(N
))
4739 or else Num_Saved_Checks
= Saved_Checks
'Last
4741 Activate_Range_Check
(N
);
4743 if Debug_Flag_CC
then
4744 w
("Optimization off");
4750 -- Otherwise find out the target type
4754 -- For assignment, use left side subtype
4756 if Nkind
(P
) = N_Assignment_Statement
4757 and then Expression
(P
) = N
4759 Ttyp
:= Etype
(Name
(P
));
4761 -- For indexed component, use subscript subtype
4763 elsif Nkind
(P
) = N_Indexed_Component
then
4770 Atyp
:= Etype
(Prefix
(P
));
4772 if Is_Access_Type
(Atyp
) then
4773 Atyp
:= Designated_Type
(Atyp
);
4775 -- If the prefix is an access to an unconstrained array,
4776 -- perform check unconditionally: it depends on the bounds of
4777 -- an object and we cannot currently recognize whether the test
4778 -- may be redundant.
4780 if not Is_Constrained
(Atyp
) then
4781 Activate_Range_Check
(N
);
4785 -- Ditto if the prefix is an explicit dereference whose designated
4786 -- type is unconstrained.
4788 elsif Nkind
(Prefix
(P
)) = N_Explicit_Dereference
4789 and then not Is_Constrained
(Atyp
)
4791 Activate_Range_Check
(N
);
4795 Indx
:= First_Index
(Atyp
);
4796 Subs
:= First
(Expressions
(P
));
4799 Ttyp
:= Etype
(Indx
);
4808 -- For now, ignore all other cases, they are not so interesting
4811 if Debug_Flag_CC
then
4812 w
(" target type not found, flag set");
4815 Activate_Range_Check
(N
);
4819 -- Evaluate and check the expression
4824 Target_Type
=> Ttyp
,
4830 if Debug_Flag_CC
then
4831 w
("Called Find_Check");
4832 w
("Target_Typ = ", Int
(Ttyp
));
4836 w
(" Check_Num = ", Chk
);
4837 w
(" Ent = ", Int
(Ent
));
4838 Write_Str
(" Ofs = ");
4843 -- If check is not of form to optimize, then set flag and we are done
4846 if Debug_Flag_CC
then
4847 w
(" expression not of optimizable type, flag set");
4850 Activate_Range_Check
(N
);
4854 -- If check is already performed, then return without setting flag
4857 if Debug_Flag_CC
then
4858 w
("Check suppressed!");
4864 -- Here we will make a new entry for the new check
4866 Activate_Range_Check
(N
);
4867 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
4868 Saved_Checks
(Num_Saved_Checks
) :=
4873 Target_Type
=> Ttyp
);
4875 if Debug_Flag_CC
then
4876 w
("Make new entry, check number = ", Num_Saved_Checks
);
4877 w
(" Entity = ", Int
(Ent
));
4878 Write_Str
(" Offset = ");
4880 w
(" Check_Type = R");
4881 w
(" Target_Type = ", Int
(Ttyp
));
4882 pg
(Union_Id
(Ttyp
));
4885 -- If we get an exception, then something went wrong, probably because of
4886 -- an error in the structure of the tree due to an incorrect program. Or
4887 -- it may be a bug in the optimization circuit. In either case the safest
4888 -- thing is simply to set the check flag unconditionally.
4892 Activate_Range_Check
(N
);
4894 if Debug_Flag_CC
then
4895 w
(" exception occurred, range flag set");
4899 end Enable_Range_Check
;
4905 procedure Ensure_Valid
(Expr
: Node_Id
; Holes_OK
: Boolean := False) is
4906 Typ
: constant Entity_Id
:= Etype
(Expr
);
4909 -- Ignore call if we are not doing any validity checking
4911 if not Validity_Checks_On
then
4914 -- Ignore call if range or validity checks suppressed on entity or type
4916 elsif Range_Or_Validity_Checks_Suppressed
(Expr
) then
4919 -- No check required if expression is from the expander, we assume the
4920 -- expander will generate whatever checks are needed. Note that this is
4921 -- not just an optimization, it avoids infinite recursions!
4923 -- Unchecked conversions must be checked, unless they are initialized
4924 -- scalar values, as in a component assignment in an init proc.
4926 -- In addition, we force a check if Force_Validity_Checks is set
4928 elsif not Comes_From_Source
(Expr
)
4929 and then not Force_Validity_Checks
4930 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
4931 or else Kill_Range_Check
(Expr
))
4935 -- No check required if expression is known to have valid value
4937 elsif Expr_Known_Valid
(Expr
) then
4940 -- Ignore case of enumeration with holes where the flag is set not to
4941 -- worry about holes, since no special validity check is needed
4943 elsif Is_Enumeration_Type
(Typ
)
4944 and then Has_Non_Standard_Rep
(Typ
)
4949 -- No check required on the left-hand side of an assignment
4951 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
4952 and then Expr
= Name
(Parent
(Expr
))
4956 -- No check on a universal real constant. The context will eventually
4957 -- convert it to a machine number for some target type, or report an
4960 elsif Nkind
(Expr
) = N_Real_Literal
4961 and then Etype
(Expr
) = Universal_Real
4965 -- If the expression denotes a component of a packed boolean array,
4966 -- no possible check applies. We ignore the old ACATS chestnuts that
4967 -- involve Boolean range True..True.
4969 -- Note: validity checks are generated for expressions that yield a
4970 -- scalar type, when it is possible to create a value that is outside of
4971 -- the type. If this is a one-bit boolean no such value exists. This is
4972 -- an optimization, and it also prevents compiler blowing up during the
4973 -- elaboration of improperly expanded packed array references.
4975 elsif Nkind
(Expr
) = N_Indexed_Component
4976 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Expr
)))
4977 and then Root_Type
(Etype
(Expr
)) = Standard_Boolean
4981 -- An annoying special case. If this is an out parameter of a scalar
4982 -- type, then the value is not going to be accessed, therefore it is
4983 -- inappropriate to do any validity check at the call site.
4986 -- Only need to worry about scalar types
4988 if Is_Scalar_Type
(Typ
) then
4998 -- Find actual argument (which may be a parameter association)
4999 -- and the parent of the actual argument (the call statement)
5004 if Nkind
(P
) = N_Parameter_Association
then
5009 -- Only need to worry if we are argument of a procedure call
5010 -- since functions don't have out parameters. If this is an
5011 -- indirect or dispatching call, get signature from the
5014 if Nkind
(P
) = N_Procedure_Call_Statement
then
5015 L
:= Parameter_Associations
(P
);
5017 if Is_Entity_Name
(Name
(P
)) then
5018 E
:= Entity
(Name
(P
));
5020 pragma Assert
(Nkind
(Name
(P
)) = N_Explicit_Dereference
);
5021 E
:= Etype
(Name
(P
));
5024 -- Only need to worry if there are indeed actuals, and if
5025 -- this could be a procedure call, otherwise we cannot get a
5026 -- match (either we are not an argument, or the mode of the
5027 -- formal is not OUT). This test also filters out the
5030 if Is_Non_Empty_List
(L
)
5031 and then Is_Subprogram
(E
)
5033 -- This is the loop through parameters, looking for an
5034 -- OUT parameter for which we are the argument.
5036 F
:= First_Formal
(E
);
5038 while Present
(F
) loop
5039 if Ekind
(F
) = E_Out_Parameter
and then A
= N
then
5052 -- If this is a boolean expression, only its elementary operands need
5053 -- checking: if they are valid, a boolean or short-circuit operation
5054 -- with them will be valid as well.
5056 if Base_Type
(Typ
) = Standard_Boolean
5058 (Nkind
(Expr
) in N_Op
or else Nkind
(Expr
) in N_Short_Circuit
)
5063 -- If we fall through, a validity check is required
5065 Insert_Valid_Check
(Expr
);
5067 if Is_Entity_Name
(Expr
)
5068 and then Safe_To_Capture_Value
(Expr
, Entity
(Expr
))
5070 Set_Is_Known_Valid
(Entity
(Expr
));
5074 ----------------------
5075 -- Expr_Known_Valid --
5076 ----------------------
5078 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
5079 Typ
: constant Entity_Id
:= Etype
(Expr
);
5082 -- Non-scalar types are always considered valid, since they never give
5083 -- rise to the issues of erroneous or bounded error behavior that are
5084 -- the concern. In formal reference manual terms the notion of validity
5085 -- only applies to scalar types. Note that even when packed arrays are
5086 -- represented using modular types, they are still arrays semantically,
5087 -- so they are also always valid (in particular, the unused bits can be
5088 -- random rubbish without affecting the validity of the array value).
5090 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Type
(Typ
) then
5093 -- If no validity checking, then everything is considered valid
5095 elsif not Validity_Checks_On
then
5098 -- Floating-point types are considered valid unless floating-point
5099 -- validity checks have been specifically turned on.
5101 elsif Is_Floating_Point_Type
(Typ
)
5102 and then not Validity_Check_Floating_Point
5106 -- If the expression is the value of an object that is known to be
5107 -- valid, then clearly the expression value itself is valid.
5109 elsif Is_Entity_Name
(Expr
)
5110 and then Is_Known_Valid
(Entity
(Expr
))
5114 -- References to discriminants are always considered valid. The value
5115 -- of a discriminant gets checked when the object is built. Within the
5116 -- record, we consider it valid, and it is important to do so, since
5117 -- otherwise we can try to generate bogus validity checks which
5118 -- reference discriminants out of scope. Discriminants of concurrent
5119 -- types are excluded for the same reason.
5121 elsif Is_Entity_Name
(Expr
)
5122 and then Denotes_Discriminant
(Expr
, Check_Concurrent
=> True)
5126 -- If the type is one for which all values are known valid, then we are
5127 -- sure that the value is valid except in the slightly odd case where
5128 -- the expression is a reference to a variable whose size has been
5129 -- explicitly set to a value greater than the object size.
5131 elsif Is_Known_Valid
(Typ
) then
5132 if Is_Entity_Name
(Expr
)
5133 and then Ekind
(Entity
(Expr
)) = E_Variable
5134 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
5141 -- Integer and character literals always have valid values, where
5142 -- appropriate these will be range checked in any case.
5144 elsif Nkind
(Expr
) = N_Integer_Literal
5146 Nkind
(Expr
) = N_Character_Literal
5150 -- Real literals are assumed to be valid in VM targets
5152 elsif VM_Target
/= No_VM
5153 and then Nkind
(Expr
) = N_Real_Literal
5157 -- If we have a type conversion or a qualification of a known valid
5158 -- value, then the result will always be valid.
5160 elsif Nkind
(Expr
) = N_Type_Conversion
5162 Nkind
(Expr
) = N_Qualified_Expression
5164 return Expr_Known_Valid
(Expression
(Expr
));
5166 -- The result of any operator is always considered valid, since we
5167 -- assume the necessary checks are done by the operator. For operators
5168 -- on floating-point operations, we must also check when the operation
5169 -- is the right-hand side of an assignment, or is an actual in a call.
5171 elsif Nkind
(Expr
) in N_Op
then
5172 if Is_Floating_Point_Type
(Typ
)
5173 and then Validity_Check_Floating_Point
5175 (Nkind
(Parent
(Expr
)) = N_Assignment_Statement
5176 or else Nkind
(Parent
(Expr
)) = N_Function_Call
5177 or else Nkind
(Parent
(Expr
)) = N_Parameter_Association
)
5184 -- The result of a membership test is always valid, since it is true or
5185 -- false, there are no other possibilities.
5187 elsif Nkind
(Expr
) in N_Membership_Test
then
5190 -- For all other cases, we do not know the expression is valid
5195 end Expr_Known_Valid
;
5201 procedure Find_Check
5203 Check_Type
: Character;
5204 Target_Type
: Entity_Id
;
5205 Entry_OK
: out Boolean;
5206 Check_Num
: out Nat
;
5207 Ent
: out Entity_Id
;
5210 function Within_Range_Of
5211 (Target_Type
: Entity_Id
;
5212 Check_Type
: Entity_Id
) return Boolean;
5213 -- Given a requirement for checking a range against Target_Type, and
5214 -- and a range Check_Type against which a check has already been made,
5215 -- determines if the check against check type is sufficient to ensure
5216 -- that no check against Target_Type is required.
5218 ---------------------
5219 -- Within_Range_Of --
5220 ---------------------
5222 function Within_Range_Of
5223 (Target_Type
: Entity_Id
;
5224 Check_Type
: Entity_Id
) return Boolean
5227 if Target_Type
= Check_Type
then
5232 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
5233 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
5234 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
5235 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
5239 or else (Compile_Time_Known_Value
(Tlo
)
5241 Compile_Time_Known_Value
(Clo
)
5243 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
5246 or else (Compile_Time_Known_Value
(Thi
)
5248 Compile_Time_Known_Value
(Chi
)
5250 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
5258 end Within_Range_Of
;
5260 -- Start of processing for Find_Check
5263 -- Establish default, in case no entry is found
5267 -- Case of expression is simple entity reference
5269 if Is_Entity_Name
(Expr
) then
5270 Ent
:= Entity
(Expr
);
5273 -- Case of expression is entity + known constant
5275 elsif Nkind
(Expr
) = N_Op_Add
5276 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
5277 and then Is_Entity_Name
(Left_Opnd
(Expr
))
5279 Ent
:= Entity
(Left_Opnd
(Expr
));
5280 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
5282 -- Case of expression is entity - known constant
5284 elsif Nkind
(Expr
) = N_Op_Subtract
5285 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
5286 and then Is_Entity_Name
(Left_Opnd
(Expr
))
5288 Ent
:= Entity
(Left_Opnd
(Expr
));
5289 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
5291 -- Any other expression is not of the right form
5300 -- Come here with expression of appropriate form, check if entity is an
5301 -- appropriate one for our purposes.
5303 if (Ekind
(Ent
) = E_Variable
5304 or else Is_Constant_Object
(Ent
))
5305 and then not Is_Library_Level_Entity
(Ent
)
5313 -- See if there is matching check already
5315 for J
in reverse 1 .. Num_Saved_Checks
loop
5317 SC
: Saved_Check
renames Saved_Checks
(J
);
5320 if SC
.Killed
= False
5321 and then SC
.Entity
= Ent
5322 and then SC
.Offset
= Ofs
5323 and then SC
.Check_Type
= Check_Type
5324 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
5332 -- If we fall through entry was not found
5337 ---------------------------------
5338 -- Generate_Discriminant_Check --
5339 ---------------------------------
5341 -- Note: the code for this procedure is derived from the
5342 -- Emit_Discriminant_Check Routine in trans.c.
5344 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
5345 Loc
: constant Source_Ptr
:= Sloc
(N
);
5346 Pref
: constant Node_Id
:= Prefix
(N
);
5347 Sel
: constant Node_Id
:= Selector_Name
(N
);
5349 Orig_Comp
: constant Entity_Id
:=
5350 Original_Record_Component
(Entity
(Sel
));
5351 -- The original component to be checked
5353 Discr_Fct
: constant Entity_Id
:=
5354 Discriminant_Checking_Func
(Orig_Comp
);
5355 -- The discriminant checking function
5358 -- One discriminant to be checked in the type
5360 Real_Discr
: Entity_Id
;
5361 -- Actual discriminant in the call
5363 Pref_Type
: Entity_Id
;
5364 -- Type of relevant prefix (ignoring private/access stuff)
5367 -- List of arguments for function call
5370 -- Keep track of the formal corresponding to the actual we build for
5371 -- each discriminant, in order to be able to perform the necessary type
5375 -- Selected component reference for checking function argument
5378 Pref_Type
:= Etype
(Pref
);
5380 -- Force evaluation of the prefix, so that it does not get evaluated
5381 -- twice (once for the check, once for the actual reference). Such a
5382 -- double evaluation is always a potential source of inefficiency,
5383 -- and is functionally incorrect in the volatile case, or when the
5384 -- prefix may have side-effects. An entity or a component of an
5385 -- entity requires no evaluation.
5387 if Is_Entity_Name
(Pref
) then
5388 if Treat_As_Volatile
(Entity
(Pref
)) then
5389 Force_Evaluation
(Pref
, Name_Req
=> True);
5392 elsif Treat_As_Volatile
(Etype
(Pref
)) then
5393 Force_Evaluation
(Pref
, Name_Req
=> True);
5395 elsif Nkind
(Pref
) = N_Selected_Component
5396 and then Is_Entity_Name
(Prefix
(Pref
))
5401 Force_Evaluation
(Pref
, Name_Req
=> True);
5404 -- For a tagged type, use the scope of the original component to
5405 -- obtain the type, because ???
5407 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
5408 Pref_Type
:= Scope
(Orig_Comp
);
5410 -- For an untagged derived type, use the discriminants of the parent
5411 -- which have been renamed in the derivation, possibly by a one-to-many
5412 -- discriminant constraint. For non-tagged type, initially get the Etype
5416 if Is_Derived_Type
(Pref_Type
)
5417 and then Number_Discriminants
(Pref_Type
) /=
5418 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
5420 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
5424 -- We definitely should have a checking function, This routine should
5425 -- not be called if no discriminant checking function is present.
5427 pragma Assert
(Present
(Discr_Fct
));
5429 -- Create the list of the actual parameters for the call. This list
5430 -- is the list of the discriminant fields of the record expression to
5431 -- be discriminant checked.
5434 Formal
:= First_Formal
(Discr_Fct
);
5435 Discr
:= First_Discriminant
(Pref_Type
);
5436 while Present
(Discr
) loop
5438 -- If we have a corresponding discriminant field, and a parent
5439 -- subtype is present, then we want to use the corresponding
5440 -- discriminant since this is the one with the useful value.
5442 if Present
(Corresponding_Discriminant
(Discr
))
5443 and then Ekind
(Pref_Type
) = E_Record_Type
5444 and then Present
(Parent_Subtype
(Pref_Type
))
5446 Real_Discr
:= Corresponding_Discriminant
(Discr
);
5448 Real_Discr
:= Discr
;
5451 -- Construct the reference to the discriminant
5454 Make_Selected_Component
(Loc
,
5456 Unchecked_Convert_To
(Pref_Type
,
5457 Duplicate_Subexpr
(Pref
)),
5458 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
5460 -- Manually analyze and resolve this selected component. We really
5461 -- want it just as it appears above, and do not want the expander
5462 -- playing discriminal games etc with this reference. Then we append
5463 -- the argument to the list we are gathering.
5465 Set_Etype
(Scomp
, Etype
(Real_Discr
));
5466 Set_Analyzed
(Scomp
, True);
5467 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
5469 Next_Formal_With_Extras
(Formal
);
5470 Next_Discriminant
(Discr
);
5473 -- Now build and insert the call
5476 Make_Raise_Constraint_Error
(Loc
,
5478 Make_Function_Call
(Loc
,
5479 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
5480 Parameter_Associations
=> Args
),
5481 Reason
=> CE_Discriminant_Check_Failed
));
5482 end Generate_Discriminant_Check
;
5484 ---------------------------
5485 -- Generate_Index_Checks --
5486 ---------------------------
5488 procedure Generate_Index_Checks
(N
: Node_Id
) is
5490 function Entity_Of_Prefix
return Entity_Id
;
5491 -- Returns the entity of the prefix of N (or Empty if not found)
5493 ----------------------
5494 -- Entity_Of_Prefix --
5495 ----------------------
5497 function Entity_Of_Prefix
return Entity_Id
is
5502 while not Is_Entity_Name
(P
) loop
5503 if not Nkind_In
(P
, N_Selected_Component
,
5504 N_Indexed_Component
)
5513 end Entity_Of_Prefix
;
5517 Loc
: constant Source_Ptr
:= Sloc
(N
);
5518 A
: constant Node_Id
:= Prefix
(N
);
5519 A_Ent
: constant Entity_Id
:= Entity_Of_Prefix
;
5522 -- Start of processing for Generate_Index_Checks
5525 -- Ignore call if the prefix is not an array since we have a serious
5526 -- error in the sources. Ignore it also if index checks are suppressed
5527 -- for array object or type.
5529 if not Is_Array_Type
(Etype
(A
))
5530 or else (Present
(A_Ent
)
5531 and then Index_Checks_Suppressed
(A_Ent
))
5532 or else Index_Checks_Suppressed
(Etype
(A
))
5536 -- The indexed component we are dealing with contains 'Loop_Entry in its
5537 -- prefix. This case arises when analysis has determined that constructs
5540 -- Prefix'Loop_Entry (Expr)
5541 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
5543 -- require rewriting for error detection purposes. A side effect of this
5544 -- action is the generation of index checks that mention 'Loop_Entry.
5545 -- Delay the generation of the check until 'Loop_Entry has been properly
5546 -- expanded. This is done in Expand_Loop_Entry_Attributes.
5548 elsif Nkind
(Prefix
(N
)) = N_Attribute_Reference
5549 and then Attribute_Name
(Prefix
(N
)) = Name_Loop_Entry
5554 -- Generate a raise of constraint error with the appropriate reason and
5555 -- a condition of the form:
5557 -- Base_Type (Sub) not in Array'Range (Subscript)
5559 -- Note that the reason we generate the conversion to the base type here
5560 -- is that we definitely want the range check to take place, even if it
5561 -- looks like the subtype is OK. Optimization considerations that allow
5562 -- us to omit the check have already been taken into account in the
5563 -- setting of the Do_Range_Check flag earlier on.
5565 Sub
:= First
(Expressions
(N
));
5567 -- Handle string literals
5569 if Ekind
(Etype
(A
)) = E_String_Literal_Subtype
then
5570 if Do_Range_Check
(Sub
) then
5571 Set_Do_Range_Check
(Sub
, False);
5573 -- For string literals we obtain the bounds of the string from the
5574 -- associated subtype.
5577 Make_Raise_Constraint_Error
(Loc
,
5581 Convert_To
(Base_Type
(Etype
(Sub
)),
5582 Duplicate_Subexpr_Move_Checks
(Sub
)),
5584 Make_Attribute_Reference
(Loc
,
5585 Prefix
=> New_Reference_To
(Etype
(A
), Loc
),
5586 Attribute_Name
=> Name_Range
)),
5587 Reason
=> CE_Index_Check_Failed
));
5594 A_Idx
: Node_Id
:= Empty
;
5601 A_Idx
:= First_Index
(Etype
(A
));
5603 while Present
(Sub
) loop
5604 if Do_Range_Check
(Sub
) then
5605 Set_Do_Range_Check
(Sub
, False);
5607 -- Force evaluation except for the case of a simple name of
5608 -- a non-volatile entity.
5610 if not Is_Entity_Name
(Sub
)
5611 or else Treat_As_Volatile
(Entity
(Sub
))
5613 Force_Evaluation
(Sub
);
5616 if Nkind
(A_Idx
) = N_Range
then
5619 elsif Nkind
(A_Idx
) = N_Identifier
5620 or else Nkind
(A_Idx
) = N_Expanded_Name
5622 A_Range
:= Scalar_Range
(Entity
(A_Idx
));
5624 else pragma Assert
(Nkind
(A_Idx
) = N_Subtype_Indication
);
5625 A_Range
:= Range_Expression
(Constraint
(A_Idx
));
5628 -- For array objects with constant bounds we can generate
5629 -- the index check using the bounds of the type of the index
5632 and then Ekind
(A_Ent
) = E_Variable
5633 and then Is_Constant_Bound
(Low_Bound
(A_Range
))
5634 and then Is_Constant_Bound
(High_Bound
(A_Range
))
5637 Make_Attribute_Reference
(Loc
,
5639 New_Reference_To
(Etype
(A_Idx
), Loc
),
5640 Attribute_Name
=> Name_Range
);
5642 -- For arrays with non-constant bounds we cannot generate
5643 -- the index check using the bounds of the type of the index
5644 -- since it may reference discriminants of some enclosing
5645 -- type. We obtain the bounds directly from the prefix
5652 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
5656 Make_Attribute_Reference
(Loc
,
5658 Duplicate_Subexpr_Move_Checks
(A
, Name_Req
=> True),
5659 Attribute_Name
=> Name_Range
,
5660 Expressions
=> Num
);
5664 Make_Raise_Constraint_Error
(Loc
,
5668 Convert_To
(Base_Type
(Etype
(Sub
)),
5669 Duplicate_Subexpr_Move_Checks
(Sub
)),
5670 Right_Opnd
=> Range_N
),
5671 Reason
=> CE_Index_Check_Failed
));
5674 A_Idx
:= Next_Index
(A_Idx
);
5680 end Generate_Index_Checks
;
5682 --------------------------
5683 -- Generate_Range_Check --
5684 --------------------------
5686 procedure Generate_Range_Check
5688 Target_Type
: Entity_Id
;
5689 Reason
: RT_Exception_Code
)
5691 Loc
: constant Source_Ptr
:= Sloc
(N
);
5692 Source_Type
: constant Entity_Id
:= Etype
(N
);
5693 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
5694 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
5697 -- First special case, if the source type is already within the range
5698 -- of the target type, then no check is needed (probably we should have
5699 -- stopped Do_Range_Check from being set in the first place, but better
5700 -- late than never in preventing junk code!
5702 if In_Subrange_Of
(Source_Type
, Target_Type
)
5704 -- We do NOT apply this if the source node is a literal, since in this
5705 -- case the literal has already been labeled as having the subtype of
5709 (Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
, N_Character_Literal
)
5712 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
5714 -- Also do not apply this for floating-point if Check_Float_Overflow
5717 (Is_Floating_Point_Type
(Source_Type
) and Check_Float_Overflow
)
5722 -- We need a check, so force evaluation of the node, so that it does
5723 -- not get evaluated twice (once for the check, once for the actual
5724 -- reference). Such a double evaluation is always a potential source
5725 -- of inefficiency, and is functionally incorrect in the volatile case.
5727 if not Is_Entity_Name
(N
) or else Treat_As_Volatile
(Entity
(N
)) then
5728 Force_Evaluation
(N
);
5731 -- The easiest case is when Source_Base_Type and Target_Base_Type are
5732 -- the same since in this case we can simply do a direct check of the
5733 -- value of N against the bounds of Target_Type.
5735 -- [constraint_error when N not in Target_Type]
5737 -- Note: this is by far the most common case, for example all cases of
5738 -- checks on the RHS of assignments are in this category, but not all
5739 -- cases are like this. Notably conversions can involve two types.
5741 if Source_Base_Type
= Target_Base_Type
then
5743 Make_Raise_Constraint_Error
(Loc
,
5746 Left_Opnd
=> Duplicate_Subexpr
(N
),
5747 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
5750 -- Next test for the case where the target type is within the bounds
5751 -- of the base type of the source type, since in this case we can
5752 -- simply convert these bounds to the base type of T to do the test.
5754 -- [constraint_error when N not in
5755 -- Source_Base_Type (Target_Type'First)
5757 -- Source_Base_Type(Target_Type'Last))]
5759 -- The conversions will always work and need no check
5761 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
5762 -- of converting from an enumeration value to an integer type, such as
5763 -- occurs for the case of generating a range check on Enum'Val(Exp)
5764 -- (which used to be handled by gigi). This is OK, since the conversion
5765 -- itself does not require a check.
5767 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
5769 Make_Raise_Constraint_Error
(Loc
,
5772 Left_Opnd
=> Duplicate_Subexpr
(N
),
5777 Unchecked_Convert_To
(Source_Base_Type
,
5778 Make_Attribute_Reference
(Loc
,
5780 New_Occurrence_Of
(Target_Type
, Loc
),
5781 Attribute_Name
=> Name_First
)),
5784 Unchecked_Convert_To
(Source_Base_Type
,
5785 Make_Attribute_Reference
(Loc
,
5787 New_Occurrence_Of
(Target_Type
, Loc
),
5788 Attribute_Name
=> Name_Last
)))),
5791 -- Note that at this stage we now that the Target_Base_Type is not in
5792 -- the range of the Source_Base_Type (since even the Target_Type itself
5793 -- is not in this range). It could still be the case that Source_Type is
5794 -- in range of the target base type since we have not checked that case.
5796 -- If that is the case, we can freely convert the source to the target,
5797 -- and then test the target result against the bounds.
5799 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
5801 -- We make a temporary to hold the value of the converted value
5802 -- (converted to the base type), and then we will do the test against
5805 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
5806 -- [constraint_error when Tnn not in Target_Type]
5808 -- Then the conversion itself is replaced by an occurrence of Tnn
5811 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
5814 Insert_Actions
(N
, New_List
(
5815 Make_Object_Declaration
(Loc
,
5816 Defining_Identifier
=> Tnn
,
5817 Object_Definition
=>
5818 New_Occurrence_Of
(Target_Base_Type
, Loc
),
5819 Constant_Present
=> True,
5821 Make_Type_Conversion
(Loc
,
5822 Subtype_Mark
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
5823 Expression
=> Duplicate_Subexpr
(N
))),
5825 Make_Raise_Constraint_Error
(Loc
,
5828 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
5829 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
5831 Reason
=> Reason
)));
5833 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
5835 -- Set the type of N, because the declaration for Tnn might not
5836 -- be analyzed yet, as is the case if N appears within a record
5837 -- declaration, as a discriminant constraint or expression.
5839 Set_Etype
(N
, Target_Base_Type
);
5842 -- At this stage, we know that we have two scalar types, which are
5843 -- directly convertible, and where neither scalar type has a base
5844 -- range that is in the range of the other scalar type.
5846 -- The only way this can happen is with a signed and unsigned type.
5847 -- So test for these two cases:
5850 -- Case of the source is unsigned and the target is signed
5852 if Is_Unsigned_Type
(Source_Base_Type
)
5853 and then not Is_Unsigned_Type
(Target_Base_Type
)
5855 -- If the source is unsigned and the target is signed, then we
5856 -- know that the source is not shorter than the target (otherwise
5857 -- the source base type would be in the target base type range).
5859 -- In other words, the unsigned type is either the same size as
5860 -- the target, or it is larger. It cannot be smaller.
5863 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
5865 -- We only need to check the low bound if the low bound of the
5866 -- target type is non-negative. If the low bound of the target
5867 -- type is negative, then we know that we will fit fine.
5869 -- If the high bound of the target type is negative, then we
5870 -- know we have a constraint error, since we can't possibly
5871 -- have a negative source.
5873 -- With these two checks out of the way, we can do the check
5874 -- using the source type safely
5876 -- This is definitely the most annoying case!
5878 -- [constraint_error
5879 -- when (Target_Type'First >= 0
5881 -- N < Source_Base_Type (Target_Type'First))
5882 -- or else Target_Type'Last < 0
5883 -- or else N > Source_Base_Type (Target_Type'Last)];
5885 -- We turn off all checks since we know that the conversions
5886 -- will work fine, given the guards for negative values.
5889 Make_Raise_Constraint_Error
(Loc
,
5895 Left_Opnd
=> Make_Op_Ge
(Loc
,
5897 Make_Attribute_Reference
(Loc
,
5899 New_Occurrence_Of
(Target_Type
, Loc
),
5900 Attribute_Name
=> Name_First
),
5901 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
5905 Left_Opnd
=> Duplicate_Subexpr
(N
),
5907 Convert_To
(Source_Base_Type
,
5908 Make_Attribute_Reference
(Loc
,
5910 New_Occurrence_Of
(Target_Type
, Loc
),
5911 Attribute_Name
=> Name_First
)))),
5916 Make_Attribute_Reference
(Loc
,
5917 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
5918 Attribute_Name
=> Name_Last
),
5919 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
5923 Left_Opnd
=> Duplicate_Subexpr
(N
),
5925 Convert_To
(Source_Base_Type
,
5926 Make_Attribute_Reference
(Loc
,
5927 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
5928 Attribute_Name
=> Name_Last
)))),
5931 Suppress
=> All_Checks
);
5933 -- Only remaining possibility is that the source is signed and
5934 -- the target is unsigned.
5937 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
5938 and then Is_Unsigned_Type
(Target_Base_Type
));
5940 -- If the source is signed and the target is unsigned, then we
5941 -- know that the target is not shorter than the source (otherwise
5942 -- the target base type would be in the source base type range).
5944 -- In other words, the unsigned type is either the same size as
5945 -- the target, or it is larger. It cannot be smaller.
5947 -- Clearly we have an error if the source value is negative since
5948 -- no unsigned type can have negative values. If the source type
5949 -- is non-negative, then the check can be done using the target
5952 -- Tnn : constant Target_Base_Type (N) := Target_Type;
5954 -- [constraint_error
5955 -- when N < 0 or else Tnn not in Target_Type];
5957 -- We turn off all checks for the conversion of N to the target
5958 -- base type, since we generate the explicit check to ensure that
5959 -- the value is non-negative
5962 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
5965 Insert_Actions
(N
, New_List
(
5966 Make_Object_Declaration
(Loc
,
5967 Defining_Identifier
=> Tnn
,
5968 Object_Definition
=>
5969 New_Occurrence_Of
(Target_Base_Type
, Loc
),
5970 Constant_Present
=> True,
5972 Make_Unchecked_Type_Conversion
(Loc
,
5974 New_Occurrence_Of
(Target_Base_Type
, Loc
),
5975 Expression
=> Duplicate_Subexpr
(N
))),
5977 Make_Raise_Constraint_Error
(Loc
,
5982 Left_Opnd
=> Duplicate_Subexpr
(N
),
5983 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
5987 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
5989 New_Occurrence_Of
(Target_Type
, Loc
))),
5992 Suppress
=> All_Checks
);
5994 -- Set the Etype explicitly, because Insert_Actions may have
5995 -- placed the declaration in the freeze list for an enclosing
5996 -- construct, and thus it is not analyzed yet.
5998 Set_Etype
(Tnn
, Target_Base_Type
);
5999 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
6003 end Generate_Range_Check
;
6009 function Get_Check_Id
(N
: Name_Id
) return Check_Id
is
6011 -- For standard check name, we can do a direct computation
6013 if N
in First_Check_Name
.. Last_Check_Name
then
6014 return Check_Id
(N
- (First_Check_Name
- 1));
6016 -- For non-standard names added by pragma Check_Name, search table
6019 for J
in All_Checks
+ 1 .. Check_Names
.Last
loop
6020 if Check_Names
.Table
(J
) = N
then
6026 -- No matching name found
6031 ---------------------
6032 -- Get_Discriminal --
6033 ---------------------
6035 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
6036 Loc
: constant Source_Ptr
:= Sloc
(E
);
6041 -- The bound can be a bona fide parameter of a protected operation,
6042 -- rather than a prival encoded as an in-parameter.
6044 if No
(Discriminal_Link
(Entity
(Bound
))) then
6048 -- Climb the scope stack looking for an enclosing protected type. If
6049 -- we run out of scopes, return the bound itself.
6052 while Present
(Sc
) loop
6053 if Sc
= Standard_Standard
then
6056 elsif Ekind
(Sc
) = E_Protected_Type
then
6063 D
:= First_Discriminant
(Sc
);
6064 while Present
(D
) loop
6065 if Chars
(D
) = Chars
(Bound
) then
6066 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
6069 Next_Discriminant
(D
);
6073 end Get_Discriminal
;
6075 ----------------------
6076 -- Get_Range_Checks --
6077 ----------------------
6079 function Get_Range_Checks
6081 Target_Typ
: Entity_Id
;
6082 Source_Typ
: Entity_Id
:= Empty
;
6083 Warn_Node
: Node_Id
:= Empty
) return Check_Result
6086 return Selected_Range_Checks
6087 (Ck_Node
, Target_Typ
, Source_Typ
, Warn_Node
);
6088 end Get_Range_Checks
;
6094 function Guard_Access
6097 Ck_Node
: Node_Id
) return Node_Id
6100 if Nkind
(Cond
) = N_Or_Else
then
6101 Set_Paren_Count
(Cond
, 1);
6104 if Nkind
(Ck_Node
) = N_Allocator
then
6111 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
6112 Right_Opnd
=> Make_Null
(Loc
)),
6113 Right_Opnd
=> Cond
);
6117 -----------------------------
6118 -- Index_Checks_Suppressed --
6119 -----------------------------
6121 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6123 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6124 return Is_Check_Suppressed
(E
, Index_Check
);
6126 return Scope_Suppress
.Suppress
(Index_Check
);
6128 end Index_Checks_Suppressed
;
6134 procedure Initialize
is
6136 for J
in Determine_Range_Cache_N
'Range loop
6137 Determine_Range_Cache_N
(J
) := Empty
;
6142 for J
in Int
range 1 .. All_Checks
loop
6143 Check_Names
.Append
(Name_Id
(Int
(First_Check_Name
) + J
- 1));
6147 -------------------------
6148 -- Insert_Range_Checks --
6149 -------------------------
6151 procedure Insert_Range_Checks
6152 (Checks
: Check_Result
;
6154 Suppress_Typ
: Entity_Id
;
6155 Static_Sloc
: Source_Ptr
:= No_Location
;
6156 Flag_Node
: Node_Id
:= Empty
;
6157 Do_Before
: Boolean := False)
6159 Internal_Flag_Node
: Node_Id
:= Flag_Node
;
6160 Internal_Static_Sloc
: Source_Ptr
:= Static_Sloc
;
6162 Check_Node
: Node_Id
;
6163 Checks_On
: constant Boolean :=
6164 (not Index_Checks_Suppressed
(Suppress_Typ
))
6165 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
6168 -- For now we just return if Checks_On is false, however this should be
6169 -- enhanced to check for an always True value in the condition and to
6170 -- generate a compilation warning???
6172 if not Full_Expander_Active
or else not Checks_On
then
6176 if Static_Sloc
= No_Location
then
6177 Internal_Static_Sloc
:= Sloc
(Node
);
6180 if No
(Flag_Node
) then
6181 Internal_Flag_Node
:= Node
;
6184 for J
in 1 .. 2 loop
6185 exit when No
(Checks
(J
));
6187 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
6188 and then Present
(Condition
(Checks
(J
)))
6190 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
6191 Check_Node
:= Checks
(J
);
6192 Mark_Rewrite_Insertion
(Check_Node
);
6195 Insert_Before_And_Analyze
(Node
, Check_Node
);
6197 Insert_After_And_Analyze
(Node
, Check_Node
);
6200 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
6205 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
6206 Reason
=> CE_Range_Check_Failed
);
6207 Mark_Rewrite_Insertion
(Check_Node
);
6210 Insert_Before_And_Analyze
(Node
, Check_Node
);
6212 Insert_After_And_Analyze
(Node
, Check_Node
);
6216 end Insert_Range_Checks
;
6218 ------------------------
6219 -- Insert_Valid_Check --
6220 ------------------------
6222 procedure Insert_Valid_Check
(Expr
: Node_Id
) is
6223 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6227 -- Do not insert if checks off, or if not checking validity or
6228 -- if expression is known to be valid
6230 if not Validity_Checks_On
6231 or else Range_Or_Validity_Checks_Suppressed
(Expr
)
6232 or else Expr_Known_Valid
(Expr
)
6237 -- If we have a checked conversion, then validity check applies to
6238 -- the expression inside the conversion, not the result, since if
6239 -- the expression inside is valid, then so is the conversion result.
6242 while Nkind
(Exp
) = N_Type_Conversion
loop
6243 Exp
:= Expression
(Exp
);
6246 -- We are about to insert the validity check for Exp. We save and
6247 -- reset the Do_Range_Check flag over this validity check, and then
6248 -- put it back for the final original reference (Exp may be rewritten).
6251 DRC
: constant Boolean := Do_Range_Check
(Exp
);
6256 Set_Do_Range_Check
(Exp
, False);
6258 -- Force evaluation to avoid multiple reads for atomic/volatile
6260 if Is_Entity_Name
(Exp
)
6261 and then Is_Volatile
(Entity
(Exp
))
6263 Force_Evaluation
(Exp
, Name_Req
=> True);
6266 -- Build the prefix for the 'Valid call
6268 PV
:= Duplicate_Subexpr_No_Checks
(Exp
, Name_Req
=> True);
6270 -- A rather specialized kludge. If PV is an analyzed expression
6271 -- which is an indexed component of a packed array that has not
6272 -- been properly expanded, turn off its Analyzed flag to make sure
6273 -- it gets properly reexpanded.
6275 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
6276 -- an analyze with the old parent pointer. This may point e.g. to
6277 -- a subprogram call, which deactivates this expansion.
6280 and then Nkind
(PV
) = N_Indexed_Component
6281 and then Present
(Packed_Array_Type
(Etype
(Prefix
(PV
))))
6283 Set_Analyzed
(PV
, False);
6286 -- Build the raise CE node to check for validity
6289 Make_Raise_Constraint_Error
(Loc
,
6293 Make_Attribute_Reference
(Loc
,
6295 Attribute_Name
=> Name_Valid
)),
6296 Reason
=> CE_Invalid_Data
);
6298 -- Insert the validity check. Note that we do this with validity
6299 -- checks turned off, to avoid recursion, we do not want validity
6300 -- checks on the validity checking code itself!
6302 Insert_Action
(Expr
, CE
, Suppress
=> Validity_Check
);
6304 -- If the expression is a reference to an element of a bit-packed
6305 -- array, then it is rewritten as a renaming declaration. If the
6306 -- expression is an actual in a call, it has not been expanded,
6307 -- waiting for the proper point at which to do it. The same happens
6308 -- with renamings, so that we have to force the expansion now. This
6309 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
6312 if Is_Entity_Name
(Exp
)
6313 and then Nkind
(Parent
(Entity
(Exp
))) =
6314 N_Object_Renaming_Declaration
6317 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
6319 if Nkind
(Old_Exp
) = N_Indexed_Component
6320 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
6322 Expand_Packed_Element_Reference
(Old_Exp
);
6327 -- Put back the Do_Range_Check flag on the resulting (possibly
6328 -- rewritten) expression.
6330 -- Note: it might be thought that a validity check is not required
6331 -- when a range check is present, but that's not the case, because
6332 -- the back end is allowed to assume for the range check that the
6333 -- operand is within its declared range (an assumption that validity
6334 -- checking is all about NOT assuming!)
6336 -- Note: no need to worry about Possible_Local_Raise here, it will
6337 -- already have been called if original node has Do_Range_Check set.
6339 Set_Do_Range_Check
(Exp
, DRC
);
6341 end Insert_Valid_Check
;
6343 -------------------------------------
6344 -- Is_Signed_Integer_Arithmetic_Op --
6345 -------------------------------------
6347 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean is
6350 when N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
6351 N_Op_Minus | N_Op_Mod | N_Op_Multiply | N_Op_Plus |
6352 N_Op_Rem | N_Op_Subtract
=>
6353 return Is_Signed_Integer_Type
(Etype
(N
));
6355 when N_If_Expression | N_Case_Expression
=>
6356 return Is_Signed_Integer_Type
(Etype
(N
));
6361 end Is_Signed_Integer_Arithmetic_Op
;
6363 ----------------------------------
6364 -- Install_Null_Excluding_Check --
6365 ----------------------------------
6367 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
6368 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
6369 Typ
: constant Entity_Id
:= Etype
(N
);
6371 function Safe_To_Capture_In_Parameter_Value
return Boolean;
6372 -- Determines if it is safe to capture Known_Non_Null status for an
6373 -- the entity referenced by node N. The caller ensures that N is indeed
6374 -- an entity name. It is safe to capture the non-null status for an IN
6375 -- parameter when the reference occurs within a declaration that is sure
6376 -- to be executed as part of the declarative region.
6378 procedure Mark_Non_Null
;
6379 -- After installation of check, if the node in question is an entity
6380 -- name, then mark this entity as non-null if possible.
6382 function Safe_To_Capture_In_Parameter_Value
return Boolean is
6383 E
: constant Entity_Id
:= Entity
(N
);
6384 S
: constant Entity_Id
:= Current_Scope
;
6388 if Ekind
(E
) /= E_In_Parameter
then
6392 -- Two initial context checks. We must be inside a subprogram body
6393 -- with declarations and reference must not appear in nested scopes.
6395 if (Ekind
(S
) /= E_Function
and then Ekind
(S
) /= E_Procedure
)
6396 or else Scope
(E
) /= S
6401 S_Par
:= Parent
(Parent
(S
));
6403 if Nkind
(S_Par
) /= N_Subprogram_Body
6404 or else No
(Declarations
(S_Par
))
6414 -- Retrieve the declaration node of N (if any). Note that N
6415 -- may be a part of a complex initialization expression.
6419 while Present
(P
) loop
6421 -- If we have a short circuit form, and we are within the right
6422 -- hand expression, we return false, since the right hand side
6423 -- is not guaranteed to be elaborated.
6425 if Nkind
(P
) in N_Short_Circuit
6426 and then N
= Right_Opnd
(P
)
6431 -- Similarly, if we are in an if expression and not part of the
6432 -- condition, then we return False, since neither the THEN or
6433 -- ELSE dependent expressions will always be elaborated.
6435 if Nkind
(P
) = N_If_Expression
6436 and then N
/= First
(Expressions
(P
))
6441 -- If we are in a case expression, and not part of the
6442 -- expression, then we return False, since a particular
6443 -- dependent expression may not always be elaborated
6445 if Nkind
(P
) = N_Case_Expression
6446 and then N
/= Expression
(P
)
6451 -- While traversing the parent chain, we find that N
6452 -- belongs to a statement, thus it may never appear in
6453 -- a declarative region.
6455 if Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
6456 or else Nkind
(P
) = N_Procedure_Call_Statement
6461 -- If we are at a declaration, record it and exit
6463 if Nkind
(P
) in N_Declaration
6464 and then Nkind
(P
) not in N_Subprogram_Specification
6477 return List_Containing
(N_Decl
) = Declarations
(S_Par
);
6479 end Safe_To_Capture_In_Parameter_Value
;
6485 procedure Mark_Non_Null
is
6487 -- Only case of interest is if node N is an entity name
6489 if Is_Entity_Name
(N
) then
6491 -- For sure, we want to clear an indication that this is known to
6492 -- be null, since if we get past this check, it definitely is not!
6494 Set_Is_Known_Null
(Entity
(N
), False);
6496 -- We can mark the entity as known to be non-null if either it is
6497 -- safe to capture the value, or in the case of an IN parameter,
6498 -- which is a constant, if the check we just installed is in the
6499 -- declarative region of the subprogram body. In this latter case,
6500 -- a check is decisive for the rest of the body if the expression
6501 -- is sure to be elaborated, since we know we have to elaborate
6502 -- all declarations before executing the body.
6504 -- Couldn't this always be part of Safe_To_Capture_Value ???
6506 if Safe_To_Capture_Value
(N
, Entity
(N
))
6507 or else Safe_To_Capture_In_Parameter_Value
6509 Set_Is_Known_Non_Null
(Entity
(N
));
6514 -- Start of processing for Install_Null_Excluding_Check
6517 pragma Assert
(Is_Access_Type
(Typ
));
6519 -- No check inside a generic (why not???)
6521 if Inside_A_Generic
then
6525 -- No check needed if known to be non-null
6527 if Known_Non_Null
(N
) then
6531 -- If known to be null, here is where we generate a compile time check
6533 if Known_Null
(N
) then
6535 -- Avoid generating warning message inside init procs
6537 if not Inside_Init_Proc
then
6538 Apply_Compile_Time_Constraint_Error
6540 "null value not allowed here??",
6541 CE_Access_Check_Failed
);
6544 Make_Raise_Constraint_Error
(Loc
,
6545 Reason
=> CE_Access_Check_Failed
));
6552 -- If entity is never assigned, for sure a warning is appropriate
6554 if Is_Entity_Name
(N
) then
6555 Check_Unset_Reference
(N
);
6558 -- No check needed if checks are suppressed on the range. Note that we
6559 -- don't set Is_Known_Non_Null in this case (we could legitimately do
6560 -- so, since the program is erroneous, but we don't like to casually
6561 -- propagate such conclusions from erroneosity).
6563 if Access_Checks_Suppressed
(Typ
) then
6567 -- No check needed for access to concurrent record types generated by
6568 -- the expander. This is not just an optimization (though it does indeed
6569 -- remove junk checks). It also avoids generation of junk warnings.
6571 if Nkind
(N
) in N_Has_Chars
6572 and then Chars
(N
) = Name_uObject
6573 and then Is_Concurrent_Record_Type
6574 (Directly_Designated_Type
(Etype
(N
)))
6579 -- No check needed for the Get_Current_Excep.all.all idiom generated by
6580 -- the expander within exception handlers, since we know that the value
6581 -- can never be null.
6583 -- Is this really the right way to do this? Normally we generate such
6584 -- code in the expander with checks off, and that's how we suppress this
6585 -- kind of junk check ???
6587 if Nkind
(N
) = N_Function_Call
6588 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
6589 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
6590 and then Is_RTE
(Entity
(Prefix
(Name
(N
))), RE_Get_Current_Excep
)
6595 -- Otherwise install access check
6598 Make_Raise_Constraint_Error
(Loc
,
6601 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
6602 Right_Opnd
=> Make_Null
(Loc
)),
6603 Reason
=> CE_Access_Check_Failed
));
6606 end Install_Null_Excluding_Check
;
6608 --------------------------
6609 -- Install_Static_Check --
6610 --------------------------
6612 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
6613 Stat
: constant Boolean := Is_Static_Expression
(R_Cno
);
6614 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
6618 Make_Raise_Constraint_Error
(Loc
,
6619 Reason
=> CE_Range_Check_Failed
));
6620 Set_Analyzed
(R_Cno
);
6621 Set_Etype
(R_Cno
, Typ
);
6622 Set_Raises_Constraint_Error
(R_Cno
);
6623 Set_Is_Static_Expression
(R_Cno
, Stat
);
6625 -- Now deal with possible local raise handling
6627 Possible_Local_Raise
(R_Cno
, Standard_Constraint_Error
);
6628 end Install_Static_Check
;
6630 -------------------------
6631 -- Is_Check_Suppressed --
6632 -------------------------
6634 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
6635 Ptr
: Suppress_Stack_Entry_Ptr
;
6638 -- First search the local entity suppress stack. We search this from the
6639 -- top of the stack down so that we get the innermost entry that applies
6640 -- to this case if there are nested entries.
6642 Ptr
:= Local_Suppress_Stack_Top
;
6643 while Ptr
/= null loop
6644 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
6645 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
6647 return Ptr
.Suppress
;
6653 -- Now search the global entity suppress table for a matching entry.
6654 -- We also search this from the top down so that if there are multiple
6655 -- pragmas for the same entity, the last one applies (not clear what
6656 -- or whether the RM specifies this handling, but it seems reasonable).
6658 Ptr
:= Global_Suppress_Stack_Top
;
6659 while Ptr
/= null loop
6660 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
6661 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
6663 return Ptr
.Suppress
;
6669 -- If we did not find a matching entry, then use the normal scope
6670 -- suppress value after all (actually this will be the global setting
6671 -- since it clearly was not overridden at any point). For a predefined
6672 -- check, we test the specific flag. For a user defined check, we check
6673 -- the All_Checks flag. The Overflow flag requires special handling to
6674 -- deal with the General vs Assertion case
6676 if C
= Overflow_Check
then
6677 return Overflow_Checks_Suppressed
(Empty
);
6678 elsif C
in Predefined_Check_Id
then
6679 return Scope_Suppress
.Suppress
(C
);
6681 return Scope_Suppress
.Suppress
(All_Checks
);
6683 end Is_Check_Suppressed
;
6685 ---------------------
6686 -- Kill_All_Checks --
6687 ---------------------
6689 procedure Kill_All_Checks
is
6691 if Debug_Flag_CC
then
6692 w
("Kill_All_Checks");
6695 -- We reset the number of saved checks to zero, and also modify all
6696 -- stack entries for statement ranges to indicate that the number of
6697 -- checks at each level is now zero.
6699 Num_Saved_Checks
:= 0;
6701 -- Note: the Int'Min here avoids any possibility of J being out of
6702 -- range when called from e.g. Conditional_Statements_Begin.
6704 for J
in 1 .. Int
'Min (Saved_Checks_TOS
, Saved_Checks_Stack
'Last) loop
6705 Saved_Checks_Stack
(J
) := 0;
6707 end Kill_All_Checks
;
6713 procedure Kill_Checks
(V
: Entity_Id
) is
6715 if Debug_Flag_CC
then
6716 w
("Kill_Checks for entity", Int
(V
));
6719 for J
in 1 .. Num_Saved_Checks
loop
6720 if Saved_Checks
(J
).Entity
= V
then
6721 if Debug_Flag_CC
then
6722 w
(" Checks killed for saved check ", J
);
6725 Saved_Checks
(J
).Killed
:= True;
6730 ------------------------------
6731 -- Length_Checks_Suppressed --
6732 ------------------------------
6734 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6736 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6737 return Is_Check_Suppressed
(E
, Length_Check
);
6739 return Scope_Suppress
.Suppress
(Length_Check
);
6741 end Length_Checks_Suppressed
;
6743 -----------------------
6744 -- Make_Bignum_Block --
6745 -----------------------
6747 function Make_Bignum_Block
(Loc
: Source_Ptr
) return Node_Id
is
6748 M
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uM
);
6752 Make_Block_Statement
(Loc
,
6753 Declarations
=> New_List
(
6754 Make_Object_Declaration
(Loc
,
6755 Defining_Identifier
=> M
,
6756 Object_Definition
=>
6757 New_Occurrence_Of
(RTE
(RE_Mark_Id
), Loc
),
6759 Make_Function_Call
(Loc
,
6760 Name
=> New_Reference_To
(RTE
(RE_SS_Mark
), Loc
)))),
6762 Handled_Statement_Sequence
=>
6763 Make_Handled_Sequence_Of_Statements
(Loc
,
6764 Statements
=> New_List
(
6765 Make_Procedure_Call_Statement
(Loc
,
6766 Name
=> New_Occurrence_Of
(RTE
(RE_SS_Release
), Loc
),
6767 Parameter_Associations
=> New_List
(
6768 New_Reference_To
(M
, Loc
))))));
6769 end Make_Bignum_Block
;
6771 ----------------------------------
6772 -- Minimize_Eliminate_Overflows --
6773 ----------------------------------
6775 -- This is a recursive routine that is called at the top of an expression
6776 -- tree to properly process overflow checking for a whole subtree by making
6777 -- recursive calls to process operands. This processing may involve the use
6778 -- of bignum or long long integer arithmetic, which will change the types
6779 -- of operands and results. That's why we can't do this bottom up (since
6780 -- it would interfere with semantic analysis).
6782 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
6783 -- the operator expansion routines, as well as the expansion routines for
6784 -- if/case expression, do nothing (for the moment) except call the routine
6785 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
6786 -- routine does nothing for non top-level nodes, so at the point where the
6787 -- call is made for the top level node, the entire expression subtree has
6788 -- not been expanded, or processed for overflow. All that has to happen as
6789 -- a result of the top level call to this routine.
6791 -- As noted above, the overflow processing works by making recursive calls
6792 -- for the operands, and figuring out what to do, based on the processing
6793 -- of these operands (e.g. if a bignum operand appears, the parent op has
6794 -- to be done in bignum mode), and the determined ranges of the operands.
6796 -- After possible rewriting of a constituent subexpression node, a call is
6797 -- made to either reexpand the node (if nothing has changed) or reanalyze
6798 -- the node (if it has been modified by the overflow check processing). The
6799 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
6800 -- a recursive call into the whole overflow apparatus, an important rule
6801 -- for this call is that the overflow handling mode must be temporarily set
6804 procedure Minimize_Eliminate_Overflows
6808 Top_Level
: Boolean)
6810 Rtyp
: constant Entity_Id
:= Etype
(N
);
6811 pragma Assert
(Is_Signed_Integer_Type
(Rtyp
));
6812 -- Result type, must be a signed integer type
6814 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
6815 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
6817 Loc
: constant Source_Ptr
:= Sloc
(N
);
6820 -- Ranges of values for right operand (operator case)
6823 -- Ranges of values for left operand (operator case)
6825 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
6826 -- Operands and results are of this type when we convert
6828 LLLo
: constant Uint
:= Intval
(Type_Low_Bound
(LLIB
));
6829 LLHi
: constant Uint
:= Intval
(Type_High_Bound
(LLIB
));
6830 -- Bounds of Long_Long_Integer
6832 Binary
: constant Boolean := Nkind
(N
) in N_Binary_Op
;
6833 -- Indicates binary operator case
6836 -- Used in call to Determine_Range
6838 Bignum_Operands
: Boolean;
6839 -- Set True if one or more operands is already of type Bignum, meaning
6840 -- that for sure (regardless of Top_Level setting) we are committed to
6841 -- doing the operation in Bignum mode (or in the case of a case or if
6842 -- expression, converting all the dependent expressions to Bignum).
6844 Long_Long_Integer_Operands
: Boolean;
6845 -- Set True if one or more operands is already of type Long_Long_Integer
6846 -- which means that if the result is known to be in the result type
6847 -- range, then we must convert such operands back to the result type.
6849 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False);
6850 -- This is called when we have modified the node and we therefore need
6851 -- to reanalyze it. It is important that we reset the mode to STRICT for
6852 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
6853 -- we would reenter this routine recursively which would not be good!
6854 -- The argument Suppress is set True if we also want to suppress
6855 -- overflow checking for the reexpansion (this is set when we know
6856 -- overflow is not possible). Typ is the type for the reanalysis.
6858 procedure Reexpand
(Suppress
: Boolean := False);
6859 -- This is like Reanalyze, but does not do the Analyze step, it only
6860 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
6861 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
6862 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
6863 -- Note that skipping reanalysis is not just an optimization, testing
6864 -- has showed up several complex cases in which reanalyzing an already
6865 -- analyzed node causes incorrect behavior.
6867 function In_Result_Range
return Boolean;
6868 -- Returns True iff Lo .. Hi are within range of the result type
6870 procedure Max
(A
: in out Uint
; B
: Uint
);
6871 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
6873 procedure Min
(A
: in out Uint
; B
: Uint
);
6874 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
6876 ---------------------
6877 -- In_Result_Range --
6878 ---------------------
6880 function In_Result_Range
return Boolean is
6882 if Lo
= No_Uint
or else Hi
= No_Uint
then
6885 elsif Is_Static_Subtype
(Etype
(N
)) then
6886 return Lo
>= Expr_Value
(Type_Low_Bound
(Rtyp
))
6888 Hi
<= Expr_Value
(Type_High_Bound
(Rtyp
));
6891 return Lo
>= Expr_Value
(Type_Low_Bound
(Base_Type
(Rtyp
)))
6893 Hi
<= Expr_Value
(Type_High_Bound
(Base_Type
(Rtyp
)));
6895 end In_Result_Range
;
6901 procedure Max
(A
: in out Uint
; B
: Uint
) is
6903 if A
= No_Uint
or else B
> A
then
6912 procedure Min
(A
: in out Uint
; B
: Uint
) is
6914 if A
= No_Uint
or else B
< A
then
6923 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False) is
6924 Svg
: constant Overflow_Mode_Type
:=
6925 Scope_Suppress
.Overflow_Mode_General
;
6926 Sva
: constant Overflow_Mode_Type
:=
6927 Scope_Suppress
.Overflow_Mode_Assertions
;
6928 Svo
: constant Boolean :=
6929 Scope_Suppress
.Suppress
(Overflow_Check
);
6932 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
6933 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
6936 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
6939 Analyze_And_Resolve
(N
, Typ
);
6941 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
6942 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
6943 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
6950 procedure Reexpand
(Suppress
: Boolean := False) is
6951 Svg
: constant Overflow_Mode_Type
:=
6952 Scope_Suppress
.Overflow_Mode_General
;
6953 Sva
: constant Overflow_Mode_Type
:=
6954 Scope_Suppress
.Overflow_Mode_Assertions
;
6955 Svo
: constant Boolean :=
6956 Scope_Suppress
.Suppress
(Overflow_Check
);
6959 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
6960 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
6961 Set_Analyzed
(N
, False);
6964 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
6969 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
6970 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
6971 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
6974 -- Start of processing for Minimize_Eliminate_Overflows
6977 -- Case where we do not have a signed integer arithmetic operation
6979 if not Is_Signed_Integer_Arithmetic_Op
(N
) then
6981 -- Use the normal Determine_Range routine to get the range. We
6982 -- don't require operands to be valid, invalid values may result in
6983 -- rubbish results where the result has not been properly checked for
6984 -- overflow, that's fine!
6986 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> False);
6988 -- If Determine_Range did not work (can this in fact happen? Not
6989 -- clear but might as well protect), use type bounds.
6992 Lo
:= Intval
(Type_Low_Bound
(Base_Type
(Etype
(N
))));
6993 Hi
:= Intval
(Type_High_Bound
(Base_Type
(Etype
(N
))));
6996 -- If we don't have a binary operator, all we have to do is to set
6997 -- the Hi/Lo range, so we are done
7001 -- Processing for if expression
7003 elsif Nkind
(N
) = N_If_Expression
then
7005 Then_DE
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
7006 Else_DE
: constant Node_Id
:= Next
(Then_DE
);
7009 Bignum_Operands
:= False;
7011 Minimize_Eliminate_Overflows
7012 (Then_DE
, Lo
, Hi
, Top_Level
=> False);
7014 if Lo
= No_Uint
then
7015 Bignum_Operands
:= True;
7018 Minimize_Eliminate_Overflows
7019 (Else_DE
, Rlo
, Rhi
, Top_Level
=> False);
7021 if Rlo
= No_Uint
then
7022 Bignum_Operands
:= True;
7024 Long_Long_Integer_Operands
:=
7025 Etype
(Then_DE
) = LLIB
or else Etype
(Else_DE
) = LLIB
;
7031 -- If at least one of our operands is now Bignum, we must rebuild
7032 -- the if expression to use Bignum operands. We will analyze the
7033 -- rebuilt if expression with overflow checks off, since once we
7034 -- are in bignum mode, we are all done with overflow checks!
7036 if Bignum_Operands
then
7038 Make_If_Expression
(Loc
,
7039 Expressions
=> New_List
(
7040 Remove_Head
(Expressions
(N
)),
7041 Convert_To_Bignum
(Then_DE
),
7042 Convert_To_Bignum
(Else_DE
)),
7043 Is_Elsif
=> Is_Elsif
(N
)));
7045 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
7047 -- If we have no Long_Long_Integer operands, then we are in result
7048 -- range, since it means that none of our operands felt the need
7049 -- to worry about overflow (otherwise it would have already been
7050 -- converted to long long integer or bignum). We reexpand to
7051 -- complete the expansion of the if expression (but we do not
7052 -- need to reanalyze).
7054 elsif not Long_Long_Integer_Operands
then
7055 Set_Do_Overflow_Check
(N
, False);
7058 -- Otherwise convert us to long long integer mode. Note that we
7059 -- don't need any further overflow checking at this level.
7062 Convert_To_And_Rewrite
(LLIB
, Then_DE
);
7063 Convert_To_And_Rewrite
(LLIB
, Else_DE
);
7064 Set_Etype
(N
, LLIB
);
7066 -- Now reanalyze with overflow checks off
7068 Set_Do_Overflow_Check
(N
, False);
7069 Reanalyze
(LLIB
, Suppress
=> True);
7075 -- Here for case expression
7077 elsif Nkind
(N
) = N_Case_Expression
then
7078 Bignum_Operands
:= False;
7079 Long_Long_Integer_Operands
:= False;
7085 -- Loop through expressions applying recursive call
7087 Alt
:= First
(Alternatives
(N
));
7088 while Present
(Alt
) loop
7090 Aexp
: constant Node_Id
:= Expression
(Alt
);
7093 Minimize_Eliminate_Overflows
7094 (Aexp
, Lo
, Hi
, Top_Level
=> False);
7096 if Lo
= No_Uint
then
7097 Bignum_Operands
:= True;
7098 elsif Etype
(Aexp
) = LLIB
then
7099 Long_Long_Integer_Operands
:= True;
7106 -- If we have no bignum or long long integer operands, it means
7107 -- that none of our dependent expressions could raise overflow.
7108 -- In this case, we simply return with no changes except for
7109 -- resetting the overflow flag, since we are done with overflow
7110 -- checks for this node. We will reexpand to get the needed
7111 -- expansion for the case expression, but we do not need to
7112 -- reanalyze, since nothing has changed.
7114 if not (Bignum_Operands
or Long_Long_Integer_Operands
) then
7115 Set_Do_Overflow_Check
(N
, False);
7116 Reexpand
(Suppress
=> True);
7118 -- Otherwise we are going to rebuild the case expression using
7119 -- either bignum or long long integer operands throughout.
7128 New_Alts
:= New_List
;
7129 Alt
:= First
(Alternatives
(N
));
7130 while Present
(Alt
) loop
7131 if Bignum_Operands
then
7132 New_Exp
:= Convert_To_Bignum
(Expression
(Alt
));
7133 Rtype
:= RTE
(RE_Bignum
);
7135 New_Exp
:= Convert_To
(LLIB
, Expression
(Alt
));
7139 Append_To
(New_Alts
,
7140 Make_Case_Expression_Alternative
(Sloc
(Alt
),
7142 Discrete_Choices
=> Discrete_Choices
(Alt
),
7143 Expression
=> New_Exp
));
7149 Make_Case_Expression
(Loc
,
7150 Expression
=> Expression
(N
),
7151 Alternatives
=> New_Alts
));
7153 Reanalyze
(Rtype
, Suppress
=> True);
7161 -- If we have an arithmetic operator we make recursive calls on the
7162 -- operands to get the ranges (and to properly process the subtree
7163 -- that lies below us!)
7165 Minimize_Eliminate_Overflows
7166 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
7169 Minimize_Eliminate_Overflows
7170 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
7173 -- Record if we have Long_Long_Integer operands
7175 Long_Long_Integer_Operands
:=
7176 Etype
(Right_Opnd
(N
)) = LLIB
7177 or else (Binary
and then Etype
(Left_Opnd
(N
)) = LLIB
);
7179 -- If either operand is a bignum, then result will be a bignum and we
7180 -- don't need to do any range analysis. As previously discussed we could
7181 -- do range analysis in such cases, but it could mean working with giant
7182 -- numbers at compile time for very little gain (the number of cases
7183 -- in which we could slip back from bignum mode is small).
7185 if Rlo
= No_Uint
or else (Binary
and then Llo
= No_Uint
) then
7188 Bignum_Operands
:= True;
7190 -- Otherwise compute result range
7193 Bignum_Operands
:= False;
7201 Hi
:= UI_Max
(abs Rlo
, abs Rhi
);
7213 -- If the right operand can only be zero, set 0..0
7215 if Rlo
= 0 and then Rhi
= 0 then
7219 -- Possible bounds of division must come from dividing end
7220 -- values of the input ranges (four possibilities), provided
7221 -- zero is not included in the possible values of the right
7224 -- Otherwise, we just consider two intervals of values for
7225 -- the right operand: the interval of negative values (up to
7226 -- -1) and the interval of positive values (starting at 1).
7227 -- Since division by 1 is the identity, and division by -1
7228 -- is negation, we get all possible bounds of division in that
7229 -- case by considering:
7230 -- - all values from the division of end values of input
7232 -- - the end values of the left operand;
7233 -- - the negation of the end values of the left operand.
7237 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
7238 -- Mark so we can release the RR and Ev values
7246 -- Discard extreme values of zero for the divisor, since
7247 -- they will simply result in an exception in any case.
7255 -- Compute possible bounds coming from dividing end
7256 -- values of the input ranges.
7263 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
7264 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
7266 -- If the right operand can be both negative or positive,
7267 -- include the end values of the left operand in the
7268 -- extreme values, as well as their negation.
7270 if Rlo
< 0 and then Rhi
> 0 then
7277 UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
)));
7279 UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
)));
7282 -- Release the RR and Ev values
7284 Release_And_Save
(Mrk
, Lo
, Hi
);
7292 -- Discard negative values for the exponent, since they will
7293 -- simply result in an exception in any case.
7301 -- Estimate number of bits in result before we go computing
7302 -- giant useless bounds. Basically the number of bits in the
7303 -- result is the number of bits in the base multiplied by the
7304 -- value of the exponent. If this is big enough that the result
7305 -- definitely won't fit in Long_Long_Integer, switch to bignum
7306 -- mode immediately, and avoid computing giant bounds.
7308 -- The comparison here is approximate, but conservative, it
7309 -- only clicks on cases that are sure to exceed the bounds.
7311 if Num_Bits
(UI_Max
(abs Llo
, abs Lhi
)) * Rhi
+ 1 > 100 then
7315 -- If right operand is zero then result is 1
7322 -- High bound comes either from exponentiation of largest
7323 -- positive value to largest exponent value, or from
7324 -- the exponentiation of most negative value to an
7338 if Rhi
mod 2 = 0 then
7341 Hi2
:= Llo
** (Rhi
- 1);
7347 Hi
:= UI_Max
(Hi1
, Hi2
);
7350 -- Result can only be negative if base can be negative
7353 if Rhi
mod 2 = 0 then
7354 Lo
:= Llo
** (Rhi
- 1);
7359 -- Otherwise low bound is minimum ** minimum
7376 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
7377 -- This is the maximum absolute value of the result
7383 -- The result depends only on the sign and magnitude of
7384 -- the right operand, it does not depend on the sign or
7385 -- magnitude of the left operand.
7398 when N_Op_Multiply
=>
7400 -- Possible bounds of multiplication must come from multiplying
7401 -- end values of the input ranges (four possibilities).
7404 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
7405 -- Mark so we can release the Ev values
7407 Ev1
: constant Uint
:= Llo
* Rlo
;
7408 Ev2
: constant Uint
:= Llo
* Rhi
;
7409 Ev3
: constant Uint
:= Lhi
* Rlo
;
7410 Ev4
: constant Uint
:= Lhi
* Rhi
;
7413 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
7414 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
7416 -- Release the Ev values
7418 Release_And_Save
(Mrk
, Lo
, Hi
);
7421 -- Plus operator (affirmation)
7431 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
7432 -- This is the maximum absolute value of the result. Note
7433 -- that the result range does not depend on the sign of the
7440 -- Case of left operand negative, which results in a range
7441 -- of -Maxabs .. 0 for those negative values. If there are
7442 -- no negative values then Lo value of result is always 0.
7448 -- Case of left operand positive
7457 when N_Op_Subtract
=>
7461 -- Nothing else should be possible
7464 raise Program_Error
;
7468 -- Here for the case where we have not rewritten anything (no bignum
7469 -- operands or long long integer operands), and we know the result.
7470 -- If we know we are in the result range, and we do not have Bignum
7471 -- operands or Long_Long_Integer operands, we can just reexpand with
7472 -- overflow checks turned off (since we know we cannot have overflow).
7473 -- As always the reexpansion is required to complete expansion of the
7474 -- operator, but we do not need to reanalyze, and we prevent recursion
7475 -- by suppressing the check.
7477 if not (Bignum_Operands
or Long_Long_Integer_Operands
)
7478 and then In_Result_Range
7480 Set_Do_Overflow_Check
(N
, False);
7481 Reexpand
(Suppress
=> True);
7484 -- Here we know that we are not in the result range, and in the general
7485 -- case we will move into either the Bignum or Long_Long_Integer domain
7486 -- to compute the result. However, there is one exception. If we are
7487 -- at the top level, and we do not have Bignum or Long_Long_Integer
7488 -- operands, we will have to immediately convert the result back to
7489 -- the result type, so there is no point in Bignum/Long_Long_Integer
7493 and then not (Bignum_Operands
or Long_Long_Integer_Operands
)
7495 -- One further refinement. If we are at the top level, but our parent
7496 -- is a type conversion, then go into bignum or long long integer node
7497 -- since the result will be converted to that type directly without
7498 -- going through the result type, and we may avoid an overflow. This
7499 -- is the case for example of Long_Long_Integer (A ** 4), where A is
7500 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
7501 -- but does not fit in Integer.
7503 and then Nkind
(Parent
(N
)) /= N_Type_Conversion
7505 -- Here keep original types, but we need to complete analysis
7507 -- One subtlety. We can't just go ahead and do an analyze operation
7508 -- here because it will cause recursion into the whole MINIMIZED/
7509 -- ELIMINATED overflow processing which is not what we want. Here
7510 -- we are at the top level, and we need a check against the result
7511 -- mode (i.e. we want to use STRICT mode). So do exactly that!
7512 -- Also, we have not modified the node, so this is a case where
7513 -- we need to reexpand, but not reanalyze.
7518 -- Cases where we do the operation in Bignum mode. This happens either
7519 -- because one of our operands is in Bignum mode already, or because
7520 -- the computed bounds are outside the bounds of Long_Long_Integer,
7521 -- which in some cases can be indicated by Hi and Lo being No_Uint.
7523 -- Note: we could do better here and in some cases switch back from
7524 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
7525 -- 0 .. 1, but the cases are rare and it is not worth the effort.
7526 -- Failing to do this switching back is only an efficiency issue.
7528 elsif Lo
= No_Uint
or else Lo
< LLLo
or else Hi
> LLHi
then
7530 -- OK, we are definitely outside the range of Long_Long_Integer. The
7531 -- question is whether to move to Bignum mode, or stay in the domain
7532 -- of Long_Long_Integer, signalling that an overflow check is needed.
7534 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
7535 -- the Bignum business. In ELIMINATED mode, we will normally move
7536 -- into Bignum mode, but there is an exception if neither of our
7537 -- operands is Bignum now, and we are at the top level (Top_Level
7538 -- set True). In this case, there is no point in moving into Bignum
7539 -- mode to prevent overflow if the caller will immediately convert
7540 -- the Bignum value back to LLI with an overflow check. It's more
7541 -- efficient to stay in LLI mode with an overflow check (if needed)
7543 if Check_Mode
= Minimized
7544 or else (Top_Level
and not Bignum_Operands
)
7546 if Do_Overflow_Check
(N
) then
7547 Enable_Overflow_Check
(N
);
7550 -- The result now has to be in Long_Long_Integer mode, so adjust
7551 -- the possible range to reflect this. Note these calls also
7552 -- change No_Uint values from the top level case to LLI bounds.
7557 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
7560 pragma Assert
(Check_Mode
= Eliminated
);
7569 Fent
:= RTE
(RE_Big_Abs
);
7572 Fent
:= RTE
(RE_Big_Add
);
7575 Fent
:= RTE
(RE_Big_Div
);
7578 Fent
:= RTE
(RE_Big_Exp
);
7581 Fent
:= RTE
(RE_Big_Neg
);
7584 Fent
:= RTE
(RE_Big_Mod
);
7586 when N_Op_Multiply
=>
7587 Fent
:= RTE
(RE_Big_Mul
);
7590 Fent
:= RTE
(RE_Big_Rem
);
7592 when N_Op_Subtract
=>
7593 Fent
:= RTE
(RE_Big_Sub
);
7595 -- Anything else is an internal error, this includes the
7596 -- N_Op_Plus case, since how can plus cause the result
7597 -- to be out of range if the operand is in range?
7600 raise Program_Error
;
7603 -- Construct argument list for Bignum call, converting our
7604 -- operands to Bignum form if they are not already there.
7609 Append_To
(Args
, Convert_To_Bignum
(Left_Opnd
(N
)));
7612 Append_To
(Args
, Convert_To_Bignum
(Right_Opnd
(N
)));
7614 -- Now rewrite the arithmetic operator with a call to the
7615 -- corresponding bignum function.
7618 Make_Function_Call
(Loc
,
7619 Name
=> New_Occurrence_Of
(Fent
, Loc
),
7620 Parameter_Associations
=> Args
));
7621 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
7623 -- Indicate result is Bignum mode
7631 -- Otherwise we are in range of Long_Long_Integer, so no overflow
7632 -- check is required, at least not yet.
7635 Set_Do_Overflow_Check
(N
, False);
7638 -- Here we are not in Bignum territory, but we may have long long
7639 -- integer operands that need special handling. First a special check:
7640 -- If an exponentiation operator exponent is of type Long_Long_Integer,
7641 -- it means we converted it to prevent overflow, but exponentiation
7642 -- requires a Natural right operand, so convert it back to Natural.
7643 -- This conversion may raise an exception which is fine.
7645 if Nkind
(N
) = N_Op_Expon
and then Etype
(Right_Opnd
(N
)) = LLIB
then
7646 Convert_To_And_Rewrite
(Standard_Natural
, Right_Opnd
(N
));
7649 -- Here we will do the operation in Long_Long_Integer. We do this even
7650 -- if we know an overflow check is required, better to do this in long
7651 -- long integer mode, since we are less likely to overflow!
7653 -- Convert right or only operand to Long_Long_Integer, except that
7654 -- we do not touch the exponentiation right operand.
7656 if Nkind
(N
) /= N_Op_Expon
then
7657 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
7660 -- Convert left operand to Long_Long_Integer for binary case
7663 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
7666 -- Reset node to unanalyzed
7668 Set_Analyzed
(N
, False);
7669 Set_Etype
(N
, Empty
);
7670 Set_Entity
(N
, Empty
);
7672 -- Now analyze this new node. This reanalysis will complete processing
7673 -- for the node. In particular we will complete the expansion of an
7674 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
7675 -- we will complete any division checks (since we have not changed the
7676 -- setting of the Do_Division_Check flag).
7678 -- We do this reanalysis in STRICT mode to avoid recursion into the
7679 -- MINIMIZED/ELIMINATED handling, since we are now done with that!
7682 SG
: constant Overflow_Mode_Type
:=
7683 Scope_Suppress
.Overflow_Mode_General
;
7684 SA
: constant Overflow_Mode_Type
:=
7685 Scope_Suppress
.Overflow_Mode_Assertions
;
7688 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7689 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7691 if not Do_Overflow_Check
(N
) then
7692 Reanalyze
(LLIB
, Suppress
=> True);
7697 Scope_Suppress
.Overflow_Mode_General
:= SG
;
7698 Scope_Suppress
.Overflow_Mode_Assertions
:= SA
;
7700 end Minimize_Eliminate_Overflows
;
7702 -------------------------
7703 -- Overflow_Check_Mode --
7704 -------------------------
7706 function Overflow_Check_Mode
return Overflow_Mode_Type
is
7708 if In_Assertion_Expr
= 0 then
7709 return Scope_Suppress
.Overflow_Mode_General
;
7711 return Scope_Suppress
.Overflow_Mode_Assertions
;
7713 end Overflow_Check_Mode
;
7715 --------------------------------
7716 -- Overflow_Checks_Suppressed --
7717 --------------------------------
7719 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7721 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7722 return Is_Check_Suppressed
(E
, Overflow_Check
);
7724 return Scope_Suppress
.Suppress
(Overflow_Check
);
7726 end Overflow_Checks_Suppressed
;
7728 -----------------------------
7729 -- Range_Checks_Suppressed --
7730 -----------------------------
7732 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7736 -- Note: for now we always suppress range checks on Vax float types,
7737 -- since Gigi does not know how to generate these checks.
7739 if Vax_Float
(E
) then
7741 elsif Kill_Range_Checks
(E
) then
7743 elsif Checks_May_Be_Suppressed
(E
) then
7744 return Is_Check_Suppressed
(E
, Range_Check
);
7748 return Scope_Suppress
.Suppress
(Range_Check
);
7749 end Range_Checks_Suppressed
;
7751 -----------------------------------------
7752 -- Range_Or_Validity_Checks_Suppressed --
7753 -----------------------------------------
7755 -- Note: the coding would be simpler here if we simply made appropriate
7756 -- calls to Range/Validity_Checks_Suppressed, but that would result in
7757 -- duplicated checks which we prefer to avoid.
7759 function Range_Or_Validity_Checks_Suppressed
7760 (Expr
: Node_Id
) return Boolean
7763 -- Immediate return if scope checks suppressed for either check
7765 if Scope_Suppress
.Suppress
(Range_Check
)
7767 Scope_Suppress
.Suppress
(Validity_Check
)
7772 -- If no expression, that's odd, decide that checks are suppressed,
7773 -- since we don't want anyone trying to do checks in this case, which
7774 -- is most likely the result of some other error.
7780 -- Expression is present, so perform suppress checks on type
7783 Typ
: constant Entity_Id
:= Etype
(Expr
);
7785 if Vax_Float
(Typ
) then
7787 elsif Checks_May_Be_Suppressed
(Typ
)
7788 and then (Is_Check_Suppressed
(Typ
, Range_Check
)
7790 Is_Check_Suppressed
(Typ
, Validity_Check
))
7796 -- If expression is an entity name, perform checks on this entity
7798 if Is_Entity_Name
(Expr
) then
7800 Ent
: constant Entity_Id
:= Entity
(Expr
);
7802 if Checks_May_Be_Suppressed
(Ent
) then
7803 return Is_Check_Suppressed
(Ent
, Range_Check
)
7804 or else Is_Check_Suppressed
(Ent
, Validity_Check
);
7809 -- If we fall through, no checks suppressed
7812 end Range_Or_Validity_Checks_Suppressed
;
7818 procedure Remove_Checks
(Expr
: Node_Id
) is
7819 function Process
(N
: Node_Id
) return Traverse_Result
;
7820 -- Process a single node during the traversal
7822 procedure Traverse
is new Traverse_Proc
(Process
);
7823 -- The traversal procedure itself
7829 function Process
(N
: Node_Id
) return Traverse_Result
is
7831 if Nkind
(N
) not in N_Subexpr
then
7835 Set_Do_Range_Check
(N
, False);
7839 Traverse
(Left_Opnd
(N
));
7842 when N_Attribute_Reference
=>
7843 Set_Do_Overflow_Check
(N
, False);
7845 when N_Function_Call
=>
7846 Set_Do_Tag_Check
(N
, False);
7849 Set_Do_Overflow_Check
(N
, False);
7853 Set_Do_Division_Check
(N
, False);
7856 Set_Do_Length_Check
(N
, False);
7859 Set_Do_Division_Check
(N
, False);
7862 Set_Do_Length_Check
(N
, False);
7865 Set_Do_Division_Check
(N
, False);
7868 Set_Do_Length_Check
(N
, False);
7875 Traverse
(Left_Opnd
(N
));
7878 when N_Selected_Component
=>
7879 Set_Do_Discriminant_Check
(N
, False);
7881 when N_Type_Conversion
=>
7882 Set_Do_Length_Check
(N
, False);
7883 Set_Do_Tag_Check
(N
, False);
7884 Set_Do_Overflow_Check
(N
, False);
7893 -- Start of processing for Remove_Checks
7899 ----------------------------
7900 -- Selected_Length_Checks --
7901 ----------------------------
7903 function Selected_Length_Checks
7905 Target_Typ
: Entity_Id
;
7906 Source_Typ
: Entity_Id
;
7907 Warn_Node
: Node_Id
) return Check_Result
7909 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
7912 Expr_Actual
: Node_Id
;
7914 Cond
: Node_Id
:= Empty
;
7915 Do_Access
: Boolean := False;
7916 Wnode
: Node_Id
:= Warn_Node
;
7917 Ret_Result
: Check_Result
:= (Empty
, Empty
);
7918 Num_Checks
: Natural := 0;
7920 procedure Add_Check
(N
: Node_Id
);
7921 -- Adds the action given to Ret_Result if N is non-Empty
7923 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
7924 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
7925 -- Comments required ???
7927 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
7928 -- True for equal literals and for nodes that denote the same constant
7929 -- entity, even if its value is not a static constant. This includes the
7930 -- case of a discriminal reference within an init proc. Removes some
7931 -- obviously superfluous checks.
7933 function Length_E_Cond
7934 (Exptyp
: Entity_Id
;
7936 Indx
: Nat
) return Node_Id
;
7937 -- Returns expression to compute:
7938 -- Typ'Length /= Exptyp'Length
7940 function Length_N_Cond
7943 Indx
: Nat
) return Node_Id
;
7944 -- Returns expression to compute:
7945 -- Typ'Length /= Expr'Length
7951 procedure Add_Check
(N
: Node_Id
) is
7955 -- For now, ignore attempt to place more than 2 checks ???
7957 if Num_Checks
= 2 then
7961 pragma Assert
(Num_Checks
<= 1);
7962 Num_Checks
:= Num_Checks
+ 1;
7963 Ret_Result
(Num_Checks
) := N
;
7971 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
7972 SE
: constant Entity_Id
:= Scope
(E
);
7974 E1
: Entity_Id
:= E
;
7977 if Ekind
(Scope
(E
)) = E_Record_Type
7978 and then Has_Discriminants
(Scope
(E
))
7980 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
7983 Insert_Action
(Ck_Node
, N
);
7984 E1
:= Defining_Identifier
(N
);
7988 if Ekind
(E1
) = E_String_Literal_Subtype
then
7990 Make_Integer_Literal
(Loc
,
7991 Intval
=> String_Literal_Length
(E1
));
7993 elsif SE
/= Standard_Standard
7994 and then Ekind
(Scope
(SE
)) = E_Protected_Type
7995 and then Has_Discriminants
(Scope
(SE
))
7996 and then Has_Completion
(Scope
(SE
))
7997 and then not Inside_Init_Proc
7999 -- If the type whose length is needed is a private component
8000 -- constrained by a discriminant, we must expand the 'Length
8001 -- attribute into an explicit computation, using the discriminal
8002 -- of the current protected operation. This is because the actual
8003 -- type of the prival is constructed after the protected opera-
8004 -- tion has been fully expanded.
8007 Indx_Type
: Node_Id
;
8010 Do_Expand
: Boolean := False;
8013 Indx_Type
:= First_Index
(E
);
8015 for J
in 1 .. Indx
- 1 loop
8016 Next_Index
(Indx_Type
);
8019 Get_Index_Bounds
(Indx_Type
, Lo
, Hi
);
8021 if Nkind
(Lo
) = N_Identifier
8022 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
8024 Lo
:= Get_Discriminal
(E
, Lo
);
8028 if Nkind
(Hi
) = N_Identifier
8029 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
8031 Hi
:= Get_Discriminal
(E
, Hi
);
8036 if not Is_Entity_Name
(Lo
) then
8037 Lo
:= Duplicate_Subexpr_No_Checks
(Lo
);
8040 if not Is_Entity_Name
(Hi
) then
8041 Lo
:= Duplicate_Subexpr_No_Checks
(Hi
);
8047 Make_Op_Subtract
(Loc
,
8051 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
8056 Make_Attribute_Reference
(Loc
,
8057 Attribute_Name
=> Name_Length
,
8059 New_Occurrence_Of
(E1
, Loc
));
8062 Set_Expressions
(N
, New_List
(
8063 Make_Integer_Literal
(Loc
, Indx
)));
8072 Make_Attribute_Reference
(Loc
,
8073 Attribute_Name
=> Name_Length
,
8075 New_Occurrence_Of
(E1
, Loc
));
8078 Set_Expressions
(N
, New_List
(
8079 Make_Integer_Literal
(Loc
, Indx
)));
8090 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8093 Make_Attribute_Reference
(Loc
,
8094 Attribute_Name
=> Name_Length
,
8096 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8097 Expressions
=> New_List
(
8098 Make_Integer_Literal
(Loc
, Indx
)));
8105 function Length_E_Cond
8106 (Exptyp
: Entity_Id
;
8108 Indx
: Nat
) return Node_Id
8113 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8114 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
8121 function Length_N_Cond
8124 Indx
: Nat
) return Node_Id
8129 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8130 Right_Opnd
=> Get_N_Length
(Expr
, Indx
));
8137 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
8140 (Nkind
(L
) = N_Integer_Literal
8141 and then Nkind
(R
) = N_Integer_Literal
8142 and then Intval
(L
) = Intval
(R
))
8146 and then Ekind
(Entity
(L
)) = E_Constant
8147 and then ((Is_Entity_Name
(R
)
8148 and then Entity
(L
) = Entity
(R
))
8150 (Nkind
(R
) = N_Type_Conversion
8151 and then Is_Entity_Name
(Expression
(R
))
8152 and then Entity
(L
) = Entity
(Expression
(R
)))))
8156 and then Ekind
(Entity
(R
)) = E_Constant
8157 and then Nkind
(L
) = N_Type_Conversion
8158 and then Is_Entity_Name
(Expression
(L
))
8159 and then Entity
(R
) = Entity
(Expression
(L
)))
8163 and then Is_Entity_Name
(R
)
8164 and then Entity
(L
) = Entity
(R
)
8165 and then Ekind
(Entity
(L
)) = E_In_Parameter
8166 and then Inside_Init_Proc
);
8169 -- Start of processing for Selected_Length_Checks
8172 if not Full_Expander_Active
then
8176 if Target_Typ
= Any_Type
8177 or else Target_Typ
= Any_Composite
8178 or else Raises_Constraint_Error
(Ck_Node
)
8187 T_Typ
:= Target_Typ
;
8189 if No
(Source_Typ
) then
8190 S_Typ
:= Etype
(Ck_Node
);
8192 S_Typ
:= Source_Typ
;
8195 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
8199 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
8200 S_Typ
:= Designated_Type
(S_Typ
);
8201 T_Typ
:= Designated_Type
(T_Typ
);
8204 -- A simple optimization for the null case
8206 if Known_Null
(Ck_Node
) then
8211 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
8212 if Is_Constrained
(T_Typ
) then
8214 -- The checking code to be generated will freeze the corresponding
8215 -- array type. However, we must freeze the type now, so that the
8216 -- freeze node does not appear within the generated if expression,
8219 Freeze_Before
(Ck_Node
, T_Typ
);
8221 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
8222 Exptyp
:= Get_Actual_Subtype
(Ck_Node
);
8224 if Is_Access_Type
(Exptyp
) then
8225 Exptyp
:= Designated_Type
(Exptyp
);
8228 -- String_Literal case. This needs to be handled specially be-
8229 -- cause no index types are available for string literals. The
8230 -- condition is simply:
8232 -- T_Typ'Length = string-literal-length
8234 if Nkind
(Expr_Actual
) = N_String_Literal
8235 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
8239 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
8241 Make_Integer_Literal
(Loc
,
8243 String_Literal_Length
(Etype
(Expr_Actual
))));
8245 -- General array case. Here we have a usable actual subtype for
8246 -- the expression, and the condition is built from the two types
8249 -- T_Typ'Length /= Exptyp'Length or else
8250 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
8251 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
8254 elsif Is_Constrained
(Exptyp
) then
8256 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
8269 -- At the library level, we need to ensure that the type of
8270 -- the object is elaborated before the check itself is
8271 -- emitted. This is only done if the object is in the
8272 -- current compilation unit, otherwise the type is frozen
8273 -- and elaborated in its unit.
8275 if Is_Itype
(Exptyp
)
8277 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
8279 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
8280 and then In_Open_Scopes
(Scope
(Exptyp
))
8282 Ref_Node
:= Make_Itype_Reference
(Sloc
(Ck_Node
));
8283 Set_Itype
(Ref_Node
, Exptyp
);
8284 Insert_Action
(Ck_Node
, Ref_Node
);
8287 L_Index
:= First_Index
(T_Typ
);
8288 R_Index
:= First_Index
(Exptyp
);
8290 for Indx
in 1 .. Ndims
loop
8291 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
8293 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
8295 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
8296 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
8298 -- Deal with compile time length check. Note that we
8299 -- skip this in the access case, because the access
8300 -- value may be null, so we cannot know statically.
8303 and then Compile_Time_Known_Value
(L_Low
)
8304 and then Compile_Time_Known_Value
(L_High
)
8305 and then Compile_Time_Known_Value
(R_Low
)
8306 and then Compile_Time_Known_Value
(R_High
)
8308 if Expr_Value
(L_High
) >= Expr_Value
(L_Low
) then
8309 L_Length
:= Expr_Value
(L_High
) -
8310 Expr_Value
(L_Low
) + 1;
8312 L_Length
:= UI_From_Int
(0);
8315 if Expr_Value
(R_High
) >= Expr_Value
(R_Low
) then
8316 R_Length
:= Expr_Value
(R_High
) -
8317 Expr_Value
(R_Low
) + 1;
8319 R_Length
:= UI_From_Int
(0);
8322 if L_Length
> R_Length
then
8324 (Compile_Time_Constraint_Error
8325 (Wnode
, "too few elements for}??", T_Typ
));
8327 elsif L_Length
< R_Length
then
8329 (Compile_Time_Constraint_Error
8330 (Wnode
, "too many elements for}??", T_Typ
));
8333 -- The comparison for an individual index subtype
8334 -- is omitted if the corresponding index subtypes
8335 -- statically match, since the result is known to
8336 -- be true. Note that this test is worth while even
8337 -- though we do static evaluation, because non-static
8338 -- subtypes can statically match.
8341 Subtypes_Statically_Match
8342 (Etype
(L_Index
), Etype
(R_Index
))
8345 (Same_Bounds
(L_Low
, R_Low
)
8346 and then Same_Bounds
(L_High
, R_High
))
8349 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
8358 -- Handle cases where we do not get a usable actual subtype that
8359 -- is constrained. This happens for example in the function call
8360 -- and explicit dereference cases. In these cases, we have to get
8361 -- the length or range from the expression itself, making sure we
8362 -- do not evaluate it more than once.
8364 -- Here Ck_Node is the original expression, or more properly the
8365 -- result of applying Duplicate_Expr to the original tree, forcing
8366 -- the result to be a name.
8370 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
8373 -- Build the condition for the explicit dereference case
8375 for Indx
in 1 .. Ndims
loop
8377 (Cond
, Length_N_Cond
(Ck_Node
, T_Typ
, Indx
));
8384 -- Construct the test and insert into the tree
8386 if Present
(Cond
) then
8388 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
8392 (Make_Raise_Constraint_Error
(Loc
,
8394 Reason
=> CE_Length_Check_Failed
));
8398 end Selected_Length_Checks
;
8400 ---------------------------
8401 -- Selected_Range_Checks --
8402 ---------------------------
8404 function Selected_Range_Checks
8406 Target_Typ
: Entity_Id
;
8407 Source_Typ
: Entity_Id
;
8408 Warn_Node
: Node_Id
) return Check_Result
8410 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
8413 Expr_Actual
: Node_Id
;
8415 Cond
: Node_Id
:= Empty
;
8416 Do_Access
: Boolean := False;
8417 Wnode
: Node_Id
:= Warn_Node
;
8418 Ret_Result
: Check_Result
:= (Empty
, Empty
);
8419 Num_Checks
: Integer := 0;
8421 procedure Add_Check
(N
: Node_Id
);
8422 -- Adds the action given to Ret_Result if N is non-Empty
8424 function Discrete_Range_Cond
8426 Typ
: Entity_Id
) return Node_Id
;
8427 -- Returns expression to compute:
8428 -- Low_Bound (Expr) < Typ'First
8430 -- High_Bound (Expr) > Typ'Last
8432 function Discrete_Expr_Cond
8434 Typ
: Entity_Id
) return Node_Id
;
8435 -- Returns expression to compute:
8440 function Get_E_First_Or_Last
8444 Nam
: Name_Id
) return Node_Id
;
8445 -- Returns an attribute reference
8446 -- E'First or E'Last
8447 -- with a source location of Loc.
8449 -- Nam is Name_First or Name_Last, according to which attribute is
8450 -- desired. If Indx is non-zero, it is passed as a literal in the
8451 -- Expressions of the attribute reference (identifying the desired
8452 -- array dimension).
8454 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8455 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8456 -- Returns expression to compute:
8457 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
8459 function Range_E_Cond
8460 (Exptyp
: Entity_Id
;
8464 -- Returns expression to compute:
8465 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
8467 function Range_Equal_E_Cond
8468 (Exptyp
: Entity_Id
;
8470 Indx
: Nat
) return Node_Id
;
8471 -- Returns expression to compute:
8472 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
8474 function Range_N_Cond
8477 Indx
: Nat
) return Node_Id
;
8478 -- Return expression to compute:
8479 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
8485 procedure Add_Check
(N
: Node_Id
) is
8489 -- For now, ignore attempt to place more than 2 checks ???
8491 if Num_Checks
= 2 then
8495 pragma Assert
(Num_Checks
<= 1);
8496 Num_Checks
:= Num_Checks
+ 1;
8497 Ret_Result
(Num_Checks
) := N
;
8501 -------------------------
8502 -- Discrete_Expr_Cond --
8503 -------------------------
8505 function Discrete_Expr_Cond
8507 Typ
: Entity_Id
) return Node_Id
8515 Convert_To
(Base_Type
(Typ
),
8516 Duplicate_Subexpr_No_Checks
(Expr
)),
8518 Convert_To
(Base_Type
(Typ
),
8519 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
))),
8524 Convert_To
(Base_Type
(Typ
),
8525 Duplicate_Subexpr_No_Checks
(Expr
)),
8529 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
))));
8530 end Discrete_Expr_Cond
;
8532 -------------------------
8533 -- Discrete_Range_Cond --
8534 -------------------------
8536 function Discrete_Range_Cond
8538 Typ
: Entity_Id
) return Node_Id
8540 LB
: Node_Id
:= Low_Bound
(Expr
);
8541 HB
: Node_Id
:= High_Bound
(Expr
);
8543 Left_Opnd
: Node_Id
;
8544 Right_Opnd
: Node_Id
;
8547 if Nkind
(LB
) = N_Identifier
8548 and then Ekind
(Entity
(LB
)) = E_Discriminant
8550 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
8557 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
8562 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
)));
8564 if Nkind
(HB
) = N_Identifier
8565 and then Ekind
(Entity
(HB
)) = E_Discriminant
8567 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
8574 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
8579 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
)));
8581 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
8582 end Discrete_Range_Cond
;
8584 -------------------------
8585 -- Get_E_First_Or_Last --
8586 -------------------------
8588 function Get_E_First_Or_Last
8592 Nam
: Name_Id
) return Node_Id
8597 Exprs
:= New_List
(Make_Integer_Literal
(Loc
, UI_From_Int
(Indx
)));
8602 return Make_Attribute_Reference
(Loc
,
8603 Prefix
=> New_Occurrence_Of
(E
, Loc
),
8604 Attribute_Name
=> Nam
,
8605 Expressions
=> Exprs
);
8606 end Get_E_First_Or_Last
;
8612 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8615 Make_Attribute_Reference
(Loc
,
8616 Attribute_Name
=> Name_First
,
8618 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8619 Expressions
=> New_List
(
8620 Make_Integer_Literal
(Loc
, Indx
)));
8627 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8630 Make_Attribute_Reference
(Loc
,
8631 Attribute_Name
=> Name_Last
,
8633 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8634 Expressions
=> New_List
(
8635 Make_Integer_Literal
(Loc
, Indx
)));
8642 function Range_E_Cond
8643 (Exptyp
: Entity_Id
;
8645 Indx
: Nat
) return Node_Id
8653 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
8655 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8660 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
8662 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8665 ------------------------
8666 -- Range_Equal_E_Cond --
8667 ------------------------
8669 function Range_Equal_E_Cond
8670 (Exptyp
: Entity_Id
;
8672 Indx
: Nat
) return Node_Id
8680 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
8682 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8687 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
8689 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8690 end Range_Equal_E_Cond
;
8696 function Range_N_Cond
8699 Indx
: Nat
) return Node_Id
8707 Get_N_First
(Expr
, Indx
),
8709 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8714 Get_N_Last
(Expr
, Indx
),
8716 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8719 -- Start of processing for Selected_Range_Checks
8722 if not Full_Expander_Active
then
8726 if Target_Typ
= Any_Type
8727 or else Target_Typ
= Any_Composite
8728 or else Raises_Constraint_Error
(Ck_Node
)
8737 T_Typ
:= Target_Typ
;
8739 if No
(Source_Typ
) then
8740 S_Typ
:= Etype
(Ck_Node
);
8742 S_Typ
:= Source_Typ
;
8745 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
8749 -- The order of evaluating T_Typ before S_Typ seems to be critical
8750 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
8751 -- in, and since Node can be an N_Range node, it might be invalid.
8752 -- Should there be an assert check somewhere for taking the Etype of
8753 -- an N_Range node ???
8755 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
8756 S_Typ
:= Designated_Type
(S_Typ
);
8757 T_Typ
:= Designated_Type
(T_Typ
);
8760 -- A simple optimization for the null case
8762 if Known_Null
(Ck_Node
) then
8767 -- For an N_Range Node, check for a null range and then if not
8768 -- null generate a range check action.
8770 if Nkind
(Ck_Node
) = N_Range
then
8772 -- There's no point in checking a range against itself
8774 if Ck_Node
= Scalar_Range
(T_Typ
) then
8779 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
8780 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
8781 Known_T_LB
: constant Boolean := Compile_Time_Known_Value
(T_LB
);
8782 Known_T_HB
: constant Boolean := Compile_Time_Known_Value
(T_HB
);
8784 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
8785 HB
: Node_Id
:= High_Bound
(Ck_Node
);
8789 Null_Range
: Boolean;
8790 Out_Of_Range_L
: Boolean;
8791 Out_Of_Range_H
: Boolean;
8794 -- Compute what is known at compile time
8796 if Known_T_LB
and Known_T_HB
then
8797 if Compile_Time_Known_Value
(LB
) then
8800 -- There's no point in checking that a bound is within its
8801 -- own range so pretend that it is known in this case. First
8802 -- deal with low bound.
8804 elsif Ekind
(Etype
(LB
)) = E_Signed_Integer_Subtype
8805 and then Scalar_Range
(Etype
(LB
)) = Scalar_Range
(T_Typ
)
8814 -- Likewise for the high bound
8816 if Compile_Time_Known_Value
(HB
) then
8819 elsif Ekind
(Etype
(HB
)) = E_Signed_Integer_Subtype
8820 and then Scalar_Range
(Etype
(HB
)) = Scalar_Range
(T_Typ
)
8830 -- Check for case where everything is static and we can do the
8831 -- check at compile time. This is skipped if we have an access
8832 -- type, since the access value may be null.
8834 -- ??? This code can be improved since you only need to know that
8835 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
8836 -- compile time to emit pertinent messages.
8838 if Known_T_LB
and Known_T_HB
and Known_LB
and Known_HB
8841 -- Floating-point case
8843 if Is_Floating_Point_Type
(S_Typ
) then
8844 Null_Range
:= Expr_Value_R
(HB
) < Expr_Value_R
(LB
);
8846 (Expr_Value_R
(LB
) < Expr_Value_R
(T_LB
))
8848 (Expr_Value_R
(LB
) > Expr_Value_R
(T_HB
));
8851 (Expr_Value_R
(HB
) > Expr_Value_R
(T_HB
))
8853 (Expr_Value_R
(HB
) < Expr_Value_R
(T_LB
));
8855 -- Fixed or discrete type case
8858 Null_Range
:= Expr_Value
(HB
) < Expr_Value
(LB
);
8860 (Expr_Value
(LB
) < Expr_Value
(T_LB
))
8862 (Expr_Value
(LB
) > Expr_Value
(T_HB
));
8865 (Expr_Value
(HB
) > Expr_Value
(T_HB
))
8867 (Expr_Value
(HB
) < Expr_Value
(T_LB
));
8870 if not Null_Range
then
8871 if Out_Of_Range_L
then
8872 if No
(Warn_Node
) then
8874 (Compile_Time_Constraint_Error
8875 (Low_Bound
(Ck_Node
),
8876 "static value out of range of}??", T_Typ
));
8880 (Compile_Time_Constraint_Error
8882 "static range out of bounds of}??", T_Typ
));
8886 if Out_Of_Range_H
then
8887 if No
(Warn_Node
) then
8889 (Compile_Time_Constraint_Error
8890 (High_Bound
(Ck_Node
),
8891 "static value out of range of}??", T_Typ
));
8895 (Compile_Time_Constraint_Error
8897 "static range out of bounds of}??", T_Typ
));
8904 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
8905 HB
: Node_Id
:= High_Bound
(Ck_Node
);
8908 -- If either bound is a discriminant and we are within the
8909 -- record declaration, it is a use of the discriminant in a
8910 -- constraint of a component, and nothing can be checked
8911 -- here. The check will be emitted within the init proc.
8912 -- Before then, the discriminal has no real meaning.
8913 -- Similarly, if the entity is a discriminal, there is no
8914 -- check to perform yet.
8916 -- The same holds within a discriminated synchronized type,
8917 -- where the discriminant may constrain a component or an
8920 if Nkind
(LB
) = N_Identifier
8921 and then Denotes_Discriminant
(LB
, True)
8923 if Current_Scope
= Scope
(Entity
(LB
))
8924 or else Is_Concurrent_Type
(Current_Scope
)
8925 or else Ekind
(Entity
(LB
)) /= E_Discriminant
8930 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
8934 if Nkind
(HB
) = N_Identifier
8935 and then Denotes_Discriminant
(HB
, True)
8937 if Current_Scope
= Scope
(Entity
(HB
))
8938 or else Is_Concurrent_Type
(Current_Scope
)
8939 or else Ekind
(Entity
(HB
)) /= E_Discriminant
8944 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
8948 Cond
:= Discrete_Range_Cond
(Ck_Node
, T_Typ
);
8949 Set_Paren_Count
(Cond
, 1);
8955 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(HB
),
8956 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(LB
)),
8957 Right_Opnd
=> Cond
);
8962 elsif Is_Scalar_Type
(S_Typ
) then
8964 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
8965 -- except the above simply sets a flag in the node and lets
8966 -- gigi generate the check base on the Etype of the expression.
8967 -- Sometimes, however we want to do a dynamic check against an
8968 -- arbitrary target type, so we do that here.
8970 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
8971 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
8973 -- For literals, we can tell if the constraint error will be
8974 -- raised at compile time, so we never need a dynamic check, but
8975 -- if the exception will be raised, then post the usual warning,
8976 -- and replace the literal with a raise constraint error
8977 -- expression. As usual, skip this for access types
8979 elsif Compile_Time_Known_Value
(Ck_Node
)
8980 and then not Do_Access
8983 LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
8984 UB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
8986 Out_Of_Range
: Boolean;
8987 Static_Bounds
: constant Boolean :=
8988 Compile_Time_Known_Value
(LB
)
8989 and Compile_Time_Known_Value
(UB
);
8992 -- Following range tests should use Sem_Eval routine ???
8994 if Static_Bounds
then
8995 if Is_Floating_Point_Type
(S_Typ
) then
8997 (Expr_Value_R
(Ck_Node
) < Expr_Value_R
(LB
))
8999 (Expr_Value_R
(Ck_Node
) > Expr_Value_R
(UB
));
9001 -- Fixed or discrete type
9005 Expr_Value
(Ck_Node
) < Expr_Value
(LB
)
9007 Expr_Value
(Ck_Node
) > Expr_Value
(UB
);
9010 -- Bounds of the type are static and the literal is out of
9011 -- range so output a warning message.
9013 if Out_Of_Range
then
9014 if No
(Warn_Node
) then
9016 (Compile_Time_Constraint_Error
9018 "static value out of range of}??", T_Typ
));
9022 (Compile_Time_Constraint_Error
9024 "static value out of range of}??", T_Typ
));
9029 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9033 -- Here for the case of a non-static expression, we need a runtime
9034 -- check unless the source type range is guaranteed to be in the
9035 -- range of the target type.
9038 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
9039 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9044 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
9045 if Is_Constrained
(T_Typ
) then
9047 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
9048 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
9050 if Is_Access_Type
(Exptyp
) then
9051 Exptyp
:= Designated_Type
(Exptyp
);
9054 -- String_Literal case. This needs to be handled specially be-
9055 -- cause no index types are available for string literals. The
9056 -- condition is simply:
9058 -- T_Typ'Length = string-literal-length
9060 if Nkind
(Expr_Actual
) = N_String_Literal
then
9063 -- General array case. Here we have a usable actual subtype for
9064 -- the expression, and the condition is built from the two types
9066 -- T_Typ'First < Exptyp'First or else
9067 -- T_Typ'Last > Exptyp'Last or else
9068 -- T_Typ'First(1) < Exptyp'First(1) or else
9069 -- T_Typ'Last(1) > Exptyp'Last(1) or else
9072 elsif Is_Constrained
(Exptyp
) then
9074 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9080 L_Index
:= First_Index
(T_Typ
);
9081 R_Index
:= First_Index
(Exptyp
);
9083 for Indx
in 1 .. Ndims
loop
9084 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
9086 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
9088 -- Deal with compile time length check. Note that we
9089 -- skip this in the access case, because the access
9090 -- value may be null, so we cannot know statically.
9093 Subtypes_Statically_Match
9094 (Etype
(L_Index
), Etype
(R_Index
))
9096 -- If the target type is constrained then we
9097 -- have to check for exact equality of bounds
9098 -- (required for qualified expressions).
9100 if Is_Constrained
(T_Typ
) then
9103 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
9106 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
9116 -- Handle cases where we do not get a usable actual subtype that
9117 -- is constrained. This happens for example in the function call
9118 -- and explicit dereference cases. In these cases, we have to get
9119 -- the length or range from the expression itself, making sure we
9120 -- do not evaluate it more than once.
9122 -- Here Ck_Node is the original expression, or more properly the
9123 -- result of applying Duplicate_Expr to the original tree,
9124 -- forcing the result to be a name.
9128 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9131 -- Build the condition for the explicit dereference case
9133 for Indx
in 1 .. Ndims
loop
9135 (Cond
, Range_N_Cond
(Ck_Node
, T_Typ
, Indx
));
9141 -- For a conversion to an unconstrained array type, generate an
9142 -- Action to check that the bounds of the source value are within
9143 -- the constraints imposed by the target type (RM 4.6(38)). No
9144 -- check is needed for a conversion to an access to unconstrained
9145 -- array type, as 4.6(24.15/2) requires the designated subtypes
9146 -- of the two access types to statically match.
9148 if Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
9149 and then not Do_Access
9152 Opnd_Index
: Node_Id
;
9153 Targ_Index
: Node_Id
;
9154 Opnd_Range
: Node_Id
;
9157 Opnd_Index
:= First_Index
(Get_Actual_Subtype
(Ck_Node
));
9158 Targ_Index
:= First_Index
(T_Typ
);
9159 while Present
(Opnd_Index
) loop
9161 -- If the index is a range, use its bounds. If it is an
9162 -- entity (as will be the case if it is a named subtype
9163 -- or an itype created for a slice) retrieve its range.
9165 if Is_Entity_Name
(Opnd_Index
)
9166 and then Is_Type
(Entity
(Opnd_Index
))
9168 Opnd_Range
:= Scalar_Range
(Entity
(Opnd_Index
));
9170 Opnd_Range
:= Opnd_Index
;
9173 if Nkind
(Opnd_Range
) = N_Range
then
9175 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9176 Assume_Valid
=> True)
9179 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9180 Assume_Valid
=> True)
9184 -- If null range, no check needed
9187 Compile_Time_Known_Value
(High_Bound
(Opnd_Range
))
9189 Compile_Time_Known_Value
(Low_Bound
(Opnd_Range
))
9191 Expr_Value
(High_Bound
(Opnd_Range
)) <
9192 Expr_Value
(Low_Bound
(Opnd_Range
))
9196 elsif Is_Out_Of_Range
9197 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9198 Assume_Valid
=> True)
9201 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9202 Assume_Valid
=> True)
9205 (Compile_Time_Constraint_Error
9206 (Wnode
, "value out of range of}??", T_Typ
));
9212 (Opnd_Range
, Etype
(Targ_Index
)));
9216 Next_Index
(Opnd_Index
);
9217 Next_Index
(Targ_Index
);
9224 -- Construct the test and insert into the tree
9226 if Present
(Cond
) then
9228 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
9232 (Make_Raise_Constraint_Error
(Loc
,
9234 Reason
=> CE_Range_Check_Failed
));
9238 end Selected_Range_Checks
;
9240 -------------------------------
9241 -- Storage_Checks_Suppressed --
9242 -------------------------------
9244 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9246 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9247 return Is_Check_Suppressed
(E
, Storage_Check
);
9249 return Scope_Suppress
.Suppress
(Storage_Check
);
9251 end Storage_Checks_Suppressed
;
9253 ---------------------------
9254 -- Tag_Checks_Suppressed --
9255 ---------------------------
9257 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9260 and then Checks_May_Be_Suppressed
(E
)
9262 return Is_Check_Suppressed
(E
, Tag_Check
);
9265 return Scope_Suppress
.Suppress
(Tag_Check
);
9266 end Tag_Checks_Suppressed
;
9268 --------------------------
9269 -- Validity_Check_Range --
9270 --------------------------
9272 procedure Validity_Check_Range
(N
: Node_Id
) is
9274 if Validity_Checks_On
and Validity_Check_Operands
then
9275 if Nkind
(N
) = N_Range
then
9276 Ensure_Valid
(Low_Bound
(N
));
9277 Ensure_Valid
(High_Bound
(N
));
9280 end Validity_Check_Range
;
9282 --------------------------------
9283 -- Validity_Checks_Suppressed --
9284 --------------------------------
9286 function Validity_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9288 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9289 return Is_Check_Suppressed
(E
, Validity_Check
);
9291 return Scope_Suppress
.Suppress
(Validity_Check
);
9293 end Validity_Checks_Suppressed
;