1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 Set_Do_Overflow_Check
(N
, True);
391 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
392 end Activate_Overflow_Check
;
394 --------------------------
395 -- Activate_Range_Check --
396 --------------------------
398 procedure Activate_Range_Check
(N
: Node_Id
) is
400 Set_Do_Range_Check
(N
, True);
401 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
402 end Activate_Range_Check
;
404 ---------------------------------
405 -- Alignment_Checks_Suppressed --
406 ---------------------------------
408 function Alignment_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
410 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
411 return Is_Check_Suppressed
(E
, Alignment_Check
);
413 return Scope_Suppress
.Suppress
(Alignment_Check
);
415 end Alignment_Checks_Suppressed
;
417 -------------------------
418 -- Append_Range_Checks --
419 -------------------------
421 procedure Append_Range_Checks
422 (Checks
: Check_Result
;
424 Suppress_Typ
: Entity_Id
;
425 Static_Sloc
: Source_Ptr
;
428 Internal_Flag_Node
: constant Node_Id
:= Flag_Node
;
429 Internal_Static_Sloc
: constant Source_Ptr
:= Static_Sloc
;
431 Checks_On
: constant Boolean :=
432 (not Index_Checks_Suppressed
(Suppress_Typ
))
433 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
436 -- For now we just return if Checks_On is false, however this should
437 -- be enhanced to check for an always True value in the condition
438 -- and to generate a compilation warning???
440 if not Checks_On
then
445 exit when No
(Checks
(J
));
447 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
448 and then Present
(Condition
(Checks
(J
)))
450 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
451 Append_To
(Stmts
, Checks
(J
));
452 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
458 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
459 Reason
=> CE_Range_Check_Failed
));
462 end Append_Range_Checks
;
464 ------------------------
465 -- Apply_Access_Check --
466 ------------------------
468 procedure Apply_Access_Check
(N
: Node_Id
) is
469 P
: constant Node_Id
:= Prefix
(N
);
472 -- We do not need checks if we are not generating code (i.e. the
473 -- expander is not active). This is not just an optimization, there
474 -- are cases (e.g. with pragma Debug) where generating the checks
475 -- can cause real trouble).
477 if not Full_Expander_Active
then
481 -- No check if short circuiting makes check unnecessary
483 if not Check_Needed
(P
, Access_Check
) then
487 -- No check if accessing the Offset_To_Top component of a dispatch
488 -- table. They are safe by construction.
490 if Tagged_Type_Expansion
491 and then Present
(Etype
(P
))
492 and then RTU_Loaded
(Ada_Tags
)
493 and then RTE_Available
(RE_Offset_To_Top_Ptr
)
494 and then Etype
(P
) = RTE
(RE_Offset_To_Top_Ptr
)
499 -- Otherwise go ahead and install the check
501 Install_Null_Excluding_Check
(P
);
502 end Apply_Access_Check
;
504 -------------------------------
505 -- Apply_Accessibility_Check --
506 -------------------------------
508 procedure Apply_Accessibility_Check
511 Insert_Node
: Node_Id
)
513 Loc
: constant Source_Ptr
:= Sloc
(N
);
514 Param_Ent
: Entity_Id
:= Param_Entity
(N
);
515 Param_Level
: Node_Id
;
516 Type_Level
: Node_Id
;
519 if Ada_Version
>= Ada_2012
520 and then not Present
(Param_Ent
)
521 and then Is_Entity_Name
(N
)
522 and then Ekind_In
(Entity
(N
), E_Constant
, E_Variable
)
523 and then Present
(Effective_Extra_Accessibility
(Entity
(N
)))
525 Param_Ent
:= Entity
(N
);
526 while Present
(Renamed_Object
(Param_Ent
)) loop
528 -- Renamed_Object must return an Entity_Name here
529 -- because of preceding "Present (E_E_A (...))" test.
531 Param_Ent
:= Entity
(Renamed_Object
(Param_Ent
));
535 if Inside_A_Generic
then
538 -- Only apply the run-time check if the access parameter has an
539 -- associated extra access level parameter and when the level of the
540 -- type is less deep than the level of the access parameter, and
541 -- accessibility checks are not suppressed.
543 elsif Present
(Param_Ent
)
544 and then Present
(Extra_Accessibility
(Param_Ent
))
545 and then UI_Gt
(Object_Access_Level
(N
),
546 Deepest_Type_Access_Level
(Typ
))
547 and then not Accessibility_Checks_Suppressed
(Param_Ent
)
548 and then not Accessibility_Checks_Suppressed
(Typ
)
551 New_Occurrence_Of
(Extra_Accessibility
(Param_Ent
), Loc
);
554 Make_Integer_Literal
(Loc
, Deepest_Type_Access_Level
(Typ
));
556 -- Raise Program_Error if the accessibility level of the access
557 -- parameter is deeper than the level of the target access type.
559 Insert_Action
(Insert_Node
,
560 Make_Raise_Program_Error
(Loc
,
563 Left_Opnd
=> Param_Level
,
564 Right_Opnd
=> Type_Level
),
565 Reason
=> PE_Accessibility_Check_Failed
));
567 Analyze_And_Resolve
(N
);
569 end Apply_Accessibility_Check
;
571 --------------------------------
572 -- Apply_Address_Clause_Check --
573 --------------------------------
575 procedure Apply_Address_Clause_Check
(E
: Entity_Id
; N
: Node_Id
) is
576 AC
: constant Node_Id
:= Address_Clause
(E
);
577 Loc
: constant Source_Ptr
:= Sloc
(AC
);
578 Typ
: constant Entity_Id
:= Etype
(E
);
579 Aexp
: constant Node_Id
:= Expression
(AC
);
582 -- Address expression (not necessarily the same as Aexp, for example
583 -- when Aexp is a reference to a constant, in which case Expr gets
584 -- reset to reference the value expression of the constant.
586 procedure Compile_Time_Bad_Alignment
;
587 -- Post error warnings when alignment is known to be incompatible. Note
588 -- that we do not go as far as inserting a raise of Program_Error since
589 -- this is an erroneous case, and it may happen that we are lucky and an
590 -- underaligned address turns out to be OK after all.
592 --------------------------------
593 -- Compile_Time_Bad_Alignment --
594 --------------------------------
596 procedure Compile_Time_Bad_Alignment
is
598 if Address_Clause_Overlay_Warnings
then
600 ("?specified address for& may be inconsistent with alignment ",
603 ("\?program execution may be erroneous (RM 13.3(27))",
605 Set_Address_Warning_Posted
(AC
);
607 end Compile_Time_Bad_Alignment
;
609 -- Start of processing for Apply_Address_Clause_Check
612 -- See if alignment check needed. Note that we never need a check if the
613 -- maximum alignment is one, since the check will always succeed.
615 -- Note: we do not check for checks suppressed here, since that check
616 -- was done in Sem_Ch13 when the address clause was processed. We are
617 -- only called if checks were not suppressed. The reason for this is
618 -- that we have to delay the call to Apply_Alignment_Check till freeze
619 -- time (so that all types etc are elaborated), but we have to check
620 -- the status of check suppressing at the point of the address clause.
623 or else not Check_Address_Alignment
(AC
)
624 or else Maximum_Alignment
= 1
629 -- Obtain expression from address clause
631 Expr
:= Expression
(AC
);
633 -- The following loop digs for the real expression to use in the check
636 -- For constant, get constant expression
638 if Is_Entity_Name
(Expr
)
639 and then Ekind
(Entity
(Expr
)) = E_Constant
641 Expr
:= Constant_Value
(Entity
(Expr
));
643 -- For unchecked conversion, get result to convert
645 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
646 Expr
:= Expression
(Expr
);
648 -- For (common case) of To_Address call, get argument
650 elsif Nkind
(Expr
) = N_Function_Call
651 and then Is_Entity_Name
(Name
(Expr
))
652 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
654 Expr
:= First
(Parameter_Associations
(Expr
));
656 if Nkind
(Expr
) = N_Parameter_Association
then
657 Expr
:= Explicit_Actual_Parameter
(Expr
);
660 -- We finally have the real expression
667 -- See if we know that Expr has a bad alignment at compile time
669 if Compile_Time_Known_Value
(Expr
)
670 and then (Known_Alignment
(E
) or else Known_Alignment
(Typ
))
673 AL
: Uint
:= Alignment
(Typ
);
676 -- The object alignment might be more restrictive than the
679 if Known_Alignment
(E
) then
683 if Expr_Value
(Expr
) mod AL
/= 0 then
684 Compile_Time_Bad_Alignment
;
690 -- If the expression has the form X'Address, then we can find out if
691 -- the object X has an alignment that is compatible with the object E.
692 -- If it hasn't or we don't know, we defer issuing the warning until
693 -- the end of the compilation to take into account back end annotations.
695 elsif Nkind
(Expr
) = N_Attribute_Reference
696 and then Attribute_Name
(Expr
) = Name_Address
697 and then Has_Compatible_Alignment
(E
, Prefix
(Expr
)) = Known_Compatible
702 -- Here we do not know if the value is acceptable. Strictly we don't
703 -- have to do anything, since if the alignment is bad, we have an
704 -- erroneous program. However we are allowed to check for erroneous
705 -- conditions and we decide to do this by default if the check is not
708 -- However, don't do the check if elaboration code is unwanted
710 if Restriction_Active
(No_Elaboration_Code
) then
713 -- Generate a check to raise PE if alignment may be inappropriate
716 -- If the original expression is a non-static constant, use the
717 -- name of the constant itself rather than duplicating its
718 -- defining expression, which was extracted above.
720 -- Note: Expr is empty if the address-clause is applied to in-mode
721 -- actuals (allowed by 13.1(22)).
723 if not Present
(Expr
)
725 (Is_Entity_Name
(Expression
(AC
))
726 and then Ekind
(Entity
(Expression
(AC
))) = E_Constant
727 and then Nkind
(Parent
(Entity
(Expression
(AC
))))
728 = N_Object_Declaration
)
730 Expr
:= New_Copy_Tree
(Expression
(AC
));
732 Remove_Side_Effects
(Expr
);
735 Insert_After_And_Analyze
(N
,
736 Make_Raise_Program_Error
(Loc
,
743 (RTE
(RE_Integer_Address
), Expr
),
745 Make_Attribute_Reference
(Loc
,
746 Prefix
=> New_Occurrence_Of
(E
, Loc
),
747 Attribute_Name
=> Name_Alignment
)),
748 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
749 Reason
=> PE_Misaligned_Address_Value
),
750 Suppress
=> All_Checks
);
755 -- If we have some missing run time component in configurable run time
756 -- mode then just skip the check (it is not required in any case).
758 when RE_Not_Available
=>
760 end Apply_Address_Clause_Check
;
762 -------------------------------------
763 -- Apply_Arithmetic_Overflow_Check --
764 -------------------------------------
766 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
768 -- Use old routine in almost all cases (the only case we are treating
769 -- specially is the case of a signed integer arithmetic op with the
770 -- overflow checking mode set to MINIMIZED or ELIMINATED).
772 if Overflow_Check_Mode
= Strict
773 or else not Is_Signed_Integer_Arithmetic_Op
(N
)
775 Apply_Arithmetic_Overflow_Strict
(N
);
777 -- Otherwise use the new routine for the case of a signed integer
778 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
779 -- mode is MINIMIZED or ELIMINATED.
782 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
784 end Apply_Arithmetic_Overflow_Check
;
786 --------------------------------------
787 -- Apply_Arithmetic_Overflow_Strict --
788 --------------------------------------
790 -- This routine is called only if the type is an integer type, and a
791 -- software arithmetic overflow check may be needed for op (add, subtract,
792 -- or multiply). This check is performed only if Software_Overflow_Checking
793 -- is enabled and Do_Overflow_Check is set. In this case we expand the
794 -- operation into a more complex sequence of tests that ensures that
795 -- overflow is properly caught.
797 -- This is used in CHECKED modes. It is identical to the code for this
798 -- cases before the big overflow earthquake, thus ensuring that in this
799 -- modes we have compatible behavior (and reliability) to what was there
800 -- before. It is also called for types other than signed integers, and if
801 -- the Do_Overflow_Check flag is off.
803 -- Note: we also call this routine if we decide in the MINIMIZED case
804 -- to give up and just generate an overflow check without any fuss.
806 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
) is
807 Loc
: constant Source_Ptr
:= Sloc
(N
);
808 Typ
: constant Entity_Id
:= Etype
(N
);
809 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
812 -- Nothing to do if Do_Overflow_Check not set or overflow checks
815 if not Do_Overflow_Check
(N
) then
819 -- An interesting special case. If the arithmetic operation appears as
820 -- the operand of a type conversion:
824 -- and all the following conditions apply:
826 -- arithmetic operation is for a signed integer type
827 -- target type type1 is a static integer subtype
828 -- range of x and y are both included in the range of type1
829 -- range of x op y is included in the range of type1
830 -- size of type1 is at least twice the result size of op
832 -- then we don't do an overflow check in any case, instead we transform
833 -- the operation so that we end up with:
835 -- type1 (type1 (x) op type1 (y))
837 -- This avoids intermediate overflow before the conversion. It is
838 -- explicitly permitted by RM 3.5.4(24):
840 -- For the execution of a predefined operation of a signed integer
841 -- type, the implementation need not raise Constraint_Error if the
842 -- result is outside the base range of the type, so long as the
843 -- correct result is produced.
845 -- It's hard to imagine that any programmer counts on the exception
846 -- being raised in this case, and in any case it's wrong coding to
847 -- have this expectation, given the RM permission. Furthermore, other
848 -- Ada compilers do allow such out of range results.
850 -- Note that we do this transformation even if overflow checking is
851 -- off, since this is precisely about giving the "right" result and
852 -- avoiding the need for an overflow check.
854 -- Note: this circuit is partially redundant with respect to the similar
855 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
856 -- with cases that do not come through here. We still need the following
857 -- processing even with the Exp_Ch4 code in place, since we want to be
858 -- sure not to generate the arithmetic overflow check in these cases
859 -- (Exp_Ch4 would have a hard time removing them once generated).
861 if Is_Signed_Integer_Type
(Typ
)
862 and then Nkind
(Parent
(N
)) = N_Type_Conversion
864 Conversion_Optimization
: declare
865 Target_Type
: constant Entity_Id
:=
866 Base_Type
(Entity
(Subtype_Mark
(Parent
(N
))));
880 if Is_Integer_Type
(Target_Type
)
881 and then RM_Size
(Root_Type
(Target_Type
)) >= 2 * RM_Size
(Rtyp
)
883 Tlo
:= Expr_Value
(Type_Low_Bound
(Target_Type
));
884 Thi
:= Expr_Value
(Type_High_Bound
(Target_Type
));
887 (Left_Opnd
(N
), LOK
, Llo
, Lhi
, Assume_Valid
=> True);
889 (Right_Opnd
(N
), ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
892 and then Tlo
<= Llo
and then Lhi
<= Thi
893 and then Tlo
<= Rlo
and then Rhi
<= Thi
895 Determine_Range
(N
, VOK
, Vlo
, Vhi
, Assume_Valid
=> True);
897 if VOK
and then Tlo
<= Vlo
and then Vhi
<= Thi
then
898 Rewrite
(Left_Opnd
(N
),
899 Make_Type_Conversion
(Loc
,
900 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
901 Expression
=> Relocate_Node
(Left_Opnd
(N
))));
903 Rewrite
(Right_Opnd
(N
),
904 Make_Type_Conversion
(Loc
,
905 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
906 Expression
=> Relocate_Node
(Right_Opnd
(N
))));
908 -- Rewrite the conversion operand so that the original
909 -- node is retained, in order to avoid the warning for
910 -- redundant conversions in Resolve_Type_Conversion.
912 Rewrite
(N
, Relocate_Node
(N
));
914 Set_Etype
(N
, Target_Type
);
916 Analyze_And_Resolve
(Left_Opnd
(N
), Target_Type
);
917 Analyze_And_Resolve
(Right_Opnd
(N
), Target_Type
);
919 -- Given that the target type is twice the size of the
920 -- source type, overflow is now impossible, so we can
921 -- safely kill the overflow check and return.
923 Set_Do_Overflow_Check
(N
, False);
928 end Conversion_Optimization
;
931 -- Now see if an overflow check is required
934 Siz
: constant Int
:= UI_To_Int
(Esize
(Rtyp
));
935 Dsiz
: constant Int
:= Siz
* 2;
942 -- Skip check if back end does overflow checks, or the overflow flag
943 -- is not set anyway, or we are not doing code expansion, or the
944 -- parent node is a type conversion whose operand is an arithmetic
945 -- operation on signed integers on which the expander can promote
946 -- later the operands to type Integer (see Expand_N_Type_Conversion).
948 -- Special case CLI target, where arithmetic overflow checks can be
949 -- performed for integer and long_integer
951 if Backend_Overflow_Checks_On_Target
952 or else not Do_Overflow_Check
(N
)
953 or else not Full_Expander_Active
954 or else (Present
(Parent
(N
))
955 and then Nkind
(Parent
(N
)) = N_Type_Conversion
956 and then Integer_Promotion_Possible
(Parent
(N
)))
958 (VM_Target
= CLI_Target
and then Siz
>= Standard_Integer_Size
)
963 -- Otherwise, generate the full general code for front end overflow
964 -- detection, which works by doing arithmetic in a larger type:
970 -- Typ (Checktyp (x) op Checktyp (y));
972 -- where Typ is the type of the original expression, and Checktyp is
973 -- an integer type of sufficient length to hold the largest possible
976 -- If the size of check type exceeds the size of Long_Long_Integer,
977 -- we use a different approach, expanding to:
979 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
981 -- where xxx is Add, Multiply or Subtract as appropriate
983 -- Find check type if one exists
985 if Dsiz
<= Standard_Integer_Size
then
986 Ctyp
:= Standard_Integer
;
988 elsif Dsiz
<= Standard_Long_Long_Integer_Size
then
989 Ctyp
:= Standard_Long_Long_Integer
;
991 -- No check type exists, use runtime call
994 if Nkind
(N
) = N_Op_Add
then
995 Cent
:= RE_Add_With_Ovflo_Check
;
997 elsif Nkind
(N
) = N_Op_Multiply
then
998 Cent
:= RE_Multiply_With_Ovflo_Check
;
1001 pragma Assert
(Nkind
(N
) = N_Op_Subtract
);
1002 Cent
:= RE_Subtract_With_Ovflo_Check
;
1007 Make_Function_Call
(Loc
,
1008 Name
=> New_Reference_To
(RTE
(Cent
), Loc
),
1009 Parameter_Associations
=> New_List
(
1010 OK_Convert_To
(RTE
(RE_Integer_64
), Left_Opnd
(N
)),
1011 OK_Convert_To
(RTE
(RE_Integer_64
), Right_Opnd
(N
))))));
1013 Analyze_And_Resolve
(N
, Typ
);
1017 -- If we fall through, we have the case where we do the arithmetic
1018 -- in the next higher type and get the check by conversion. In these
1019 -- cases Ctyp is set to the type to be used as the check type.
1021 Opnod
:= Relocate_Node
(N
);
1023 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
1026 Set_Etype
(Opnd
, Ctyp
);
1027 Set_Analyzed
(Opnd
, True);
1028 Set_Left_Opnd
(Opnod
, Opnd
);
1030 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
1033 Set_Etype
(Opnd
, Ctyp
);
1034 Set_Analyzed
(Opnd
, True);
1035 Set_Right_Opnd
(Opnod
, Opnd
);
1037 -- The type of the operation changes to the base type of the check
1038 -- type, and we reset the overflow check indication, since clearly no
1039 -- overflow is possible now that we are using a double length type.
1040 -- We also set the Analyzed flag to avoid a recursive attempt to
1043 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
1044 Set_Do_Overflow_Check
(Opnod
, False);
1045 Set_Analyzed
(Opnod
, True);
1047 -- Now build the outer conversion
1049 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
1051 Set_Etype
(Opnd
, Typ
);
1053 -- In the discrete type case, we directly generate the range check
1054 -- for the outer operand. This range check will implement the
1055 -- required overflow check.
1057 if Is_Discrete_Type
(Typ
) then
1059 Generate_Range_Check
1060 (Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
1062 -- For other types, we enable overflow checking on the conversion,
1063 -- after setting the node as analyzed to prevent recursive attempts
1064 -- to expand the conversion node.
1067 Set_Analyzed
(Opnd
, True);
1068 Enable_Overflow_Check
(Opnd
);
1073 when RE_Not_Available
=>
1076 end Apply_Arithmetic_Overflow_Strict
;
1078 ----------------------------------------------------
1079 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1080 ----------------------------------------------------
1082 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
) is
1083 pragma Assert
(Is_Signed_Integer_Arithmetic_Op
(Op
));
1085 Loc
: constant Source_Ptr
:= Sloc
(Op
);
1086 P
: constant Node_Id
:= Parent
(Op
);
1088 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
1089 -- Operands and results are of this type when we convert
1091 Result_Type
: constant Entity_Id
:= Etype
(Op
);
1092 -- Original result type
1094 Check_Mode
: constant Overflow_Check_Type
:= Overflow_Check_Mode
;
1095 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
1098 -- Ranges of values for result
1101 -- Nothing to do if our parent is one of the following:
1103 -- Another signed integer arithmetic op
1104 -- A membership operation
1105 -- A comparison operation
1107 -- In all these cases, we will process at the higher level (and then
1108 -- this node will be processed during the downwards recursion that
1109 -- is part of the processing in Minimize_Eliminate_Overflows).
1111 if Is_Signed_Integer_Arithmetic_Op
(P
)
1112 or else Nkind
(P
) in N_Membership_Test
1113 or else Nkind
(P
) in N_Op_Compare
1115 -- This is also true for an alternative in a case expression
1117 or else Nkind
(P
) = N_Case_Expression_Alternative
1119 -- This is also true for a range operand in a membership test
1121 or else (Nkind
(P
) = N_Range
1122 and then Nkind
(Parent
(P
)) in N_Membership_Test
)
1127 -- Otherwise, we have a top level arithmetic operation node, and this
1128 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1129 -- modes. This is the case where we tell the machinery not to move into
1130 -- Bignum mode at this top level (of course the top level operation
1131 -- will still be in Bignum mode if either of its operands are of type
1134 Minimize_Eliminate_Overflows
(Op
, Lo
, Hi
, Top_Level
=> True);
1136 -- That call may but does not necessarily change the result type of Op.
1137 -- It is the job of this routine to undo such changes, so that at the
1138 -- top level, we have the proper type. This "undoing" is a point at
1139 -- which a final overflow check may be applied.
1141 -- If the result type was not fiddled we are all set. We go to base
1142 -- types here because things may have been rewritten to generate the
1143 -- base type of the operand types.
1145 if Base_Type
(Etype
(Op
)) = Base_Type
(Result_Type
) then
1150 elsif Is_RTE
(Etype
(Op
), RE_Bignum
) then
1152 -- We need a sequence that looks like:
1154 -- Rnn : Result_Type;
1157 -- M : Mark_Id := SS_Mark;
1159 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1163 -- This block is inserted (using Insert_Actions), and then the node
1164 -- is replaced with a reference to Rnn.
1166 -- A special case arises if our parent is a conversion node. In this
1167 -- case no point in generating a conversion to Result_Type, we will
1168 -- let the parent handle this. Note that this special case is not
1169 -- just about optimization. Consider
1173 -- X := Long_Long_Integer'Base (A * (B ** C));
1175 -- Now the product may fit in Long_Long_Integer but not in Integer.
1176 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1177 -- overflow exception for this intermediate value.
1180 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
1181 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R', Op
);
1187 RHS
:= Convert_From_Bignum
(Op
);
1189 if Nkind
(P
) /= N_Type_Conversion
then
1190 Convert_To_And_Rewrite
(Result_Type
, RHS
);
1191 Rtype
:= Result_Type
;
1193 -- Interesting question, do we need a check on that conversion
1194 -- operation. Answer, not if we know the result is in range.
1195 -- At the moment we are not taking advantage of this. To be
1196 -- looked at later ???
1203 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
1204 Make_Assignment_Statement
(Loc
,
1205 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
1206 Expression
=> RHS
));
1208 Insert_Actions
(Op
, New_List
(
1209 Make_Object_Declaration
(Loc
,
1210 Defining_Identifier
=> Rnn
,
1211 Object_Definition
=> New_Occurrence_Of
(Rtype
, Loc
)),
1214 Rewrite
(Op
, New_Occurrence_Of
(Rnn
, Loc
));
1215 Analyze_And_Resolve
(Op
);
1218 -- Here we know the result is Long_Long_Integer'Base, of that it has
1219 -- been rewritten because the parent operation is a conversion. See
1220 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1224 (Etype
(Op
) = LLIB
or else Nkind
(Parent
(Op
)) = N_Type_Conversion
);
1226 -- All we need to do here is to convert the result to the proper
1227 -- result type. As explained above for the Bignum case, we can
1228 -- omit this if our parent is a type conversion.
1230 if Nkind
(P
) /= N_Type_Conversion
then
1231 Convert_To_And_Rewrite
(Result_Type
, Op
);
1234 Analyze_And_Resolve
(Op
);
1236 end Apply_Arithmetic_Overflow_Minimized_Eliminated
;
1238 ----------------------------
1239 -- Apply_Constraint_Check --
1240 ----------------------------
1242 procedure Apply_Constraint_Check
1245 No_Sliding
: Boolean := False)
1247 Desig_Typ
: Entity_Id
;
1250 -- No checks inside a generic (check the instantiations)
1252 if Inside_A_Generic
then
1256 -- Apply required constraint checks
1258 if Is_Scalar_Type
(Typ
) then
1259 Apply_Scalar_Range_Check
(N
, Typ
);
1261 elsif Is_Array_Type
(Typ
) then
1263 -- A useful optimization: an aggregate with only an others clause
1264 -- always has the right bounds.
1266 if Nkind
(N
) = N_Aggregate
1267 and then No
(Expressions
(N
))
1269 (First
(Choices
(First
(Component_Associations
(N
)))))
1275 if Is_Constrained
(Typ
) then
1276 Apply_Length_Check
(N
, Typ
);
1279 Apply_Range_Check
(N
, Typ
);
1282 Apply_Range_Check
(N
, Typ
);
1285 elsif (Is_Record_Type
(Typ
) or else Is_Private_Type
(Typ
))
1286 and then Has_Discriminants
(Base_Type
(Typ
))
1287 and then Is_Constrained
(Typ
)
1289 Apply_Discriminant_Check
(N
, Typ
);
1291 elsif Is_Access_Type
(Typ
) then
1293 Desig_Typ
:= Designated_Type
(Typ
);
1295 -- No checks necessary if expression statically null
1297 if Known_Null
(N
) then
1298 if Can_Never_Be_Null
(Typ
) then
1299 Install_Null_Excluding_Check
(N
);
1302 -- No sliding possible on access to arrays
1304 elsif Is_Array_Type
(Desig_Typ
) then
1305 if Is_Constrained
(Desig_Typ
) then
1306 Apply_Length_Check
(N
, Typ
);
1309 Apply_Range_Check
(N
, Typ
);
1311 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
1312 and then Is_Constrained
(Desig_Typ
)
1314 Apply_Discriminant_Check
(N
, Typ
);
1317 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1318 -- this check if the constraint node is illegal, as shown by having
1319 -- an error posted. This additional guard prevents cascaded errors
1320 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1322 if Can_Never_Be_Null
(Typ
)
1323 and then not Can_Never_Be_Null
(Etype
(N
))
1324 and then not Error_Posted
(N
)
1326 Install_Null_Excluding_Check
(N
);
1329 end Apply_Constraint_Check
;
1331 ------------------------------
1332 -- Apply_Discriminant_Check --
1333 ------------------------------
1335 procedure Apply_Discriminant_Check
1338 Lhs
: Node_Id
:= Empty
)
1340 Loc
: constant Source_Ptr
:= Sloc
(N
);
1341 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1342 S_Typ
: Entity_Id
:= Etype
(N
);
1346 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean;
1347 -- A heap object with an indefinite subtype is constrained by its
1348 -- initial value, and assigning to it requires a constraint_check.
1349 -- The target may be an explicit dereference, or a renaming of one.
1351 function Is_Aliased_Unconstrained_Component
return Boolean;
1352 -- It is possible for an aliased component to have a nominal
1353 -- unconstrained subtype (through instantiation). If this is a
1354 -- discriminated component assigned in the expansion of an aggregate
1355 -- in an initialization, the check must be suppressed. This unusual
1356 -- situation requires a predicate of its own.
1358 ----------------------------------
1359 -- Denotes_Explicit_Dereference --
1360 ----------------------------------
1362 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean is
1365 Nkind
(Obj
) = N_Explicit_Dereference
1367 (Is_Entity_Name
(Obj
)
1368 and then Present
(Renamed_Object
(Entity
(Obj
)))
1369 and then Nkind
(Renamed_Object
(Entity
(Obj
))) =
1370 N_Explicit_Dereference
);
1371 end Denotes_Explicit_Dereference
;
1373 ----------------------------------------
1374 -- Is_Aliased_Unconstrained_Component --
1375 ----------------------------------------
1377 function Is_Aliased_Unconstrained_Component
return Boolean is
1382 if Nkind
(Lhs
) /= N_Selected_Component
then
1385 Comp
:= Entity
(Selector_Name
(Lhs
));
1386 Pref
:= Prefix
(Lhs
);
1389 if Ekind
(Comp
) /= E_Component
1390 or else not Is_Aliased
(Comp
)
1395 return not Comes_From_Source
(Pref
)
1396 and then In_Instance
1397 and then not Is_Constrained
(Etype
(Comp
));
1398 end Is_Aliased_Unconstrained_Component
;
1400 -- Start of processing for Apply_Discriminant_Check
1404 T_Typ
:= Designated_Type
(Typ
);
1409 -- Nothing to do if discriminant checks are suppressed or else no code
1410 -- is to be generated
1412 if not Full_Expander_Active
1413 or else Discriminant_Checks_Suppressed
(T_Typ
)
1418 -- No discriminant checks necessary for an access when expression is
1419 -- statically Null. This is not only an optimization, it is fundamental
1420 -- because otherwise discriminant checks may be generated in init procs
1421 -- for types containing an access to a not-yet-frozen record, causing a
1422 -- deadly forward reference.
1424 -- Also, if the expression is of an access type whose designated type is
1425 -- incomplete, then the access value must be null and we suppress the
1428 if Known_Null
(N
) then
1431 elsif Is_Access_Type
(S_Typ
) then
1432 S_Typ
:= Designated_Type
(S_Typ
);
1434 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1439 -- If an assignment target is present, then we need to generate the
1440 -- actual subtype if the target is a parameter or aliased object with
1441 -- an unconstrained nominal subtype.
1443 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1444 -- subtype to the parameter and dereference cases, since other aliased
1445 -- objects are unconstrained (unless the nominal subtype is explicitly
1449 and then (Present
(Param_Entity
(Lhs
))
1450 or else (Ada_Version
< Ada_2005
1451 and then not Is_Constrained
(T_Typ
)
1452 and then Is_Aliased_View
(Lhs
)
1453 and then not Is_Aliased_Unconstrained_Component
)
1454 or else (Ada_Version
>= Ada_2005
1455 and then not Is_Constrained
(T_Typ
)
1456 and then Denotes_Explicit_Dereference
(Lhs
)
1457 and then Nkind
(Original_Node
(Lhs
)) /=
1460 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1463 -- Nothing to do if the type is unconstrained (this is the case where
1464 -- the actual subtype in the RM sense of N is unconstrained and no check
1467 if not Is_Constrained
(T_Typ
) then
1470 -- Ada 2005: nothing to do if the type is one for which there is a
1471 -- partial view that is constrained.
1473 elsif Ada_Version
>= Ada_2005
1474 and then Effectively_Has_Constrained_Partial_View
1475 (Typ
=> Base_Type
(T_Typ
),
1476 Scop
=> Current_Scope
)
1481 -- Nothing to do if the type is an Unchecked_Union
1483 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
1487 -- Suppress checks if the subtypes are the same. the check must be
1488 -- preserved in an assignment to a formal, because the constraint is
1489 -- given by the actual.
1491 if Nkind
(Original_Node
(N
)) /= N_Allocator
1493 or else not Is_Entity_Name
(Lhs
)
1494 or else No
(Param_Entity
(Lhs
)))
1497 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1498 and then not Is_Aliased_View
(Lhs
)
1503 -- We can also eliminate checks on allocators with a subtype mark that
1504 -- coincides with the context type. The context type may be a subtype
1505 -- without a constraint (common case, a generic actual).
1507 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1508 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1511 Alloc_Typ
: constant Entity_Id
:=
1512 Entity
(Expression
(Original_Node
(N
)));
1515 if Alloc_Typ
= T_Typ
1516 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1517 and then Is_Entity_Name
(
1518 Subtype_Indication
(Parent
(T_Typ
)))
1519 and then Alloc_Typ
= Base_Type
(T_Typ
))
1527 -- See if we have a case where the types are both constrained, and all
1528 -- the constraints are constants. In this case, we can do the check
1529 -- successfully at compile time.
1531 -- We skip this check for the case where the node is a rewritten`
1532 -- allocator, because it already carries the context subtype, and
1533 -- extracting the discriminants from the aggregate is messy.
1535 if Is_Constrained
(S_Typ
)
1536 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1546 -- S_Typ may not have discriminants in the case where it is a
1547 -- private type completed by a default discriminated type. In that
1548 -- case, we need to get the constraints from the underlying_type.
1549 -- If the underlying type is unconstrained (i.e. has no default
1550 -- discriminants) no check is needed.
1552 if Has_Discriminants
(S_Typ
) then
1553 Discr
:= First_Discriminant
(S_Typ
);
1554 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1557 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1560 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1566 -- A further optimization: if T_Typ is derived from S_Typ
1567 -- without imposing a constraint, no check is needed.
1569 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1570 N_Full_Type_Declaration
1573 Type_Def
: constant Node_Id
:=
1574 Type_Definition
(Original_Node
(Parent
(T_Typ
)));
1576 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1577 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1578 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1586 DconT
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
1588 while Present
(Discr
) loop
1589 ItemS
:= Node
(DconS
);
1590 ItemT
:= Node
(DconT
);
1592 -- For a discriminated component type constrained by the
1593 -- current instance of an enclosing type, there is no
1594 -- applicable discriminant check.
1596 if Nkind
(ItemT
) = N_Attribute_Reference
1597 and then Is_Access_Type
(Etype
(ItemT
))
1598 and then Is_Entity_Name
(Prefix
(ItemT
))
1599 and then Is_Type
(Entity
(Prefix
(ItemT
)))
1604 -- If the expressions for the discriminants are identical
1605 -- and it is side-effect free (for now just an entity),
1606 -- this may be a shared constraint, e.g. from a subtype
1607 -- without a constraint introduced as a generic actual.
1608 -- Examine other discriminants if any.
1611 and then Is_Entity_Name
(ItemS
)
1615 elsif not Is_OK_Static_Expression
(ItemS
)
1616 or else not Is_OK_Static_Expression
(ItemT
)
1620 elsif Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1621 if Do_Access
then -- needs run-time check.
1624 Apply_Compile_Time_Constraint_Error
1625 (N
, "incorrect value for discriminant&?",
1626 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1633 Next_Discriminant
(Discr
);
1642 -- Here we need a discriminant check. First build the expression
1643 -- for the comparisons of the discriminants:
1645 -- (n.disc1 /= typ.disc1) or else
1646 -- (n.disc2 /= typ.disc2) or else
1648 -- (n.discn /= typ.discn)
1650 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1652 -- If Lhs is set and is a parameter, then the condition is guarded by:
1653 -- lhs'constrained and then (condition built above)
1655 if Present
(Param_Entity
(Lhs
)) then
1659 Make_Attribute_Reference
(Loc
,
1660 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1661 Attribute_Name
=> Name_Constrained
),
1662 Right_Opnd
=> Cond
);
1666 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1670 Make_Raise_Constraint_Error
(Loc
,
1672 Reason
=> CE_Discriminant_Check_Failed
));
1673 end Apply_Discriminant_Check
;
1675 -------------------------
1676 -- Apply_Divide_Checks --
1677 -------------------------
1679 procedure Apply_Divide_Checks
(N
: Node_Id
) is
1680 Loc
: constant Source_Ptr
:= Sloc
(N
);
1681 Typ
: constant Entity_Id
:= Etype
(N
);
1682 Left
: constant Node_Id
:= Left_Opnd
(N
);
1683 Right
: constant Node_Id
:= Right_Opnd
(N
);
1685 Mode
: constant Overflow_Check_Type
:= Overflow_Check_Mode
;
1686 -- Current overflow checking mode
1696 pragma Warnings
(Off
, Lhi
);
1697 -- Don't actually use this value
1700 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1701 -- operating on signed integer types, then the only thing this routine
1702 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1703 -- procedure will (possibly later on during recursive downward calls),
1704 -- ensure that any needed overflow/division checks are properly applied.
1706 if Mode
in Minimized_Or_Eliminated
1707 and then Is_Signed_Integer_Type
(Typ
)
1709 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
1713 -- Proceed here in SUPPRESSED or CHECKED modes
1715 if Full_Expander_Active
1716 and then not Backend_Divide_Checks_On_Target
1717 and then Check_Needed
(Right
, Division_Check
)
1719 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
1721 -- Deal with division check
1723 if Do_Division_Check
(N
)
1724 and then not Division_Checks_Suppressed
(Typ
)
1726 Apply_Division_Check
(N
, Rlo
, Rhi
, ROK
);
1729 -- Deal with overflow check
1731 if Do_Overflow_Check
(N
)
1732 and then not Overflow_Checks_Suppressed
(Etype
(N
))
1735 -- Test for extremely annoying case of xxx'First divided by -1
1736 -- for division of signed integer types (only overflow case).
1738 if Nkind
(N
) = N_Op_Divide
1739 and then Is_Signed_Integer_Type
(Typ
)
1741 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
1742 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1744 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1746 ((not LOK
) or else (Llo
= LLB
))
1749 Make_Raise_Constraint_Error
(Loc
,
1755 Duplicate_Subexpr_Move_Checks
(Left
),
1756 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1760 Left_Opnd
=> Duplicate_Subexpr
(Right
),
1761 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1))),
1763 Reason
=> CE_Overflow_Check_Failed
));
1768 end Apply_Divide_Checks
;
1770 --------------------------
1771 -- Apply_Division_Check --
1772 --------------------------
1774 procedure Apply_Division_Check
1780 pragma Assert
(Do_Division_Check
(N
));
1782 Loc
: constant Source_Ptr
:= Sloc
(N
);
1783 Right
: constant Node_Id
:= Right_Opnd
(N
);
1786 if Full_Expander_Active
1787 and then not Backend_Divide_Checks_On_Target
1788 and then Check_Needed
(Right
, Division_Check
)
1790 -- See if division by zero possible, and if so generate test. This
1791 -- part of the test is not controlled by the -gnato switch, since
1792 -- it is a Division_Check and not an Overflow_Check.
1794 if Do_Division_Check
(N
) then
1795 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1797 Make_Raise_Constraint_Error
(Loc
,
1800 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1801 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1802 Reason
=> CE_Divide_By_Zero
));
1806 end Apply_Division_Check
;
1808 ----------------------------------
1809 -- Apply_Float_Conversion_Check --
1810 ----------------------------------
1812 -- Let F and I be the source and target types of the conversion. The RM
1813 -- specifies that a floating-point value X is rounded to the nearest
1814 -- integer, with halfway cases being rounded away from zero. The rounded
1815 -- value of X is checked against I'Range.
1817 -- The catch in the above paragraph is that there is no good way to know
1818 -- whether the round-to-integer operation resulted in overflow. A remedy is
1819 -- to perform a range check in the floating-point domain instead, however:
1821 -- (1) The bounds may not be known at compile time
1822 -- (2) The check must take into account rounding or truncation.
1823 -- (3) The range of type I may not be exactly representable in F.
1824 -- (4) For the rounding case, The end-points I'First - 0.5 and
1825 -- I'Last + 0.5 may or may not be in range, depending on the
1826 -- sign of I'First and I'Last.
1827 -- (5) X may be a NaN, which will fail any comparison
1829 -- The following steps correctly convert X with rounding:
1831 -- (1) If either I'First or I'Last is not known at compile time, use
1832 -- I'Base instead of I in the next three steps and perform a
1833 -- regular range check against I'Range after conversion.
1834 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1835 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1836 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1837 -- In other words, take one of the closest floating-point numbers
1838 -- (which is an integer value) to I'First, and see if it is in
1840 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1841 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1842 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1843 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1844 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1846 -- For the truncating case, replace steps (2) and (3) as follows:
1847 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1848 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1850 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1851 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1854 procedure Apply_Float_Conversion_Check
1856 Target_Typ
: Entity_Id
)
1858 LB
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1859 HB
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1860 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1861 Expr_Type
: constant Entity_Id
:= Base_Type
(Etype
(Ck_Node
));
1862 Target_Base
: constant Entity_Id
:=
1863 Implementation_Base_Type
(Target_Typ
);
1865 Par
: constant Node_Id
:= Parent
(Ck_Node
);
1866 pragma Assert
(Nkind
(Par
) = N_Type_Conversion
);
1867 -- Parent of check node, must be a type conversion
1869 Truncate
: constant Boolean := Float_Truncate
(Par
);
1870 Max_Bound
: constant Uint
:=
1872 (Machine_Radix_Value
(Expr_Type
),
1873 Machine_Mantissa_Value
(Expr_Type
) - 1) - 1;
1875 -- Largest bound, so bound plus or minus half is a machine number of F
1877 Ifirst
, Ilast
: Uint
;
1878 -- Bounds of integer type
1881 -- Bounds to check in floating-point domain
1883 Lo_OK
, Hi_OK
: Boolean;
1884 -- True iff Lo resp. Hi belongs to I'Range
1886 Lo_Chk
, Hi_Chk
: Node_Id
;
1887 -- Expressions that are False iff check fails
1889 Reason
: RT_Exception_Code
;
1892 if not Compile_Time_Known_Value
(LB
)
1893 or not Compile_Time_Known_Value
(HB
)
1896 -- First check that the value falls in the range of the base type,
1897 -- to prevent overflow during conversion and then perform a
1898 -- regular range check against the (dynamic) bounds.
1900 pragma Assert
(Target_Base
/= Target_Typ
);
1902 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Par
);
1905 Apply_Float_Conversion_Check
(Ck_Node
, Target_Base
);
1906 Set_Etype
(Temp
, Target_Base
);
1908 Insert_Action
(Parent
(Par
),
1909 Make_Object_Declaration
(Loc
,
1910 Defining_Identifier
=> Temp
,
1911 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
),
1912 Expression
=> New_Copy_Tree
(Par
)),
1913 Suppress
=> All_Checks
);
1916 Make_Raise_Constraint_Error
(Loc
,
1919 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
1920 Right_Opnd
=> New_Occurrence_Of
(Target_Typ
, Loc
)),
1921 Reason
=> CE_Range_Check_Failed
));
1922 Rewrite
(Par
, New_Occurrence_Of
(Temp
, Loc
));
1928 -- Get the (static) bounds of the target type
1930 Ifirst
:= Expr_Value
(LB
);
1931 Ilast
:= Expr_Value
(HB
);
1933 -- A simple optimization: if the expression is a universal literal,
1934 -- we can do the comparison with the bounds and the conversion to
1935 -- an integer type statically. The range checks are unchanged.
1937 if Nkind
(Ck_Node
) = N_Real_Literal
1938 and then Etype
(Ck_Node
) = Universal_Real
1939 and then Is_Integer_Type
(Target_Typ
)
1940 and then Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
1943 Int_Val
: constant Uint
:= UR_To_Uint
(Realval
(Ck_Node
));
1946 if Int_Val
<= Ilast
and then Int_Val
>= Ifirst
then
1948 -- Conversion is safe
1950 Rewrite
(Parent
(Ck_Node
),
1951 Make_Integer_Literal
(Loc
, UI_To_Int
(Int_Val
)));
1952 Analyze_And_Resolve
(Parent
(Ck_Node
), Target_Typ
);
1958 -- Check against lower bound
1960 if Truncate
and then Ifirst
> 0 then
1961 Lo
:= Pred
(Expr_Type
, UR_From_Uint
(Ifirst
));
1965 Lo
:= Succ
(Expr_Type
, UR_From_Uint
(Ifirst
- 1));
1968 elsif abs (Ifirst
) < Max_Bound
then
1969 Lo
:= UR_From_Uint
(Ifirst
) - Ureal_Half
;
1970 Lo_OK
:= (Ifirst
> 0);
1973 Lo
:= Machine
(Expr_Type
, UR_From_Uint
(Ifirst
), Round_Even
, Ck_Node
);
1974 Lo_OK
:= (Lo
>= UR_From_Uint
(Ifirst
));
1979 -- Lo_Chk := (X >= Lo)
1981 Lo_Chk
:= Make_Op_Ge
(Loc
,
1982 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1983 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
1986 -- Lo_Chk := (X > Lo)
1988 Lo_Chk
:= Make_Op_Gt
(Loc
,
1989 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1990 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
1993 -- Check against higher bound
1995 if Truncate
and then Ilast
< 0 then
1996 Hi
:= Succ
(Expr_Type
, UR_From_Uint
(Ilast
));
2000 Hi
:= Pred
(Expr_Type
, UR_From_Uint
(Ilast
+ 1));
2003 elsif abs (Ilast
) < Max_Bound
then
2004 Hi
:= UR_From_Uint
(Ilast
) + Ureal_Half
;
2005 Hi_OK
:= (Ilast
< 0);
2007 Hi
:= Machine
(Expr_Type
, UR_From_Uint
(Ilast
), Round_Even
, Ck_Node
);
2008 Hi_OK
:= (Hi
<= UR_From_Uint
(Ilast
));
2013 -- Hi_Chk := (X <= Hi)
2015 Hi_Chk
:= Make_Op_Le
(Loc
,
2016 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2017 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2020 -- Hi_Chk := (X < Hi)
2022 Hi_Chk
:= Make_Op_Lt
(Loc
,
2023 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2024 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2027 -- If the bounds of the target type are the same as those of the base
2028 -- type, the check is an overflow check as a range check is not
2029 -- performed in these cases.
2031 if Expr_Value
(Type_Low_Bound
(Target_Base
)) = Ifirst
2032 and then Expr_Value
(Type_High_Bound
(Target_Base
)) = Ilast
2034 Reason
:= CE_Overflow_Check_Failed
;
2036 Reason
:= CE_Range_Check_Failed
;
2039 -- Raise CE if either conditions does not hold
2041 Insert_Action
(Ck_Node
,
2042 Make_Raise_Constraint_Error
(Loc
,
2043 Condition
=> Make_Op_Not
(Loc
, Make_And_Then
(Loc
, Lo_Chk
, Hi_Chk
)),
2045 end Apply_Float_Conversion_Check
;
2047 ------------------------
2048 -- Apply_Length_Check --
2049 ------------------------
2051 procedure Apply_Length_Check
2053 Target_Typ
: Entity_Id
;
2054 Source_Typ
: Entity_Id
:= Empty
)
2057 Apply_Selected_Length_Checks
2058 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2059 end Apply_Length_Check
;
2061 -------------------------------------
2062 -- Apply_Parameter_Aliasing_Checks --
2063 -------------------------------------
2065 procedure Apply_Parameter_Aliasing_Checks
2069 function May_Cause_Aliasing
2070 (Formal_1
: Entity_Id
;
2071 Formal_2
: Entity_Id
) return Boolean;
2072 -- Determine whether two formal parameters can alias each other
2073 -- depending on their modes.
2075 function Original_Actual
(N
: Node_Id
) return Node_Id
;
2076 -- The expander may replace an actual with a temporary for the sake of
2077 -- side effect removal. The temporary may hide a potential aliasing as
2078 -- it does not share the address of the actual. This routine attempts
2079 -- to retrieve the original actual.
2081 ------------------------
2082 -- May_Cause_Aliasing --
2083 ------------------------
2085 function May_Cause_Aliasing
2086 (Formal_1
: Entity_Id
;
2087 Formal_2
: Entity_Id
) return Boolean
2090 -- The following combination cannot lead to aliasing
2092 -- Formal 1 Formal 2
2095 if Ekind
(Formal_1
) = E_In_Parameter
2097 Ekind
(Formal_2
) = E_In_Parameter
2101 -- The following combinations may lead to aliasing
2103 -- Formal 1 Formal 2
2113 end May_Cause_Aliasing
;
2115 ---------------------
2116 -- Original_Actual --
2117 ---------------------
2119 function Original_Actual
(N
: Node_Id
) return Node_Id
is
2121 if Nkind
(N
) = N_Type_Conversion
then
2122 return Expression
(N
);
2124 -- The expander created a temporary to capture the result of a type
2125 -- conversion where the expression is the real actual.
2127 elsif Nkind
(N
) = N_Identifier
2128 and then Present
(Original_Node
(N
))
2129 and then Nkind
(Original_Node
(N
)) = N_Type_Conversion
2131 return Expression
(Original_Node
(N
));
2135 end Original_Actual
;
2139 Loc
: constant Source_Ptr
:= Sloc
(Call
);
2144 Formal_1
: Entity_Id
;
2145 Formal_2
: Entity_Id
;
2147 -- Start of processing for Apply_Parameter_Aliasing_Checks
2152 Actual_1
:= First_Actual
(Call
);
2153 Formal_1
:= First_Formal
(Subp
);
2154 while Present
(Actual_1
) and then Present
(Formal_1
) loop
2156 -- Ensure that the actual is an object that is not passed by value.
2157 -- Elementary types are always passed by value, therefore actuals of
2158 -- such types cannot lead to aliasing.
2160 if Is_Object_Reference
(Original_Actual
(Actual_1
))
2161 and then not Is_Elementary_Type
(Etype
(Original_Actual
(Actual_1
)))
2163 Actual_2
:= Next_Actual
(Actual_1
);
2164 Formal_2
:= Next_Formal
(Formal_1
);
2165 while Present
(Actual_2
) and then Present
(Formal_2
) loop
2167 -- The other actual we are testing against must also denote
2168 -- a non pass-by-value object. Generate the check only when
2169 -- the mode of the two formals may lead to aliasing.
2171 if Is_Object_Reference
(Original_Actual
(Actual_2
))
2173 Is_Elementary_Type
(Etype
(Original_Actual
(Actual_2
)))
2174 and then May_Cause_Aliasing
(Formal_1
, Formal_2
)
2177 -- Actual_1'Overlaps_Storage (Actual_2)
2180 Make_Attribute_Reference
(Loc
,
2182 New_Copy_Tree
(Original_Actual
(Actual_1
)),
2183 Attribute_Name
=> Name_Overlaps_Storage
,
2185 New_List
(New_Copy_Tree
(Original_Actual
(Actual_2
))));
2193 Right_Opnd
=> Check
);
2197 Next_Actual
(Actual_2
);
2198 Next_Formal
(Formal_2
);
2202 Next_Actual
(Actual_1
);
2203 Next_Formal
(Formal_1
);
2206 -- Place the check right before the call
2208 if Present
(Cond
) then
2209 Insert_Action
(Call
,
2210 Make_Raise_Program_Error
(Loc
,
2212 Reason
=> PE_Explicit_Raise
));
2214 end Apply_Parameter_Aliasing_Checks
;
2216 -------------------------------------
2217 -- Apply_Parameter_Validity_Checks --
2218 -------------------------------------
2220 procedure Apply_Parameter_Validity_Checks
(Subp
: Entity_Id
) is
2221 Subp_Decl
: Node_Id
;
2223 procedure Add_Validity_Check
2224 (Context
: Entity_Id
;
2226 For_Result
: Boolean := False);
2227 -- Add a single 'Valid[_Scalar] check which verifies the initialization
2228 -- of Context. PPC_Nam denotes the pre or post condition pragma name.
2229 -- Set flag For_Result when to verify the result of a function.
2231 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
);
2232 -- Create a pre or post condition pragma with name PPC_Nam which
2233 -- tests expression Check.
2235 ------------------------
2236 -- Add_Validity_Check --
2237 ------------------------
2239 procedure Add_Validity_Check
2240 (Context
: Entity_Id
;
2242 For_Result
: Boolean := False)
2244 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2245 Typ
: constant Entity_Id
:= Etype
(Context
);
2250 -- Pick the proper version of 'Valid depending on the type of the
2251 -- context. If the context is not eligible for such a check, return.
2253 if Is_Scalar_Type
(Typ
) then
2255 elsif not No_Scalar_Parts
(Typ
) then
2256 Nam
:= Name_Valid_Scalars
;
2261 -- Step 1: Create the expression to verify the validity of the
2264 Check
:= New_Reference_To
(Context
, Loc
);
2266 -- When processing a function result, use 'Result. Generate
2271 Make_Attribute_Reference
(Loc
,
2273 Attribute_Name
=> Name_Result
);
2277 -- Context['Result]'Valid[_Scalars]
2280 Make_Attribute_Reference
(Loc
,
2282 Attribute_Name
=> Nam
);
2284 -- Step 2: Create a pre or post condition pragma
2286 Build_PPC_Pragma
(PPC_Nam
, Check
);
2287 end Add_Validity_Check
;
2289 ----------------------
2290 -- Build_PPC_Pragma --
2291 ----------------------
2293 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
) is
2294 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2301 Pragma_Identifier
=> Make_Identifier
(Loc
, PPC_Nam
),
2302 Pragma_Argument_Associations
=> New_List
(
2303 Make_Pragma_Argument_Association
(Loc
,
2304 Chars
=> Name_Check
,
2305 Expression
=> Check
)));
2307 -- Add a message unless exception messages are suppressed
2309 if not Exception_Locations_Suppressed
then
2310 Append_To
(Pragma_Argument_Associations
(Prag
),
2311 Make_Pragma_Argument_Association
(Loc
,
2312 Chars
=> Name_Message
,
2314 Make_String_Literal
(Loc
,
2315 Strval
=> "failed " & Get_Name_String
(PPC_Nam
) &
2316 " from " & Build_Location_String
(Loc
))));
2319 -- Insert the pragma in the tree
2321 if Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
then
2322 Add_Global_Declaration
(Prag
);
2325 -- PPC pragmas associated with subprogram bodies must be inserted in
2326 -- the declarative part of the body.
2328 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
then
2329 Decls
:= Declarations
(Subp_Decl
);
2333 Set_Declarations
(Subp_Decl
, Decls
);
2336 Prepend_To
(Decls
, Prag
);
2338 -- Ensure the proper visibility of the subprogram body and its
2345 -- For subprogram declarations insert the PPC pragma right after the
2346 -- declarative node.
2349 Insert_After_And_Analyze
(Subp_Decl
, Prag
);
2351 end Build_PPC_Pragma
;
2356 Subp_Spec
: Node_Id
;
2358 -- Start of processing for Apply_Parameter_Validity_Checks
2361 -- Extract the subprogram specification and declaration nodes
2363 Subp_Spec
:= Parent
(Subp
);
2365 if Nkind
(Subp_Spec
) = N_Defining_Program_Unit_Name
then
2366 Subp_Spec
:= Parent
(Subp_Spec
);
2369 Subp_Decl
:= Parent
(Subp_Spec
);
2371 if not Comes_From_Source
(Subp
)
2373 -- Do not process formal subprograms because the corresponding actual
2374 -- will receive the proper checks when the instance is analyzed.
2376 or else Is_Formal_Subprogram
(Subp
)
2378 -- Do not process imported subprograms since pre and post conditions
2379 -- are never verified on routines coming from a different language.
2381 or else Is_Imported
(Subp
)
2382 or else Is_Intrinsic_Subprogram
(Subp
)
2384 -- The PPC pragmas generated by this routine do not correspond to
2385 -- source aspects, therefore they cannot be applied to abstract
2388 or else Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
2390 -- Do not consider subprogram renaminds because the renamed entity
2391 -- already has the proper PPC pragmas.
2393 or else Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
2395 -- Do not process null procedures because there is no benefit of
2396 -- adding the checks to a no action routine.
2398 or else (Nkind
(Subp_Spec
) = N_Procedure_Specification
2399 and then Null_Present
(Subp_Spec
))
2404 -- Inspect all the formals applying aliasing and scalar initialization
2405 -- checks where applicable.
2407 Formal
:= First_Formal
(Subp
);
2408 while Present
(Formal
) loop
2410 -- Generate the following scalar initialization checks for each
2411 -- formal parameter:
2413 -- mode IN - Pre => Formal'Valid[_Scalars]
2414 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2415 -- mode OUT - Post => Formal'Valid[_Scalars]
2417 if Check_Validity_Of_Parameters
then
2418 if Ekind_In
(Formal
, E_In_Parameter
, E_In_Out_Parameter
) then
2419 Add_Validity_Check
(Formal
, Name_Precondition
, False);
2422 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
2423 Add_Validity_Check
(Formal
, Name_Postcondition
, False);
2427 Next_Formal
(Formal
);
2430 -- Generate following scalar initialization check for function result:
2432 -- Post => Subp'Result'Valid[_Scalars]
2434 if Check_Validity_Of_Parameters
and then Ekind
(Subp
) = E_Function
then
2435 Add_Validity_Check
(Subp
, Name_Postcondition
, True);
2437 end Apply_Parameter_Validity_Checks
;
2439 ---------------------------
2440 -- Apply_Predicate_Check --
2441 ---------------------------
2443 procedure Apply_Predicate_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
2447 if Present
(Predicate_Function
(Typ
)) then
2449 -- A predicate check does not apply within internally generated
2450 -- subprograms, such as TSS functions.
2453 while Present
(S
) and then not Is_Subprogram
(S
) loop
2457 if Present
(S
) and then Get_TSS_Name
(S
) /= TSS_Null
then
2460 -- If the check appears within the predicate function itself, it
2461 -- means that the user specified a check whose formal is the
2462 -- predicated subtype itself, rather than some covering type. This
2463 -- is likely to be a common error, and thus deserves a warning.
2465 elsif S
= Predicate_Function
(Typ
) then
2467 ("predicate check includes a function call that "
2468 & "requires a predicate check?", Parent
(N
));
2470 ("\this will result in infinite recursion?", Parent
(N
));
2472 Make_Raise_Storage_Error
(Sloc
(N
),
2473 Reason
=> SE_Infinite_Recursion
));
2475 -- Here for normal case of predicate active.
2478 -- If the predicate is a static predicate and the operand is
2479 -- static, the predicate must be evaluated statically. If the
2480 -- evaluation fails this is a static constraint error. This check
2481 -- is disabled in -gnatc mode, because the compiler is incapable
2482 -- of evaluating static expressions in that case.
2484 if Is_OK_Static_Expression
(N
) then
2485 if Present
(Static_Predicate
(Typ
)) then
2486 if Operating_Mode
< Generate_Code
2487 or else Eval_Static_Predicate_Check
(N
, Typ
)
2492 ("static expression fails static predicate check on&",
2499 Make_Predicate_Check
(Typ
, Duplicate_Subexpr
(N
)));
2502 end Apply_Predicate_Check
;
2504 -----------------------
2505 -- Apply_Range_Check --
2506 -----------------------
2508 procedure Apply_Range_Check
2510 Target_Typ
: Entity_Id
;
2511 Source_Typ
: Entity_Id
:= Empty
)
2514 Apply_Selected_Range_Checks
2515 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2516 end Apply_Range_Check
;
2518 ------------------------------
2519 -- Apply_Scalar_Range_Check --
2520 ------------------------------
2522 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
2523 -- off if it is already set on.
2525 procedure Apply_Scalar_Range_Check
2527 Target_Typ
: Entity_Id
;
2528 Source_Typ
: Entity_Id
:= Empty
;
2529 Fixed_Int
: Boolean := False)
2531 Parnt
: constant Node_Id
:= Parent
(Expr
);
2533 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
2534 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
2537 Is_Subscr_Ref
: Boolean;
2538 -- Set true if Expr is a subscript
2540 Is_Unconstrained_Subscr_Ref
: Boolean;
2541 -- Set true if Expr is a subscript of an unconstrained array. In this
2542 -- case we do not attempt to do an analysis of the value against the
2543 -- range of the subscript, since we don't know the actual subtype.
2546 -- Set to True if Expr should be regarded as a real value even though
2547 -- the type of Expr might be discrete.
2549 procedure Bad_Value
;
2550 -- Procedure called if value is determined to be out of range
2556 procedure Bad_Value
is
2558 Apply_Compile_Time_Constraint_Error
2559 (Expr
, "value not in range of}?", CE_Range_Check_Failed
,
2564 -- Start of processing for Apply_Scalar_Range_Check
2567 -- Return if check obviously not needed
2570 -- Not needed inside generic
2574 -- Not needed if previous error
2576 or else Target_Typ
= Any_Type
2577 or else Nkind
(Expr
) = N_Error
2579 -- Not needed for non-scalar type
2581 or else not Is_Scalar_Type
(Target_Typ
)
2583 -- Not needed if we know node raises CE already
2585 or else Raises_Constraint_Error
(Expr
)
2590 -- Now, see if checks are suppressed
2593 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
2595 if Is_Subscr_Ref
then
2596 Arr
:= Prefix
(Parnt
);
2597 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
2599 if Is_Access_Type
(Arr_Typ
) then
2600 Arr_Typ
:= Designated_Type
(Arr_Typ
);
2604 if not Do_Range_Check
(Expr
) then
2606 -- Subscript reference. Check for Index_Checks suppressed
2608 if Is_Subscr_Ref
then
2610 -- Check array type and its base type
2612 if Index_Checks_Suppressed
(Arr_Typ
)
2613 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
2617 -- Check array itself if it is an entity name
2619 elsif Is_Entity_Name
(Arr
)
2620 and then Index_Checks_Suppressed
(Entity
(Arr
))
2624 -- Check expression itself if it is an entity name
2626 elsif Is_Entity_Name
(Expr
)
2627 and then Index_Checks_Suppressed
(Entity
(Expr
))
2632 -- All other cases, check for Range_Checks suppressed
2635 -- Check target type and its base type
2637 if Range_Checks_Suppressed
(Target_Typ
)
2638 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
2642 -- Check expression itself if it is an entity name
2644 elsif Is_Entity_Name
(Expr
)
2645 and then Range_Checks_Suppressed
(Entity
(Expr
))
2649 -- If Expr is part of an assignment statement, then check left
2650 -- side of assignment if it is an entity name.
2652 elsif Nkind
(Parnt
) = N_Assignment_Statement
2653 and then Is_Entity_Name
(Name
(Parnt
))
2654 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
2661 -- Do not set range checks if they are killed
2663 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
2664 and then Kill_Range_Check
(Expr
)
2669 -- Do not set range checks for any values from System.Scalar_Values
2670 -- since the whole idea of such values is to avoid checking them!
2672 if Is_Entity_Name
(Expr
)
2673 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
2678 -- Now see if we need a check
2680 if No
(Source_Typ
) then
2681 S_Typ
:= Etype
(Expr
);
2683 S_Typ
:= Source_Typ
;
2686 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
2690 Is_Unconstrained_Subscr_Ref
:=
2691 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
2693 -- Always do a range check if the source type includes infinities and
2694 -- the target type does not include infinities. We do not do this if
2695 -- range checks are killed.
2697 if Is_Floating_Point_Type
(S_Typ
)
2698 and then Has_Infinities
(S_Typ
)
2699 and then not Has_Infinities
(Target_Typ
)
2701 Enable_Range_Check
(Expr
);
2704 -- Return if we know expression is definitely in the range of the target
2705 -- type as determined by Determine_Range. Right now we only do this for
2706 -- discrete types, and not fixed-point or floating-point types.
2708 -- The additional less-precise tests below catch these cases
2710 -- Note: skip this if we are given a source_typ, since the point of
2711 -- supplying a Source_Typ is to stop us looking at the expression.
2712 -- We could sharpen this test to be out parameters only ???
2714 if Is_Discrete_Type
(Target_Typ
)
2715 and then Is_Discrete_Type
(Etype
(Expr
))
2716 and then not Is_Unconstrained_Subscr_Ref
2717 and then No
(Source_Typ
)
2720 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
2721 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
2726 if Compile_Time_Known_Value
(Tlo
)
2727 and then Compile_Time_Known_Value
(Thi
)
2730 Lov
: constant Uint
:= Expr_Value
(Tlo
);
2731 Hiv
: constant Uint
:= Expr_Value
(Thi
);
2734 -- If range is null, we for sure have a constraint error
2735 -- (we don't even need to look at the value involved,
2736 -- since all possible values will raise CE).
2743 -- Otherwise determine range of value
2745 Determine_Range
(Expr
, OK
, Lo
, Hi
, Assume_Valid
=> True);
2749 -- If definitely in range, all OK
2751 if Lo
>= Lov
and then Hi
<= Hiv
then
2754 -- If definitely not in range, warn
2756 elsif Lov
> Hi
or else Hiv
< Lo
then
2760 -- Otherwise we don't know
2772 Is_Floating_Point_Type
(S_Typ
)
2773 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
2775 -- Check if we can determine at compile time whether Expr is in the
2776 -- range of the target type. Note that if S_Typ is within the bounds
2777 -- of Target_Typ then this must be the case. This check is meaningful
2778 -- only if this is not a conversion between integer and real types.
2780 if not Is_Unconstrained_Subscr_Ref
2782 Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
2784 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
2786 Is_In_Range
(Expr
, Target_Typ
,
2787 Assume_Valid
=> True,
2788 Fixed_Int
=> Fixed_Int
,
2789 Int_Real
=> Int_Real
))
2793 elsif Is_Out_Of_Range
(Expr
, Target_Typ
,
2794 Assume_Valid
=> True,
2795 Fixed_Int
=> Fixed_Int
,
2796 Int_Real
=> Int_Real
)
2801 -- In the floating-point case, we only do range checks if the type is
2802 -- constrained. We definitely do NOT want range checks for unconstrained
2803 -- types, since we want to have infinities
2805 elsif Is_Floating_Point_Type
(S_Typ
) then
2806 if Is_Constrained
(S_Typ
) then
2807 Enable_Range_Check
(Expr
);
2810 -- For all other cases we enable a range check unconditionally
2813 Enable_Range_Check
(Expr
);
2816 end Apply_Scalar_Range_Check
;
2818 ----------------------------------
2819 -- Apply_Selected_Length_Checks --
2820 ----------------------------------
2822 procedure Apply_Selected_Length_Checks
2824 Target_Typ
: Entity_Id
;
2825 Source_Typ
: Entity_Id
;
2826 Do_Static
: Boolean)
2829 R_Result
: Check_Result
;
2832 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
2833 Checks_On
: constant Boolean :=
2834 (not Index_Checks_Suppressed
(Target_Typ
))
2835 or else (not Length_Checks_Suppressed
(Target_Typ
));
2838 if not Full_Expander_Active
then
2843 Selected_Length_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
2845 for J
in 1 .. 2 loop
2846 R_Cno
:= R_Result
(J
);
2847 exit when No
(R_Cno
);
2849 -- A length check may mention an Itype which is attached to a
2850 -- subsequent node. At the top level in a package this can cause
2851 -- an order-of-elaboration problem, so we make sure that the itype
2852 -- is referenced now.
2854 if Ekind
(Current_Scope
) = E_Package
2855 and then Is_Compilation_Unit
(Current_Scope
)
2857 Ensure_Defined
(Target_Typ
, Ck_Node
);
2859 if Present
(Source_Typ
) then
2860 Ensure_Defined
(Source_Typ
, Ck_Node
);
2862 elsif Is_Itype
(Etype
(Ck_Node
)) then
2863 Ensure_Defined
(Etype
(Ck_Node
), Ck_Node
);
2867 -- If the item is a conditional raise of constraint error, then have
2868 -- a look at what check is being performed and ???
2870 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
2871 and then Present
(Condition
(R_Cno
))
2873 Cond
:= Condition
(R_Cno
);
2875 -- Case where node does not now have a dynamic check
2877 if not Has_Dynamic_Length_Check
(Ck_Node
) then
2879 -- If checks are on, just insert the check
2882 Insert_Action
(Ck_Node
, R_Cno
);
2884 if not Do_Static
then
2885 Set_Has_Dynamic_Length_Check
(Ck_Node
);
2888 -- If checks are off, then analyze the length check after
2889 -- temporarily attaching it to the tree in case the relevant
2890 -- condition can be evaluated at compile time. We still want a
2891 -- compile time warning in this case.
2894 Set_Parent
(R_Cno
, Ck_Node
);
2899 -- Output a warning if the condition is known to be True
2901 if Is_Entity_Name
(Cond
)
2902 and then Entity
(Cond
) = Standard_True
2904 Apply_Compile_Time_Constraint_Error
2905 (Ck_Node
, "wrong length for array of}?",
2906 CE_Length_Check_Failed
,
2910 -- If we were only doing a static check, or if checks are not
2911 -- on, then we want to delete the check, since it is not needed.
2912 -- We do this by replacing the if statement by a null statement
2914 elsif Do_Static
or else not Checks_On
then
2915 Remove_Warning_Messages
(R_Cno
);
2916 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
2920 Install_Static_Check
(R_Cno
, Loc
);
2923 end Apply_Selected_Length_Checks
;
2925 ---------------------------------
2926 -- Apply_Selected_Range_Checks --
2927 ---------------------------------
2929 procedure Apply_Selected_Range_Checks
2931 Target_Typ
: Entity_Id
;
2932 Source_Typ
: Entity_Id
;
2933 Do_Static
: Boolean)
2936 R_Result
: Check_Result
;
2939 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
2940 Checks_On
: constant Boolean :=
2941 (not Index_Checks_Suppressed
(Target_Typ
))
2942 or else (not Range_Checks_Suppressed
(Target_Typ
));
2945 if not Full_Expander_Active
or else not Checks_On
then
2950 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
2952 for J
in 1 .. 2 loop
2954 R_Cno
:= R_Result
(J
);
2955 exit when No
(R_Cno
);
2957 -- If the item is a conditional raise of constraint error, then have
2958 -- a look at what check is being performed and ???
2960 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
2961 and then Present
(Condition
(R_Cno
))
2963 Cond
:= Condition
(R_Cno
);
2965 if not Has_Dynamic_Range_Check
(Ck_Node
) then
2966 Insert_Action
(Ck_Node
, R_Cno
);
2968 if not Do_Static
then
2969 Set_Has_Dynamic_Range_Check
(Ck_Node
);
2973 -- Output a warning if the condition is known to be True
2975 if Is_Entity_Name
(Cond
)
2976 and then Entity
(Cond
) = Standard_True
2978 -- Since an N_Range is technically not an expression, we have
2979 -- to set one of the bounds to C_E and then just flag the
2980 -- N_Range. The warning message will point to the lower bound
2981 -- and complain about a range, which seems OK.
2983 if Nkind
(Ck_Node
) = N_Range
then
2984 Apply_Compile_Time_Constraint_Error
2985 (Low_Bound
(Ck_Node
), "static range out of bounds of}?",
2986 CE_Range_Check_Failed
,
2990 Set_Raises_Constraint_Error
(Ck_Node
);
2993 Apply_Compile_Time_Constraint_Error
2994 (Ck_Node
, "static value out of range of}?",
2995 CE_Range_Check_Failed
,
3000 -- If we were only doing a static check, or if checks are not
3001 -- on, then we want to delete the check, since it is not needed.
3002 -- We do this by replacing the if statement by a null statement
3004 elsif Do_Static
or else not Checks_On
then
3005 Remove_Warning_Messages
(R_Cno
);
3006 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3010 Install_Static_Check
(R_Cno
, Loc
);
3013 end Apply_Selected_Range_Checks
;
3015 -------------------------------
3016 -- Apply_Static_Length_Check --
3017 -------------------------------
3019 procedure Apply_Static_Length_Check
3021 Target_Typ
: Entity_Id
;
3022 Source_Typ
: Entity_Id
:= Empty
)
3025 Apply_Selected_Length_Checks
3026 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
3027 end Apply_Static_Length_Check
;
3029 -------------------------------------
3030 -- Apply_Subscript_Validity_Checks --
3031 -------------------------------------
3033 procedure Apply_Subscript_Validity_Checks
(Expr
: Node_Id
) is
3037 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
3039 -- Loop through subscripts
3041 Sub
:= First
(Expressions
(Expr
));
3042 while Present
(Sub
) loop
3044 -- Check one subscript. Note that we do not worry about enumeration
3045 -- type with holes, since we will convert the value to a Pos value
3046 -- for the subscript, and that convert will do the necessary validity
3049 Ensure_Valid
(Sub
, Holes_OK
=> True);
3051 -- Move to next subscript
3055 end Apply_Subscript_Validity_Checks
;
3057 ----------------------------------
3058 -- Apply_Type_Conversion_Checks --
3059 ----------------------------------
3061 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
3062 Target_Type
: constant Entity_Id
:= Etype
(N
);
3063 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
3064 Expr
: constant Node_Id
:= Expression
(N
);
3066 Expr_Type
: constant Entity_Id
:= Underlying_Type
(Etype
(Expr
));
3067 -- Note: if Etype (Expr) is a private type without discriminants, its
3068 -- full view might have discriminants with defaults, so we need the
3069 -- full view here to retrieve the constraints.
3072 if Inside_A_Generic
then
3075 -- Skip these checks if serious errors detected, there are some nasty
3076 -- situations of incomplete trees that blow things up.
3078 elsif Serious_Errors_Detected
> 0 then
3081 -- Scalar type conversions of the form Target_Type (Expr) require a
3082 -- range check if we cannot be sure that Expr is in the base type of
3083 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3084 -- are not quite the same condition from an implementation point of
3085 -- view, but clearly the second includes the first.
3087 elsif Is_Scalar_Type
(Target_Type
) then
3089 Conv_OK
: constant Boolean := Conversion_OK
(N
);
3090 -- If the Conversion_OK flag on the type conversion is set and no
3091 -- floating point type is involved in the type conversion then
3092 -- fixed point values must be read as integral values.
3094 Float_To_Int
: constant Boolean :=
3095 Is_Floating_Point_Type
(Expr_Type
)
3096 and then Is_Integer_Type
(Target_Type
);
3099 if not Overflow_Checks_Suppressed
(Target_Base
)
3100 and then not Overflow_Checks_Suppressed
(Target_Type
)
3102 In_Subrange_Of
(Expr_Type
, Target_Base
, Fixed_Int
=> Conv_OK
)
3103 and then not Float_To_Int
3105 Activate_Overflow_Check
(N
);
3108 if not Range_Checks_Suppressed
(Target_Type
)
3109 and then not Range_Checks_Suppressed
(Expr_Type
)
3111 if Float_To_Int
then
3112 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
3114 Apply_Scalar_Range_Check
3115 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
3117 -- If the target type has predicates, we need to indicate
3118 -- the need for a check, even if Determine_Range finds
3119 -- that the value is within bounds. This may be the case
3120 -- e.g for a division with a constant denominator.
3122 if Has_Predicates
(Target_Type
) then
3123 Enable_Range_Check
(Expr
);
3129 elsif Comes_From_Source
(N
)
3130 and then not Discriminant_Checks_Suppressed
(Target_Type
)
3131 and then Is_Record_Type
(Target_Type
)
3132 and then Is_Derived_Type
(Target_Type
)
3133 and then not Is_Tagged_Type
(Target_Type
)
3134 and then not Is_Constrained
(Target_Type
)
3135 and then Present
(Stored_Constraint
(Target_Type
))
3137 -- An unconstrained derived type may have inherited discriminant.
3138 -- Build an actual discriminant constraint list using the stored
3139 -- constraint, to verify that the expression of the parent type
3140 -- satisfies the constraints imposed by the (unconstrained!)
3141 -- derived type. This applies to value conversions, not to view
3142 -- conversions of tagged types.
3145 Loc
: constant Source_Ptr
:= Sloc
(N
);
3147 Constraint
: Elmt_Id
;
3148 Discr_Value
: Node_Id
;
3151 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
3152 Old_Constraints
: constant Elist_Id
:=
3153 Discriminant_Constraint
(Expr_Type
);
3156 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
3157 while Present
(Constraint
) loop
3158 Discr_Value
:= Node
(Constraint
);
3160 if Is_Entity_Name
(Discr_Value
)
3161 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
3163 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
3166 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
3168 -- Parent is constrained by new discriminant. Obtain
3169 -- Value of original discriminant in expression. If the
3170 -- new discriminant has been used to constrain more than
3171 -- one of the stored discriminants, this will provide the
3172 -- required consistency check.
3175 (Make_Selected_Component
(Loc
,
3177 Duplicate_Subexpr_No_Checks
3178 (Expr
, Name_Req
=> True),
3180 Make_Identifier
(Loc
, Chars
(Discr
))),
3184 -- Discriminant of more remote ancestor ???
3189 -- Derived type definition has an explicit value for this
3190 -- stored discriminant.
3194 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
3198 Next_Elmt
(Constraint
);
3201 -- Use the unconstrained expression type to retrieve the
3202 -- discriminants of the parent, and apply momentarily the
3203 -- discriminant constraint synthesized above.
3205 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
3206 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
3207 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
3210 Make_Raise_Constraint_Error
(Loc
,
3212 Reason
=> CE_Discriminant_Check_Failed
));
3215 -- For arrays, conversions are applied during expansion, to take into
3216 -- accounts changes of representation. The checks become range checks on
3217 -- the base type or length checks on the subtype, depending on whether
3218 -- the target type is unconstrained or constrained.
3223 end Apply_Type_Conversion_Checks
;
3225 ----------------------------------------------
3226 -- Apply_Universal_Integer_Attribute_Checks --
3227 ----------------------------------------------
3229 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
3230 Loc
: constant Source_Ptr
:= Sloc
(N
);
3231 Typ
: constant Entity_Id
:= Etype
(N
);
3234 if Inside_A_Generic
then
3237 -- Nothing to do if checks are suppressed
3239 elsif Range_Checks_Suppressed
(Typ
)
3240 and then Overflow_Checks_Suppressed
(Typ
)
3244 -- Nothing to do if the attribute does not come from source. The
3245 -- internal attributes we generate of this type do not need checks,
3246 -- and furthermore the attempt to check them causes some circular
3247 -- elaboration orders when dealing with packed types.
3249 elsif not Comes_From_Source
(N
) then
3252 -- If the prefix is a selected component that depends on a discriminant
3253 -- the check may improperly expose a discriminant instead of using
3254 -- the bounds of the object itself. Set the type of the attribute to
3255 -- the base type of the context, so that a check will be imposed when
3256 -- needed (e.g. if the node appears as an index).
3258 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
3259 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
3260 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
3262 Set_Etype
(N
, Base_Type
(Typ
));
3264 -- Otherwise, replace the attribute node with a type conversion node
3265 -- whose expression is the attribute, retyped to universal integer, and
3266 -- whose subtype mark is the target type. The call to analyze this
3267 -- conversion will set range and overflow checks as required for proper
3268 -- detection of an out of range value.
3271 Set_Etype
(N
, Universal_Integer
);
3272 Set_Analyzed
(N
, True);
3275 Make_Type_Conversion
(Loc
,
3276 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
3277 Expression
=> Relocate_Node
(N
)));
3279 Analyze_And_Resolve
(N
, Typ
);
3282 end Apply_Universal_Integer_Attribute_Checks
;
3284 -------------------------------------
3285 -- Atomic_Synchronization_Disabled --
3286 -------------------------------------
3288 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3289 -- using a bogus check called Atomic_Synchronization. This is to make it
3290 -- more convenient to get exactly the same semantics as [Un]Suppress.
3292 function Atomic_Synchronization_Disabled
(E
: Entity_Id
) return Boolean is
3294 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3295 -- looks enabled, since it is never disabled.
3297 if Debug_Flag_Dot_E
then
3300 -- If debug flag d.d is set then always return True, i.e. all atomic
3301 -- sync looks disabled, since it always tests True.
3303 elsif Debug_Flag_Dot_D
then
3306 -- If entity present, then check result for that entity
3308 elsif Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3309 return Is_Check_Suppressed
(E
, Atomic_Synchronization
);
3311 -- Otherwise result depends on current scope setting
3314 return Scope_Suppress
.Suppress
(Atomic_Synchronization
);
3316 end Atomic_Synchronization_Disabled
;
3318 -------------------------------
3319 -- Build_Discriminant_Checks --
3320 -------------------------------
3322 function Build_Discriminant_Checks
3324 T_Typ
: Entity_Id
) return Node_Id
3326 Loc
: constant Source_Ptr
:= Sloc
(N
);
3329 Disc_Ent
: Entity_Id
;
3333 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
;
3335 ----------------------------------
3336 -- Aggregate_Discriminant_Value --
3337 ----------------------------------
3339 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
is
3343 -- The aggregate has been normalized with named associations. We use
3344 -- the Chars field to locate the discriminant to take into account
3345 -- discriminants in derived types, which carry the same name as those
3348 Assoc
:= First
(Component_Associations
(N
));
3349 while Present
(Assoc
) loop
3350 if Chars
(First
(Choices
(Assoc
))) = Chars
(Disc
) then
3351 return Expression
(Assoc
);
3357 -- Discriminant must have been found in the loop above
3359 raise Program_Error
;
3360 end Aggregate_Discriminant_Val
;
3362 -- Start of processing for Build_Discriminant_Checks
3365 -- Loop through discriminants evolving the condition
3368 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
3370 -- For a fully private type, use the discriminants of the parent type
3372 if Is_Private_Type
(T_Typ
)
3373 and then No
(Full_View
(T_Typ
))
3375 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
3377 Disc_Ent
:= First_Discriminant
(T_Typ
);
3380 while Present
(Disc
) loop
3381 Dval
:= Node
(Disc
);
3383 if Nkind
(Dval
) = N_Identifier
3384 and then Ekind
(Entity
(Dval
)) = E_Discriminant
3386 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
3388 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
3391 -- If we have an Unchecked_Union node, we can infer the discriminants
3394 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
3396 Get_Discriminant_Value
(
3397 First_Discriminant
(T_Typ
),
3399 Stored_Constraint
(T_Typ
)));
3401 elsif Nkind
(N
) = N_Aggregate
then
3403 Duplicate_Subexpr_No_Checks
3404 (Aggregate_Discriminant_Val
(Disc_Ent
));
3408 Make_Selected_Component
(Loc
,
3410 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
3412 Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
3414 Set_Is_In_Discriminant_Check
(Dref
);
3417 Evolve_Or_Else
(Cond
,
3420 Right_Opnd
=> Dval
));
3423 Next_Discriminant
(Disc_Ent
);
3427 end Build_Discriminant_Checks
;
3433 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
3441 -- Always check if not simple entity
3443 if Nkind
(Nod
) not in N_Has_Entity
3444 or else not Comes_From_Source
(Nod
)
3449 -- Look up tree for short circuit
3456 -- Done if out of subexpression (note that we allow generated stuff
3457 -- such as itype declarations in this context, to keep the loop going
3458 -- since we may well have generated such stuff in complex situations.
3459 -- Also done if no parent (probably an error condition, but no point
3460 -- in behaving nasty if we find it!)
3463 or else (K
not in N_Subexpr
and then Comes_From_Source
(P
))
3467 -- Or/Or Else case, where test is part of the right operand, or is
3468 -- part of one of the actions associated with the right operand, and
3469 -- the left operand is an equality test.
3471 elsif K
= N_Op_Or
then
3472 exit when N
= Right_Opnd
(P
)
3473 and then Nkind
(Left_Opnd
(P
)) = N_Op_Eq
;
3475 elsif K
= N_Or_Else
then
3476 exit when (N
= Right_Opnd
(P
)
3479 and then List_Containing
(N
) = Actions
(P
)))
3480 and then Nkind
(Left_Opnd
(P
)) = N_Op_Eq
;
3482 -- Similar test for the And/And then case, where the left operand
3483 -- is an inequality test.
3485 elsif K
= N_Op_And
then
3486 exit when N
= Right_Opnd
(P
)
3487 and then Nkind
(Left_Opnd
(P
)) = N_Op_Ne
;
3489 elsif K
= N_And_Then
then
3490 exit when (N
= Right_Opnd
(P
)
3493 and then List_Containing
(N
) = Actions
(P
)))
3494 and then Nkind
(Left_Opnd
(P
)) = N_Op_Ne
;
3500 -- If we fall through the loop, then we have a conditional with an
3501 -- appropriate test as its left operand. So test further.
3504 R
:= Right_Opnd
(L
);
3507 -- Left operand of test must match original variable
3509 if Nkind
(L
) not in N_Has_Entity
3510 or else Entity
(L
) /= Entity
(Nod
)
3515 -- Right operand of test must be key value (zero or null)
3518 when Access_Check
=>
3519 if not Known_Null
(R
) then
3523 when Division_Check
=>
3524 if not Compile_Time_Known_Value
(R
)
3525 or else Expr_Value
(R
) /= Uint_0
3531 raise Program_Error
;
3534 -- Here we have the optimizable case, warn if not short-circuited
3536 if K
= N_Op_And
or else K
= N_Op_Or
then
3538 when Access_Check
=>
3540 ("Constraint_Error may be raised (access check)?",
3542 when Division_Check
=>
3544 ("Constraint_Error may be raised (zero divide)?",
3548 raise Program_Error
;
3551 if K
= N_Op_And
then
3552 Error_Msg_N
-- CODEFIX
3553 ("use `AND THEN` instead of AND?", P
);
3555 Error_Msg_N
-- CODEFIX
3556 ("use `OR ELSE` instead of OR?", P
);
3559 -- If not short-circuited, we need the check
3563 -- If short-circuited, we can omit the check
3570 -----------------------------------
3571 -- Check_Valid_Lvalue_Subscripts --
3572 -----------------------------------
3574 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
3576 -- Skip this if range checks are suppressed
3578 if Range_Checks_Suppressed
(Etype
(Expr
)) then
3581 -- Only do this check for expressions that come from source. We assume
3582 -- that expander generated assignments explicitly include any necessary
3583 -- checks. Note that this is not just an optimization, it avoids
3584 -- infinite recursions!
3586 elsif not Comes_From_Source
(Expr
) then
3589 -- For a selected component, check the prefix
3591 elsif Nkind
(Expr
) = N_Selected_Component
then
3592 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3595 -- Case of indexed component
3597 elsif Nkind
(Expr
) = N_Indexed_Component
then
3598 Apply_Subscript_Validity_Checks
(Expr
);
3600 -- Prefix may itself be or contain an indexed component, and these
3601 -- subscripts need checking as well.
3603 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3605 end Check_Valid_Lvalue_Subscripts
;
3607 ----------------------------------
3608 -- Null_Exclusion_Static_Checks --
3609 ----------------------------------
3611 procedure Null_Exclusion_Static_Checks
(N
: Node_Id
) is
3612 Error_Node
: Node_Id
;
3614 Has_Null
: constant Boolean := Has_Null_Exclusion
(N
);
3615 K
: constant Node_Kind
:= Nkind
(N
);
3620 (K
= N_Component_Declaration
3621 or else K
= N_Discriminant_Specification
3622 or else K
= N_Function_Specification
3623 or else K
= N_Object_Declaration
3624 or else K
= N_Parameter_Specification
);
3626 if K
= N_Function_Specification
then
3627 Typ
:= Etype
(Defining_Entity
(N
));
3629 Typ
:= Etype
(Defining_Identifier
(N
));
3633 when N_Component_Declaration
=>
3634 if Present
(Access_Definition
(Component_Definition
(N
))) then
3635 Error_Node
:= Component_Definition
(N
);
3637 Error_Node
:= Subtype_Indication
(Component_Definition
(N
));
3640 when N_Discriminant_Specification
=>
3641 Error_Node
:= Discriminant_Type
(N
);
3643 when N_Function_Specification
=>
3644 Error_Node
:= Result_Definition
(N
);
3646 when N_Object_Declaration
=>
3647 Error_Node
:= Object_Definition
(N
);
3649 when N_Parameter_Specification
=>
3650 Error_Node
:= Parameter_Type
(N
);
3653 raise Program_Error
;
3658 -- Enforce legality rule 3.10 (13): A null exclusion can only be
3659 -- applied to an access [sub]type.
3661 if not Is_Access_Type
(Typ
) then
3663 ("`NOT NULL` allowed only for an access type", Error_Node
);
3665 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
3666 -- be applied to a [sub]type that does not exclude null already.
3668 elsif Can_Never_Be_Null
(Typ
)
3669 and then Comes_From_Source
(Typ
)
3672 ("`NOT NULL` not allowed (& already excludes null)",
3677 -- Check that null-excluding objects are always initialized, except for
3678 -- deferred constants, for which the expression will appear in the full
3681 if K
= N_Object_Declaration
3682 and then No
(Expression
(N
))
3683 and then not Constant_Present
(N
)
3684 and then not No_Initialization
(N
)
3686 -- Add an expression that assigns null. This node is needed by
3687 -- Apply_Compile_Time_Constraint_Error, which will replace this with
3688 -- a Constraint_Error node.
3690 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
3691 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
3693 Apply_Compile_Time_Constraint_Error
3694 (N
=> Expression
(N
),
3695 Msg
=> "(Ada 2005) null-excluding objects must be initialized?",
3696 Reason
=> CE_Null_Not_Allowed
);
3699 -- Check that a null-excluding component, formal or object is not being
3700 -- assigned a null value. Otherwise generate a warning message and
3701 -- replace Expression (N) by an N_Constraint_Error node.
3703 if K
/= N_Function_Specification
then
3704 Expr
:= Expression
(N
);
3706 if Present
(Expr
) and then Known_Null
(Expr
) then
3708 when N_Component_Declaration |
3709 N_Discriminant_Specification
=>
3710 Apply_Compile_Time_Constraint_Error
3712 Msg
=> "(Ada 2005) null not allowed " &
3713 "in null-excluding components?",
3714 Reason
=> CE_Null_Not_Allowed
);
3716 when N_Object_Declaration
=>
3717 Apply_Compile_Time_Constraint_Error
3719 Msg
=> "(Ada 2005) null not allowed " &
3720 "in null-excluding objects?",
3721 Reason
=> CE_Null_Not_Allowed
);
3723 when N_Parameter_Specification
=>
3724 Apply_Compile_Time_Constraint_Error
3726 Msg
=> "(Ada 2005) null not allowed " &
3727 "in null-excluding formals?",
3728 Reason
=> CE_Null_Not_Allowed
);
3735 end Null_Exclusion_Static_Checks
;
3737 ----------------------------------
3738 -- Conditional_Statements_Begin --
3739 ----------------------------------
3741 procedure Conditional_Statements_Begin
is
3743 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
3745 -- If stack overflows, kill all checks, that way we know to simply reset
3746 -- the number of saved checks to zero on return. This should never occur
3749 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
3752 -- In the normal case, we just make a new stack entry saving the current
3753 -- number of saved checks for a later restore.
3756 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
3758 if Debug_Flag_CC
then
3759 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
3763 end Conditional_Statements_Begin
;
3765 --------------------------------
3766 -- Conditional_Statements_End --
3767 --------------------------------
3769 procedure Conditional_Statements_End
is
3771 pragma Assert
(Saved_Checks_TOS
> 0);
3773 -- If the saved checks stack overflowed, then we killed all checks, so
3774 -- setting the number of saved checks back to zero is correct. This
3775 -- should never occur in practice.
3777 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
3778 Num_Saved_Checks
:= 0;
3780 -- In the normal case, restore the number of saved checks from the top
3784 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
3785 if Debug_Flag_CC
then
3786 w
("Conditional_Statements_End: Num_Saved_Checks = ",
3791 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
3792 end Conditional_Statements_End
;
3794 -------------------------
3795 -- Convert_From_Bignum --
3796 -------------------------
3798 function Convert_From_Bignum
(N
: Node_Id
) return Node_Id
is
3799 Loc
: constant Source_Ptr
:= Sloc
(N
);
3802 pragma Assert
(Is_RTE
(Etype
(N
), RE_Bignum
));
3804 -- Construct call From Bignum
3807 Make_Function_Call
(Loc
,
3809 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3810 Parameter_Associations
=> New_List
(Relocate_Node
(N
)));
3811 end Convert_From_Bignum
;
3813 -----------------------
3814 -- Convert_To_Bignum --
3815 -----------------------
3817 function Convert_To_Bignum
(N
: Node_Id
) return Node_Id
is
3818 Loc
: constant Source_Ptr
:= Sloc
(N
);
3821 -- Nothing to do if Bignum already except call Relocate_Node
3823 if Is_RTE
(Etype
(N
), RE_Bignum
) then
3824 return Relocate_Node
(N
);
3826 -- Otherwise construct call to To_Bignum, converting the operand to the
3827 -- required Long_Long_Integer form.
3830 pragma Assert
(Is_Signed_Integer_Type
(Etype
(N
)));
3832 Make_Function_Call
(Loc
,
3834 New_Occurrence_Of
(RTE
(RE_To_Bignum
), Loc
),
3835 Parameter_Associations
=> New_List
(
3836 Convert_To
(Standard_Long_Long_Integer
, Relocate_Node
(N
))));
3838 end Convert_To_Bignum
;
3840 ---------------------
3841 -- Determine_Range --
3842 ---------------------
3844 Cache_Size
: constant := 2 ** 10;
3845 type Cache_Index
is range 0 .. Cache_Size
- 1;
3846 -- Determine size of below cache (power of 2 is more efficient!)
3848 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
3849 Determine_Range_Cache_V
: array (Cache_Index
) of Boolean;
3850 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
3851 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
3852 -- The above arrays are used to implement a small direct cache for
3853 -- Determine_Range calls. Because of the way Determine_Range recursively
3854 -- traces subexpressions, and because overflow checking calls the routine
3855 -- on the way up the tree, a quadratic behavior can otherwise be
3856 -- encountered in large expressions. The cache entry for node N is stored
3857 -- in the (N mod Cache_Size) entry, and can be validated by checking the
3858 -- actual node value stored there. The Range_Cache_V array records the
3859 -- setting of Assume_Valid for the cache entry.
3861 procedure Determine_Range
3866 Assume_Valid
: Boolean := False)
3868 Typ
: Entity_Id
:= Etype
(N
);
3869 -- Type to use, may get reset to base type for possibly invalid entity
3873 -- Lo and Hi bounds of left operand
3877 -- Lo and Hi bounds of right (or only) operand
3880 -- Temp variable used to hold a bound node
3883 -- High bound of base type of expression
3887 -- Refined values for low and high bounds, after tightening
3890 -- Used in lower level calls to indicate if call succeeded
3892 Cindex
: Cache_Index
;
3893 -- Used to search cache
3898 function OK_Operands
return Boolean;
3899 -- Used for binary operators. Determines the ranges of the left and
3900 -- right operands, and if they are both OK, returns True, and puts
3901 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
3907 function OK_Operands
return Boolean is
3910 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
3917 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
3921 -- Start of processing for Determine_Range
3924 -- For temporary constants internally generated to remove side effects
3925 -- we must use the corresponding expression to determine the range of
3928 if Is_Entity_Name
(N
)
3929 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3930 and then Ekind
(Entity
(N
)) = E_Constant
3931 and then Is_Internal_Name
(Chars
(Entity
(N
)))
3934 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
3938 -- Prevent junk warnings by initializing range variables
3945 -- If type is not defined, we can't determine its range
3949 -- We don't deal with anything except discrete types
3951 or else not Is_Discrete_Type
(Typ
)
3953 -- Ignore type for which an error has been posted, since range in
3954 -- this case may well be a bogosity deriving from the error. Also
3955 -- ignore if error posted on the reference node.
3957 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
3963 -- For all other cases, we can determine the range
3967 -- If value is compile time known, then the possible range is the one
3968 -- value that we know this expression definitely has!
3970 if Compile_Time_Known_Value
(N
) then
3971 Lo
:= Expr_Value
(N
);
3976 -- Return if already in the cache
3978 Cindex
:= Cache_Index
(N
mod Cache_Size
);
3980 if Determine_Range_Cache_N
(Cindex
) = N
3982 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
3984 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
3985 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
3989 -- Otherwise, start by finding the bounds of the type of the expression,
3990 -- the value cannot be outside this range (if it is, then we have an
3991 -- overflow situation, which is a separate check, we are talking here
3992 -- only about the expression value).
3994 -- First a check, never try to find the bounds of a generic type, since
3995 -- these bounds are always junk values, and it is only valid to look at
3996 -- the bounds in an instance.
3998 if Is_Generic_Type
(Typ
) then
4003 -- First step, change to use base type unless we know the value is valid
4005 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
4006 or else Assume_No_Invalid_Values
4007 or else Assume_Valid
4011 Typ
:= Underlying_Type
(Base_Type
(Typ
));
4014 -- Retrieve the base type. Handle the case where the base type is a
4015 -- private enumeration type.
4017 Btyp
:= Base_Type
(Typ
);
4019 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
4020 Btyp
:= Full_View
(Btyp
);
4023 -- We use the actual bound unless it is dynamic, in which case use the
4024 -- corresponding base type bound if possible. If we can't get a bound
4025 -- then we figure we can't determine the range (a peculiar case, that
4026 -- perhaps cannot happen, but there is no point in bombing in this
4027 -- optimization circuit.
4029 -- First the low bound
4031 Bound
:= Type_Low_Bound
(Typ
);
4033 if Compile_Time_Known_Value
(Bound
) then
4034 Lo
:= Expr_Value
(Bound
);
4036 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
4037 Lo
:= Expr_Value
(Type_Low_Bound
(Btyp
));
4044 -- Now the high bound
4046 Bound
:= Type_High_Bound
(Typ
);
4048 -- We need the high bound of the base type later on, and this should
4049 -- always be compile time known. Again, it is not clear that this
4050 -- can ever be false, but no point in bombing.
4052 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
4053 Hbound
:= Expr_Value
(Type_High_Bound
(Btyp
));
4061 -- If we have a static subtype, then that may have a tighter bound so
4062 -- use the upper bound of the subtype instead in this case.
4064 if Compile_Time_Known_Value
(Bound
) then
4065 Hi
:= Expr_Value
(Bound
);
4068 -- We may be able to refine this value in certain situations. If any
4069 -- refinement is possible, then Lor and Hir are set to possibly tighter
4070 -- bounds, and OK1 is set to True.
4074 -- For unary plus, result is limited by range of operand
4078 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4080 -- For unary minus, determine range of operand, and negate it
4084 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4091 -- For binary addition, get range of each operand and do the
4092 -- addition to get the result range.
4096 Lor
:= Lo_Left
+ Lo_Right
;
4097 Hir
:= Hi_Left
+ Hi_Right
;
4100 -- Division is tricky. The only case we consider is where the right
4101 -- operand is a positive constant, and in this case we simply divide
4102 -- the bounds of the left operand
4106 if Lo_Right
= Hi_Right
4107 and then Lo_Right
> 0
4109 Lor
:= Lo_Left
/ Lo_Right
;
4110 Hir
:= Hi_Left
/ Lo_Right
;
4117 -- For binary subtraction, get range of each operand and do the worst
4118 -- case subtraction to get the result range.
4120 when N_Op_Subtract
=>
4122 Lor
:= Lo_Left
- Hi_Right
;
4123 Hir
:= Hi_Left
- Lo_Right
;
4126 -- For MOD, if right operand is a positive constant, then result must
4127 -- be in the allowable range of mod results.
4131 if Lo_Right
= Hi_Right
4132 and then Lo_Right
/= 0
4134 if Lo_Right
> 0 then
4136 Hir
:= Lo_Right
- 1;
4138 else -- Lo_Right < 0
4139 Lor
:= Lo_Right
+ 1;
4148 -- For REM, if right operand is a positive constant, then result must
4149 -- be in the allowable range of mod results.
4153 if Lo_Right
= Hi_Right
4154 and then Lo_Right
/= 0
4157 Dval
: constant Uint
:= (abs Lo_Right
) - 1;
4160 -- The sign of the result depends on the sign of the
4161 -- dividend (but not on the sign of the divisor, hence
4162 -- the abs operation above).
4182 -- Attribute reference cases
4184 when N_Attribute_Reference
=>
4185 case Attribute_Name
(N
) is
4187 -- For Pos/Val attributes, we can refine the range using the
4188 -- possible range of values of the attribute expression.
4190 when Name_Pos | Name_Val
=>
4192 (First
(Expressions
(N
)), OK1
, Lor
, Hir
, Assume_Valid
);
4194 -- For Length attribute, use the bounds of the corresponding
4195 -- index type to refine the range.
4199 Atyp
: Entity_Id
:= Etype
(Prefix
(N
));
4207 if Is_Access_Type
(Atyp
) then
4208 Atyp
:= Designated_Type
(Atyp
);
4211 -- For string literal, we know exact value
4213 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
4215 Lo
:= String_Literal_Length
(Atyp
);
4216 Hi
:= String_Literal_Length
(Atyp
);
4220 -- Otherwise check for expression given
4222 if No
(Expressions
(N
)) then
4226 UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
4229 Indx
:= First_Index
(Atyp
);
4230 for J
in 2 .. Inum
loop
4231 Indx
:= Next_Index
(Indx
);
4234 -- If the index type is a formal type or derived from
4235 -- one, the bounds are not static.
4237 if Is_Generic_Type
(Root_Type
(Etype
(Indx
))) then
4243 (Type_Low_Bound
(Etype
(Indx
)), OK1
, LL
, LU
,
4248 (Type_High_Bound
(Etype
(Indx
)), OK1
, UL
, UU
,
4253 -- The maximum value for Length is the biggest
4254 -- possible gap between the values of the bounds.
4255 -- But of course, this value cannot be negative.
4257 Hir
:= UI_Max
(Uint_0
, UU
- LL
+ 1);
4259 -- For constrained arrays, the minimum value for
4260 -- Length is taken from the actual value of the
4261 -- bounds, since the index will be exactly of this
4264 if Is_Constrained
(Atyp
) then
4265 Lor
:= UI_Max
(Uint_0
, UL
- LU
+ 1);
4267 -- For an unconstrained array, the minimum value
4268 -- for length is always zero.
4277 -- No special handling for other attributes
4278 -- Probably more opportunities exist here???
4285 -- For type conversion from one discrete type to another, we can
4286 -- refine the range using the converted value.
4288 when N_Type_Conversion
=>
4289 Determine_Range
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4291 -- Nothing special to do for all other expression kinds
4299 -- At this stage, if OK1 is true, then we know that the actual result of
4300 -- the computed expression is in the range Lor .. Hir. We can use this
4301 -- to restrict the possible range of results.
4305 -- If the refined value of the low bound is greater than the type
4306 -- high bound, then reset it to the more restrictive value. However,
4307 -- we do NOT do this for the case of a modular type where the
4308 -- possible upper bound on the value is above the base type high
4309 -- bound, because that means the result could wrap.
4312 and then not (Is_Modular_Integer_Type
(Typ
) and then Hir
> Hbound
)
4317 -- Similarly, if the refined value of the high bound is less than the
4318 -- value so far, then reset it to the more restrictive value. Again,
4319 -- we do not do this if the refined low bound is negative for a
4320 -- modular type, since this would wrap.
4323 and then not (Is_Modular_Integer_Type
(Typ
) and then Lor
< Uint_0
)
4329 -- Set cache entry for future call and we are all done
4331 Determine_Range_Cache_N
(Cindex
) := N
;
4332 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
4333 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
4334 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
4337 -- If any exception occurs, it means that we have some bug in the compiler,
4338 -- possibly triggered by a previous error, or by some unforeseen peculiar
4339 -- occurrence. However, this is only an optimization attempt, so there is
4340 -- really no point in crashing the compiler. Instead we just decide, too
4341 -- bad, we can't figure out a range in this case after all.
4346 -- Debug flag K disables this behavior (useful for debugging)
4348 if Debug_Flag_K
then
4356 end Determine_Range
;
4358 ------------------------------------
4359 -- Discriminant_Checks_Suppressed --
4360 ------------------------------------
4362 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4365 if Is_Unchecked_Union
(E
) then
4367 elsif Checks_May_Be_Suppressed
(E
) then
4368 return Is_Check_Suppressed
(E
, Discriminant_Check
);
4372 return Scope_Suppress
.Suppress
(Discriminant_Check
);
4373 end Discriminant_Checks_Suppressed
;
4375 --------------------------------
4376 -- Division_Checks_Suppressed --
4377 --------------------------------
4379 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4381 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4382 return Is_Check_Suppressed
(E
, Division_Check
);
4384 return Scope_Suppress
.Suppress
(Division_Check
);
4386 end Division_Checks_Suppressed
;
4388 -----------------------------------
4389 -- Elaboration_Checks_Suppressed --
4390 -----------------------------------
4392 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4394 -- The complication in this routine is that if we are in the dynamic
4395 -- model of elaboration, we also check All_Checks, since All_Checks
4396 -- does not set Elaboration_Check explicitly.
4399 if Kill_Elaboration_Checks
(E
) then
4402 elsif Checks_May_Be_Suppressed
(E
) then
4403 if Is_Check_Suppressed
(E
, Elaboration_Check
) then
4405 elsif Dynamic_Elaboration_Checks
then
4406 return Is_Check_Suppressed
(E
, All_Checks
);
4413 if Scope_Suppress
.Suppress
(Elaboration_Check
) then
4415 elsif Dynamic_Elaboration_Checks
then
4416 return Scope_Suppress
.Suppress
(All_Checks
);
4420 end Elaboration_Checks_Suppressed
;
4422 ---------------------------
4423 -- Enable_Overflow_Check --
4424 ---------------------------
4426 procedure Enable_Overflow_Check
(N
: Node_Id
) is
4427 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
4428 Mode
: constant Overflow_Check_Type
:= Overflow_Check_Mode
;
4437 if Debug_Flag_CC
then
4438 w
("Enable_Overflow_Check for node ", Int
(N
));
4439 Write_Str
(" Source location = ");
4444 -- No check if overflow checks suppressed for type of node
4446 if Overflow_Checks_Suppressed
(Etype
(N
)) then
4449 -- Nothing to do for unsigned integer types, which do not overflow
4451 elsif Is_Modular_Integer_Type
(Typ
) then
4455 -- This is the point at which processing for STRICT mode diverges
4456 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
4457 -- probably more extreme that it needs to be, but what is going on here
4458 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
4459 -- to leave the processing for STRICT mode untouched. There were
4460 -- two reasons for this. First it avoided any incompatible change of
4461 -- behavior. Second, it guaranteed that STRICT mode continued to be
4464 -- The big difference is that in STRICT mode there is a fair amount of
4465 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
4466 -- know that no check is needed. We skip all that in the two new modes,
4467 -- since really overflow checking happens over a whole subtree, and we
4468 -- do the corresponding optimizations later on when applying the checks.
4470 if Mode
in Minimized_Or_Eliminated
then
4471 if not (Overflow_Checks_Suppressed
(Etype
(N
)))
4472 and then not (Is_Entity_Name
(N
)
4473 and then Overflow_Checks_Suppressed
(Entity
(N
)))
4475 Activate_Overflow_Check
(N
);
4478 if Debug_Flag_CC
then
4479 w
("Minimized/Eliminated mode");
4485 -- Remainder of processing is for STRICT case, and is unchanged from
4486 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
4488 -- Nothing to do if the range of the result is known OK. We skip this
4489 -- for conversions, since the caller already did the check, and in any
4490 -- case the condition for deleting the check for a type conversion is
4493 if Nkind
(N
) /= N_Type_Conversion
then
4494 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
4496 -- Note in the test below that we assume that the range is not OK
4497 -- if a bound of the range is equal to that of the type. That's not
4498 -- quite accurate but we do this for the following reasons:
4500 -- a) The way that Determine_Range works, it will typically report
4501 -- the bounds of the value as being equal to the bounds of the
4502 -- type, because it either can't tell anything more precise, or
4503 -- does not think it is worth the effort to be more precise.
4505 -- b) It is very unusual to have a situation in which this would
4506 -- generate an unnecessary overflow check (an example would be
4507 -- a subtype with a range 0 .. Integer'Last - 1 to which the
4508 -- literal value one is added).
4510 -- c) The alternative is a lot of special casing in this routine
4511 -- which would partially duplicate Determine_Range processing.
4514 and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
4515 and then Hi
< Expr_Value
(Type_High_Bound
(Typ
))
4517 if Debug_Flag_CC
then
4518 w
("No overflow check required");
4525 -- If not in optimizing mode, set flag and we are done. We are also done
4526 -- (and just set the flag) if the type is not a discrete type, since it
4527 -- is not worth the effort to eliminate checks for other than discrete
4528 -- types. In addition, we take this same path if we have stored the
4529 -- maximum number of checks possible already (a very unlikely situation,
4530 -- but we do not want to blow up!)
4532 if Optimization_Level
= 0
4533 or else not Is_Discrete_Type
(Etype
(N
))
4534 or else Num_Saved_Checks
= Saved_Checks
'Last
4536 Activate_Overflow_Check
(N
);
4538 if Debug_Flag_CC
then
4539 w
("Optimization off");
4545 -- Otherwise evaluate and check the expression
4550 Target_Type
=> Empty
,
4556 if Debug_Flag_CC
then
4557 w
("Called Find_Check");
4561 w
(" Check_Num = ", Chk
);
4562 w
(" Ent = ", Int
(Ent
));
4563 Write_Str
(" Ofs = ");
4568 -- If check is not of form to optimize, then set flag and we are done
4571 Activate_Overflow_Check
(N
);
4575 -- If check is already performed, then return without setting flag
4578 if Debug_Flag_CC
then
4579 w
("Check suppressed!");
4585 -- Here we will make a new entry for the new check
4587 Activate_Overflow_Check
(N
);
4588 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
4589 Saved_Checks
(Num_Saved_Checks
) :=
4594 Target_Type
=> Empty
);
4596 if Debug_Flag_CC
then
4597 w
("Make new entry, check number = ", Num_Saved_Checks
);
4598 w
(" Entity = ", Int
(Ent
));
4599 Write_Str
(" Offset = ");
4601 w
(" Check_Type = O");
4602 w
(" Target_Type = Empty");
4605 -- If we get an exception, then something went wrong, probably because of
4606 -- an error in the structure of the tree due to an incorrect program. Or it
4607 -- may be a bug in the optimization circuit. In either case the safest
4608 -- thing is simply to set the check flag unconditionally.
4612 Activate_Overflow_Check
(N
);
4614 if Debug_Flag_CC
then
4615 w
(" exception occurred, overflow flag set");
4619 end Enable_Overflow_Check
;
4621 ------------------------
4622 -- Enable_Range_Check --
4623 ------------------------
4625 procedure Enable_Range_Check
(N
: Node_Id
) is
4634 -- Return if unchecked type conversion with range check killed. In this
4635 -- case we never set the flag (that's what Kill_Range_Check is about!)
4637 if Nkind
(N
) = N_Unchecked_Type_Conversion
4638 and then Kill_Range_Check
(N
)
4643 -- Do not set range check flag if parent is assignment statement or
4644 -- object declaration with Suppress_Assignment_Checks flag set
4646 if Nkind_In
(Parent
(N
), N_Assignment_Statement
, N_Object_Declaration
)
4647 and then Suppress_Assignment_Checks
(Parent
(N
))
4652 -- Check for various cases where we should suppress the range check
4654 -- No check if range checks suppressed for type of node
4656 if Present
(Etype
(N
))
4657 and then Range_Checks_Suppressed
(Etype
(N
))
4661 -- No check if node is an entity name, and range checks are suppressed
4662 -- for this entity, or for the type of this entity.
4664 elsif Is_Entity_Name
(N
)
4665 and then (Range_Checks_Suppressed
(Entity
(N
))
4666 or else Range_Checks_Suppressed
(Etype
(Entity
(N
))))
4670 -- No checks if index of array, and index checks are suppressed for
4671 -- the array object or the type of the array.
4673 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
then
4675 Pref
: constant Node_Id
:= Prefix
(Parent
(N
));
4677 if Is_Entity_Name
(Pref
)
4678 and then Index_Checks_Suppressed
(Entity
(Pref
))
4681 elsif Index_Checks_Suppressed
(Etype
(Pref
)) then
4687 -- Debug trace output
4689 if Debug_Flag_CC
then
4690 w
("Enable_Range_Check for node ", Int
(N
));
4691 Write_Str
(" Source location = ");
4696 -- If not in optimizing mode, set flag and we are done. We are also done
4697 -- (and just set the flag) if the type is not a discrete type, since it
4698 -- is not worth the effort to eliminate checks for other than discrete
4699 -- types. In addition, we take this same path if we have stored the
4700 -- maximum number of checks possible already (a very unlikely situation,
4701 -- but we do not want to blow up!)
4703 if Optimization_Level
= 0
4704 or else No
(Etype
(N
))
4705 or else not Is_Discrete_Type
(Etype
(N
))
4706 or else Num_Saved_Checks
= Saved_Checks
'Last
4708 Activate_Range_Check
(N
);
4710 if Debug_Flag_CC
then
4711 w
("Optimization off");
4717 -- Otherwise find out the target type
4721 -- For assignment, use left side subtype
4723 if Nkind
(P
) = N_Assignment_Statement
4724 and then Expression
(P
) = N
4726 Ttyp
:= Etype
(Name
(P
));
4728 -- For indexed component, use subscript subtype
4730 elsif Nkind
(P
) = N_Indexed_Component
then
4737 Atyp
:= Etype
(Prefix
(P
));
4739 if Is_Access_Type
(Atyp
) then
4740 Atyp
:= Designated_Type
(Atyp
);
4742 -- If the prefix is an access to an unconstrained array,
4743 -- perform check unconditionally: it depends on the bounds of
4744 -- an object and we cannot currently recognize whether the test
4745 -- may be redundant.
4747 if not Is_Constrained
(Atyp
) then
4748 Activate_Range_Check
(N
);
4752 -- Ditto if the prefix is an explicit dereference whose designated
4753 -- type is unconstrained.
4755 elsif Nkind
(Prefix
(P
)) = N_Explicit_Dereference
4756 and then not Is_Constrained
(Atyp
)
4758 Activate_Range_Check
(N
);
4762 Indx
:= First_Index
(Atyp
);
4763 Subs
:= First
(Expressions
(P
));
4766 Ttyp
:= Etype
(Indx
);
4775 -- For now, ignore all other cases, they are not so interesting
4778 if Debug_Flag_CC
then
4779 w
(" target type not found, flag set");
4782 Activate_Range_Check
(N
);
4786 -- Evaluate and check the expression
4791 Target_Type
=> Ttyp
,
4797 if Debug_Flag_CC
then
4798 w
("Called Find_Check");
4799 w
("Target_Typ = ", Int
(Ttyp
));
4803 w
(" Check_Num = ", Chk
);
4804 w
(" Ent = ", Int
(Ent
));
4805 Write_Str
(" Ofs = ");
4810 -- If check is not of form to optimize, then set flag and we are done
4813 if Debug_Flag_CC
then
4814 w
(" expression not of optimizable type, flag set");
4817 Activate_Range_Check
(N
);
4821 -- If check is already performed, then return without setting flag
4824 if Debug_Flag_CC
then
4825 w
("Check suppressed!");
4831 -- Here we will make a new entry for the new check
4833 Activate_Range_Check
(N
);
4834 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
4835 Saved_Checks
(Num_Saved_Checks
) :=
4840 Target_Type
=> Ttyp
);
4842 if Debug_Flag_CC
then
4843 w
("Make new entry, check number = ", Num_Saved_Checks
);
4844 w
(" Entity = ", Int
(Ent
));
4845 Write_Str
(" Offset = ");
4847 w
(" Check_Type = R");
4848 w
(" Target_Type = ", Int
(Ttyp
));
4849 pg
(Union_Id
(Ttyp
));
4852 -- If we get an exception, then something went wrong, probably because of
4853 -- an error in the structure of the tree due to an incorrect program. Or
4854 -- it may be a bug in the optimization circuit. In either case the safest
4855 -- thing is simply to set the check flag unconditionally.
4859 Activate_Range_Check
(N
);
4861 if Debug_Flag_CC
then
4862 w
(" exception occurred, range flag set");
4866 end Enable_Range_Check
;
4872 procedure Ensure_Valid
(Expr
: Node_Id
; Holes_OK
: Boolean := False) is
4873 Typ
: constant Entity_Id
:= Etype
(Expr
);
4876 -- Ignore call if we are not doing any validity checking
4878 if not Validity_Checks_On
then
4881 -- Ignore call if range or validity checks suppressed on entity or type
4883 elsif Range_Or_Validity_Checks_Suppressed
(Expr
) then
4886 -- No check required if expression is from the expander, we assume the
4887 -- expander will generate whatever checks are needed. Note that this is
4888 -- not just an optimization, it avoids infinite recursions!
4890 -- Unchecked conversions must be checked, unless they are initialized
4891 -- scalar values, as in a component assignment in an init proc.
4893 -- In addition, we force a check if Force_Validity_Checks is set
4895 elsif not Comes_From_Source
(Expr
)
4896 and then not Force_Validity_Checks
4897 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
4898 or else Kill_Range_Check
(Expr
))
4902 -- No check required if expression is known to have valid value
4904 elsif Expr_Known_Valid
(Expr
) then
4907 -- Ignore case of enumeration with holes where the flag is set not to
4908 -- worry about holes, since no special validity check is needed
4910 elsif Is_Enumeration_Type
(Typ
)
4911 and then Has_Non_Standard_Rep
(Typ
)
4916 -- No check required on the left-hand side of an assignment
4918 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
4919 and then Expr
= Name
(Parent
(Expr
))
4923 -- No check on a universal real constant. The context will eventually
4924 -- convert it to a machine number for some target type, or report an
4927 elsif Nkind
(Expr
) = N_Real_Literal
4928 and then Etype
(Expr
) = Universal_Real
4932 -- If the expression denotes a component of a packed boolean array,
4933 -- no possible check applies. We ignore the old ACATS chestnuts that
4934 -- involve Boolean range True..True.
4936 -- Note: validity checks are generated for expressions that yield a
4937 -- scalar type, when it is possible to create a value that is outside of
4938 -- the type. If this is a one-bit boolean no such value exists. This is
4939 -- an optimization, and it also prevents compiler blowing up during the
4940 -- elaboration of improperly expanded packed array references.
4942 elsif Nkind
(Expr
) = N_Indexed_Component
4943 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Expr
)))
4944 and then Root_Type
(Etype
(Expr
)) = Standard_Boolean
4948 -- An annoying special case. If this is an out parameter of a scalar
4949 -- type, then the value is not going to be accessed, therefore it is
4950 -- inappropriate to do any validity check at the call site.
4953 -- Only need to worry about scalar types
4955 if Is_Scalar_Type
(Typ
) then
4965 -- Find actual argument (which may be a parameter association)
4966 -- and the parent of the actual argument (the call statement)
4971 if Nkind
(P
) = N_Parameter_Association
then
4976 -- Only need to worry if we are argument of a procedure call
4977 -- since functions don't have out parameters. If this is an
4978 -- indirect or dispatching call, get signature from the
4981 if Nkind
(P
) = N_Procedure_Call_Statement
then
4982 L
:= Parameter_Associations
(P
);
4984 if Is_Entity_Name
(Name
(P
)) then
4985 E
:= Entity
(Name
(P
));
4987 pragma Assert
(Nkind
(Name
(P
)) = N_Explicit_Dereference
);
4988 E
:= Etype
(Name
(P
));
4991 -- Only need to worry if there are indeed actuals, and if
4992 -- this could be a procedure call, otherwise we cannot get a
4993 -- match (either we are not an argument, or the mode of the
4994 -- formal is not OUT). This test also filters out the
4997 if Is_Non_Empty_List
(L
)
4998 and then Is_Subprogram
(E
)
5000 -- This is the loop through parameters, looking for an
5001 -- OUT parameter for which we are the argument.
5003 F
:= First_Formal
(E
);
5005 while Present
(F
) loop
5006 if Ekind
(F
) = E_Out_Parameter
and then A
= N
then
5019 -- If this is a boolean expression, only its elementary operands need
5020 -- checking: if they are valid, a boolean or short-circuit operation
5021 -- with them will be valid as well.
5023 if Base_Type
(Typ
) = Standard_Boolean
5025 (Nkind
(Expr
) in N_Op
or else Nkind
(Expr
) in N_Short_Circuit
)
5030 -- If we fall through, a validity check is required
5032 Insert_Valid_Check
(Expr
);
5034 if Is_Entity_Name
(Expr
)
5035 and then Safe_To_Capture_Value
(Expr
, Entity
(Expr
))
5037 Set_Is_Known_Valid
(Entity
(Expr
));
5041 ----------------------
5042 -- Expr_Known_Valid --
5043 ----------------------
5045 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
5046 Typ
: constant Entity_Id
:= Etype
(Expr
);
5049 -- Non-scalar types are always considered valid, since they never give
5050 -- rise to the issues of erroneous or bounded error behavior that are
5051 -- the concern. In formal reference manual terms the notion of validity
5052 -- only applies to scalar types. Note that even when packed arrays are
5053 -- represented using modular types, they are still arrays semantically,
5054 -- so they are also always valid (in particular, the unused bits can be
5055 -- random rubbish without affecting the validity of the array value).
5057 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Type
(Typ
) then
5060 -- If no validity checking, then everything is considered valid
5062 elsif not Validity_Checks_On
then
5065 -- Floating-point types are considered valid unless floating-point
5066 -- validity checks have been specifically turned on.
5068 elsif Is_Floating_Point_Type
(Typ
)
5069 and then not Validity_Check_Floating_Point
5073 -- If the expression is the value of an object that is known to be
5074 -- valid, then clearly the expression value itself is valid.
5076 elsif Is_Entity_Name
(Expr
)
5077 and then Is_Known_Valid
(Entity
(Expr
))
5081 -- References to discriminants are always considered valid. The value
5082 -- of a discriminant gets checked when the object is built. Within the
5083 -- record, we consider it valid, and it is important to do so, since
5084 -- otherwise we can try to generate bogus validity checks which
5085 -- reference discriminants out of scope. Discriminants of concurrent
5086 -- types are excluded for the same reason.
5088 elsif Is_Entity_Name
(Expr
)
5089 and then Denotes_Discriminant
(Expr
, Check_Concurrent
=> True)
5093 -- If the type is one for which all values are known valid, then we are
5094 -- sure that the value is valid except in the slightly odd case where
5095 -- the expression is a reference to a variable whose size has been
5096 -- explicitly set to a value greater than the object size.
5098 elsif Is_Known_Valid
(Typ
) then
5099 if Is_Entity_Name
(Expr
)
5100 and then Ekind
(Entity
(Expr
)) = E_Variable
5101 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
5108 -- Integer and character literals always have valid values, where
5109 -- appropriate these will be range checked in any case.
5111 elsif Nkind
(Expr
) = N_Integer_Literal
5113 Nkind
(Expr
) = N_Character_Literal
5117 -- Real literals are assumed to be valid in VM targets
5119 elsif VM_Target
/= No_VM
5120 and then Nkind
(Expr
) = N_Real_Literal
5124 -- If we have a type conversion or a qualification of a known valid
5125 -- value, then the result will always be valid.
5127 elsif Nkind
(Expr
) = N_Type_Conversion
5129 Nkind
(Expr
) = N_Qualified_Expression
5131 return Expr_Known_Valid
(Expression
(Expr
));
5133 -- The result of any operator is always considered valid, since we
5134 -- assume the necessary checks are done by the operator. For operators
5135 -- on floating-point operations, we must also check when the operation
5136 -- is the right-hand side of an assignment, or is an actual in a call.
5138 elsif Nkind
(Expr
) in N_Op
then
5139 if Is_Floating_Point_Type
(Typ
)
5140 and then Validity_Check_Floating_Point
5142 (Nkind
(Parent
(Expr
)) = N_Assignment_Statement
5143 or else Nkind
(Parent
(Expr
)) = N_Function_Call
5144 or else Nkind
(Parent
(Expr
)) = N_Parameter_Association
)
5151 -- The result of a membership test is always valid, since it is true or
5152 -- false, there are no other possibilities.
5154 elsif Nkind
(Expr
) in N_Membership_Test
then
5157 -- For all other cases, we do not know the expression is valid
5162 end Expr_Known_Valid
;
5168 procedure Find_Check
5170 Check_Type
: Character;
5171 Target_Type
: Entity_Id
;
5172 Entry_OK
: out Boolean;
5173 Check_Num
: out Nat
;
5174 Ent
: out Entity_Id
;
5177 function Within_Range_Of
5178 (Target_Type
: Entity_Id
;
5179 Check_Type
: Entity_Id
) return Boolean;
5180 -- Given a requirement for checking a range against Target_Type, and
5181 -- and a range Check_Type against which a check has already been made,
5182 -- determines if the check against check type is sufficient to ensure
5183 -- that no check against Target_Type is required.
5185 ---------------------
5186 -- Within_Range_Of --
5187 ---------------------
5189 function Within_Range_Of
5190 (Target_Type
: Entity_Id
;
5191 Check_Type
: Entity_Id
) return Boolean
5194 if Target_Type
= Check_Type
then
5199 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
5200 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
5201 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
5202 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
5206 or else (Compile_Time_Known_Value
(Tlo
)
5208 Compile_Time_Known_Value
(Clo
)
5210 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
5213 or else (Compile_Time_Known_Value
(Thi
)
5215 Compile_Time_Known_Value
(Chi
)
5217 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
5225 end Within_Range_Of
;
5227 -- Start of processing for Find_Check
5230 -- Establish default, in case no entry is found
5234 -- Case of expression is simple entity reference
5236 if Is_Entity_Name
(Expr
) then
5237 Ent
:= Entity
(Expr
);
5240 -- Case of expression is entity + known constant
5242 elsif Nkind
(Expr
) = N_Op_Add
5243 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
5244 and then Is_Entity_Name
(Left_Opnd
(Expr
))
5246 Ent
:= Entity
(Left_Opnd
(Expr
));
5247 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
5249 -- Case of expression is entity - known constant
5251 elsif Nkind
(Expr
) = N_Op_Subtract
5252 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
5253 and then Is_Entity_Name
(Left_Opnd
(Expr
))
5255 Ent
:= Entity
(Left_Opnd
(Expr
));
5256 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
5258 -- Any other expression is not of the right form
5267 -- Come here with expression of appropriate form, check if entity is an
5268 -- appropriate one for our purposes.
5270 if (Ekind
(Ent
) = E_Variable
5271 or else Is_Constant_Object
(Ent
))
5272 and then not Is_Library_Level_Entity
(Ent
)
5280 -- See if there is matching check already
5282 for J
in reverse 1 .. Num_Saved_Checks
loop
5284 SC
: Saved_Check
renames Saved_Checks
(J
);
5287 if SC
.Killed
= False
5288 and then SC
.Entity
= Ent
5289 and then SC
.Offset
= Ofs
5290 and then SC
.Check_Type
= Check_Type
5291 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
5299 -- If we fall through entry was not found
5304 ---------------------------------
5305 -- Generate_Discriminant_Check --
5306 ---------------------------------
5308 -- Note: the code for this procedure is derived from the
5309 -- Emit_Discriminant_Check Routine in trans.c.
5311 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
5312 Loc
: constant Source_Ptr
:= Sloc
(N
);
5313 Pref
: constant Node_Id
:= Prefix
(N
);
5314 Sel
: constant Node_Id
:= Selector_Name
(N
);
5316 Orig_Comp
: constant Entity_Id
:=
5317 Original_Record_Component
(Entity
(Sel
));
5318 -- The original component to be checked
5320 Discr_Fct
: constant Entity_Id
:=
5321 Discriminant_Checking_Func
(Orig_Comp
);
5322 -- The discriminant checking function
5325 -- One discriminant to be checked in the type
5327 Real_Discr
: Entity_Id
;
5328 -- Actual discriminant in the call
5330 Pref_Type
: Entity_Id
;
5331 -- Type of relevant prefix (ignoring private/access stuff)
5334 -- List of arguments for function call
5337 -- Keep track of the formal corresponding to the actual we build for
5338 -- each discriminant, in order to be able to perform the necessary type
5342 -- Selected component reference for checking function argument
5345 Pref_Type
:= Etype
(Pref
);
5347 -- Force evaluation of the prefix, so that it does not get evaluated
5348 -- twice (once for the check, once for the actual reference). Such a
5349 -- double evaluation is always a potential source of inefficiency,
5350 -- and is functionally incorrect in the volatile case, or when the
5351 -- prefix may have side-effects. An entity or a component of an
5352 -- entity requires no evaluation.
5354 if Is_Entity_Name
(Pref
) then
5355 if Treat_As_Volatile
(Entity
(Pref
)) then
5356 Force_Evaluation
(Pref
, Name_Req
=> True);
5359 elsif Treat_As_Volatile
(Etype
(Pref
)) then
5360 Force_Evaluation
(Pref
, Name_Req
=> True);
5362 elsif Nkind
(Pref
) = N_Selected_Component
5363 and then Is_Entity_Name
(Prefix
(Pref
))
5368 Force_Evaluation
(Pref
, Name_Req
=> True);
5371 -- For a tagged type, use the scope of the original component to
5372 -- obtain the type, because ???
5374 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
5375 Pref_Type
:= Scope
(Orig_Comp
);
5377 -- For an untagged derived type, use the discriminants of the parent
5378 -- which have been renamed in the derivation, possibly by a one-to-many
5379 -- discriminant constraint. For non-tagged type, initially get the Etype
5383 if Is_Derived_Type
(Pref_Type
)
5384 and then Number_Discriminants
(Pref_Type
) /=
5385 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
5387 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
5391 -- We definitely should have a checking function, This routine should
5392 -- not be called if no discriminant checking function is present.
5394 pragma Assert
(Present
(Discr_Fct
));
5396 -- Create the list of the actual parameters for the call. This list
5397 -- is the list of the discriminant fields of the record expression to
5398 -- be discriminant checked.
5401 Formal
:= First_Formal
(Discr_Fct
);
5402 Discr
:= First_Discriminant
(Pref_Type
);
5403 while Present
(Discr
) loop
5405 -- If we have a corresponding discriminant field, and a parent
5406 -- subtype is present, then we want to use the corresponding
5407 -- discriminant since this is the one with the useful value.
5409 if Present
(Corresponding_Discriminant
(Discr
))
5410 and then Ekind
(Pref_Type
) = E_Record_Type
5411 and then Present
(Parent_Subtype
(Pref_Type
))
5413 Real_Discr
:= Corresponding_Discriminant
(Discr
);
5415 Real_Discr
:= Discr
;
5418 -- Construct the reference to the discriminant
5421 Make_Selected_Component
(Loc
,
5423 Unchecked_Convert_To
(Pref_Type
,
5424 Duplicate_Subexpr
(Pref
)),
5425 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
5427 -- Manually analyze and resolve this selected component. We really
5428 -- want it just as it appears above, and do not want the expander
5429 -- playing discriminal games etc with this reference. Then we append
5430 -- the argument to the list we are gathering.
5432 Set_Etype
(Scomp
, Etype
(Real_Discr
));
5433 Set_Analyzed
(Scomp
, True);
5434 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
5436 Next_Formal_With_Extras
(Formal
);
5437 Next_Discriminant
(Discr
);
5440 -- Now build and insert the call
5443 Make_Raise_Constraint_Error
(Loc
,
5445 Make_Function_Call
(Loc
,
5446 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
5447 Parameter_Associations
=> Args
),
5448 Reason
=> CE_Discriminant_Check_Failed
));
5449 end Generate_Discriminant_Check
;
5451 ---------------------------
5452 -- Generate_Index_Checks --
5453 ---------------------------
5455 procedure Generate_Index_Checks
(N
: Node_Id
) is
5457 function Entity_Of_Prefix
return Entity_Id
;
5458 -- Returns the entity of the prefix of N (or Empty if not found)
5460 ----------------------
5461 -- Entity_Of_Prefix --
5462 ----------------------
5464 function Entity_Of_Prefix
return Entity_Id
is
5469 while not Is_Entity_Name
(P
) loop
5470 if not Nkind_In
(P
, N_Selected_Component
,
5471 N_Indexed_Component
)
5480 end Entity_Of_Prefix
;
5484 Loc
: constant Source_Ptr
:= Sloc
(N
);
5485 A
: constant Node_Id
:= Prefix
(N
);
5486 A_Ent
: constant Entity_Id
:= Entity_Of_Prefix
;
5489 -- Start of processing for Generate_Index_Checks
5492 -- Ignore call if the prefix is not an array since we have a serious
5493 -- error in the sources. Ignore it also if index checks are suppressed
5494 -- for array object or type.
5496 if not Is_Array_Type
(Etype
(A
))
5497 or else (Present
(A_Ent
)
5498 and then Index_Checks_Suppressed
(A_Ent
))
5499 or else Index_Checks_Suppressed
(Etype
(A
))
5504 -- Generate a raise of constraint error with the appropriate reason and
5505 -- a condition of the form:
5507 -- Base_Type (Sub) not in Array'Range (Subscript)
5509 -- Note that the reason we generate the conversion to the base type here
5510 -- is that we definitely want the range check to take place, even if it
5511 -- looks like the subtype is OK. Optimization considerations that allow
5512 -- us to omit the check have already been taken into account in the
5513 -- setting of the Do_Range_Check flag earlier on.
5515 Sub
:= First
(Expressions
(N
));
5517 -- Handle string literals
5519 if Ekind
(Etype
(A
)) = E_String_Literal_Subtype
then
5520 if Do_Range_Check
(Sub
) then
5521 Set_Do_Range_Check
(Sub
, False);
5523 -- For string literals we obtain the bounds of the string from the
5524 -- associated subtype.
5527 Make_Raise_Constraint_Error
(Loc
,
5531 Convert_To
(Base_Type
(Etype
(Sub
)),
5532 Duplicate_Subexpr_Move_Checks
(Sub
)),
5534 Make_Attribute_Reference
(Loc
,
5535 Prefix
=> New_Reference_To
(Etype
(A
), Loc
),
5536 Attribute_Name
=> Name_Range
)),
5537 Reason
=> CE_Index_Check_Failed
));
5544 A_Idx
: Node_Id
:= Empty
;
5551 A_Idx
:= First_Index
(Etype
(A
));
5553 while Present
(Sub
) loop
5554 if Do_Range_Check
(Sub
) then
5555 Set_Do_Range_Check
(Sub
, False);
5557 -- Force evaluation except for the case of a simple name of
5558 -- a non-volatile entity.
5560 if not Is_Entity_Name
(Sub
)
5561 or else Treat_As_Volatile
(Entity
(Sub
))
5563 Force_Evaluation
(Sub
);
5566 if Nkind
(A_Idx
) = N_Range
then
5569 elsif Nkind
(A_Idx
) = N_Identifier
5570 or else Nkind
(A_Idx
) = N_Expanded_Name
5572 A_Range
:= Scalar_Range
(Entity
(A_Idx
));
5574 else pragma Assert
(Nkind
(A_Idx
) = N_Subtype_Indication
);
5575 A_Range
:= Range_Expression
(Constraint
(A_Idx
));
5578 -- For array objects with constant bounds we can generate
5579 -- the index check using the bounds of the type of the index
5582 and then Ekind
(A_Ent
) = E_Variable
5583 and then Is_Constant_Bound
(Low_Bound
(A_Range
))
5584 and then Is_Constant_Bound
(High_Bound
(A_Range
))
5587 Make_Attribute_Reference
(Loc
,
5589 New_Reference_To
(Etype
(A_Idx
), Loc
),
5590 Attribute_Name
=> Name_Range
);
5592 -- For arrays with non-constant bounds we cannot generate
5593 -- the index check using the bounds of the type of the index
5594 -- since it may reference discriminants of some enclosing
5595 -- type. We obtain the bounds directly from the prefix
5602 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
5606 Make_Attribute_Reference
(Loc
,
5608 Duplicate_Subexpr_Move_Checks
(A
, Name_Req
=> True),
5609 Attribute_Name
=> Name_Range
,
5610 Expressions
=> Num
);
5614 Make_Raise_Constraint_Error
(Loc
,
5618 Convert_To
(Base_Type
(Etype
(Sub
)),
5619 Duplicate_Subexpr_Move_Checks
(Sub
)),
5620 Right_Opnd
=> Range_N
),
5621 Reason
=> CE_Index_Check_Failed
));
5624 A_Idx
:= Next_Index
(A_Idx
);
5630 end Generate_Index_Checks
;
5632 --------------------------
5633 -- Generate_Range_Check --
5634 --------------------------
5636 procedure Generate_Range_Check
5638 Target_Type
: Entity_Id
;
5639 Reason
: RT_Exception_Code
)
5641 Loc
: constant Source_Ptr
:= Sloc
(N
);
5642 Source_Type
: constant Entity_Id
:= Etype
(N
);
5643 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
5644 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
5647 -- First special case, if the source type is already within the range
5648 -- of the target type, then no check is needed (probably we should have
5649 -- stopped Do_Range_Check from being set in the first place, but better
5650 -- late than later in preventing junk code!
5652 -- We do NOT apply this if the source node is a literal, since in this
5653 -- case the literal has already been labeled as having the subtype of
5656 if In_Subrange_Of
(Source_Type
, Target_Type
)
5658 (Nkind
(N
) = N_Integer_Literal
5660 Nkind
(N
) = N_Real_Literal
5662 Nkind
(N
) = N_Character_Literal
5665 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
5670 -- We need a check, so force evaluation of the node, so that it does
5671 -- not get evaluated twice (once for the check, once for the actual
5672 -- reference). Such a double evaluation is always a potential source
5673 -- of inefficiency, and is functionally incorrect in the volatile case.
5675 if not Is_Entity_Name
(N
)
5676 or else Treat_As_Volatile
(Entity
(N
))
5678 Force_Evaluation
(N
);
5681 -- The easiest case is when Source_Base_Type and Target_Base_Type are
5682 -- the same since in this case we can simply do a direct check of the
5683 -- value of N against the bounds of Target_Type.
5685 -- [constraint_error when N not in Target_Type]
5687 -- Note: this is by far the most common case, for example all cases of
5688 -- checks on the RHS of assignments are in this category, but not all
5689 -- cases are like this. Notably conversions can involve two types.
5691 if Source_Base_Type
= Target_Base_Type
then
5693 Make_Raise_Constraint_Error
(Loc
,
5696 Left_Opnd
=> Duplicate_Subexpr
(N
),
5697 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
5700 -- Next test for the case where the target type is within the bounds
5701 -- of the base type of the source type, since in this case we can
5702 -- simply convert these bounds to the base type of T to do the test.
5704 -- [constraint_error when N not in
5705 -- Source_Base_Type (Target_Type'First)
5707 -- Source_Base_Type(Target_Type'Last))]
5709 -- The conversions will always work and need no check
5711 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
5712 -- of converting from an enumeration value to an integer type, such as
5713 -- occurs for the case of generating a range check on Enum'Val(Exp)
5714 -- (which used to be handled by gigi). This is OK, since the conversion
5715 -- itself does not require a check.
5717 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
5719 Make_Raise_Constraint_Error
(Loc
,
5722 Left_Opnd
=> Duplicate_Subexpr
(N
),
5727 Unchecked_Convert_To
(Source_Base_Type
,
5728 Make_Attribute_Reference
(Loc
,
5730 New_Occurrence_Of
(Target_Type
, Loc
),
5731 Attribute_Name
=> Name_First
)),
5734 Unchecked_Convert_To
(Source_Base_Type
,
5735 Make_Attribute_Reference
(Loc
,
5737 New_Occurrence_Of
(Target_Type
, Loc
),
5738 Attribute_Name
=> Name_Last
)))),
5741 -- Note that at this stage we now that the Target_Base_Type is not in
5742 -- the range of the Source_Base_Type (since even the Target_Type itself
5743 -- is not in this range). It could still be the case that Source_Type is
5744 -- in range of the target base type since we have not checked that case.
5746 -- If that is the case, we can freely convert the source to the target,
5747 -- and then test the target result against the bounds.
5749 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
5751 -- We make a temporary to hold the value of the converted value
5752 -- (converted to the base type), and then we will do the test against
5755 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
5756 -- [constraint_error when Tnn not in Target_Type]
5758 -- Then the conversion itself is replaced by an occurrence of Tnn
5761 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
5764 Insert_Actions
(N
, New_List
(
5765 Make_Object_Declaration
(Loc
,
5766 Defining_Identifier
=> Tnn
,
5767 Object_Definition
=>
5768 New_Occurrence_Of
(Target_Base_Type
, Loc
),
5769 Constant_Present
=> True,
5771 Make_Type_Conversion
(Loc
,
5772 Subtype_Mark
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
5773 Expression
=> Duplicate_Subexpr
(N
))),
5775 Make_Raise_Constraint_Error
(Loc
,
5778 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
5779 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
5781 Reason
=> Reason
)));
5783 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
5785 -- Set the type of N, because the declaration for Tnn might not
5786 -- be analyzed yet, as is the case if N appears within a record
5787 -- declaration, as a discriminant constraint or expression.
5789 Set_Etype
(N
, Target_Base_Type
);
5792 -- At this stage, we know that we have two scalar types, which are
5793 -- directly convertible, and where neither scalar type has a base
5794 -- range that is in the range of the other scalar type.
5796 -- The only way this can happen is with a signed and unsigned type.
5797 -- So test for these two cases:
5800 -- Case of the source is unsigned and the target is signed
5802 if Is_Unsigned_Type
(Source_Base_Type
)
5803 and then not Is_Unsigned_Type
(Target_Base_Type
)
5805 -- If the source is unsigned and the target is signed, then we
5806 -- know that the source is not shorter than the target (otherwise
5807 -- the source base type would be in the target base type range).
5809 -- In other words, the unsigned type is either the same size as
5810 -- the target, or it is larger. It cannot be smaller.
5813 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
5815 -- We only need to check the low bound if the low bound of the
5816 -- target type is non-negative. If the low bound of the target
5817 -- type is negative, then we know that we will fit fine.
5819 -- If the high bound of the target type is negative, then we
5820 -- know we have a constraint error, since we can't possibly
5821 -- have a negative source.
5823 -- With these two checks out of the way, we can do the check
5824 -- using the source type safely
5826 -- This is definitely the most annoying case!
5828 -- [constraint_error
5829 -- when (Target_Type'First >= 0
5831 -- N < Source_Base_Type (Target_Type'First))
5832 -- or else Target_Type'Last < 0
5833 -- or else N > Source_Base_Type (Target_Type'Last)];
5835 -- We turn off all checks since we know that the conversions
5836 -- will work fine, given the guards for negative values.
5839 Make_Raise_Constraint_Error
(Loc
,
5845 Left_Opnd
=> Make_Op_Ge
(Loc
,
5847 Make_Attribute_Reference
(Loc
,
5849 New_Occurrence_Of
(Target_Type
, Loc
),
5850 Attribute_Name
=> Name_First
),
5851 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
5855 Left_Opnd
=> Duplicate_Subexpr
(N
),
5857 Convert_To
(Source_Base_Type
,
5858 Make_Attribute_Reference
(Loc
,
5860 New_Occurrence_Of
(Target_Type
, Loc
),
5861 Attribute_Name
=> Name_First
)))),
5866 Make_Attribute_Reference
(Loc
,
5867 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
5868 Attribute_Name
=> Name_Last
),
5869 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
5873 Left_Opnd
=> Duplicate_Subexpr
(N
),
5875 Convert_To
(Source_Base_Type
,
5876 Make_Attribute_Reference
(Loc
,
5877 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
5878 Attribute_Name
=> Name_Last
)))),
5881 Suppress
=> All_Checks
);
5883 -- Only remaining possibility is that the source is signed and
5884 -- the target is unsigned.
5887 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
5888 and then Is_Unsigned_Type
(Target_Base_Type
));
5890 -- If the source is signed and the target is unsigned, then we
5891 -- know that the target is not shorter than the source (otherwise
5892 -- the target base type would be in the source base type range).
5894 -- In other words, the unsigned type is either the same size as
5895 -- the target, or it is larger. It cannot be smaller.
5897 -- Clearly we have an error if the source value is negative since
5898 -- no unsigned type can have negative values. If the source type
5899 -- is non-negative, then the check can be done using the target
5902 -- Tnn : constant Target_Base_Type (N) := Target_Type;
5904 -- [constraint_error
5905 -- when N < 0 or else Tnn not in Target_Type];
5907 -- We turn off all checks for the conversion of N to the target
5908 -- base type, since we generate the explicit check to ensure that
5909 -- the value is non-negative
5912 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
5915 Insert_Actions
(N
, New_List
(
5916 Make_Object_Declaration
(Loc
,
5917 Defining_Identifier
=> Tnn
,
5918 Object_Definition
=>
5919 New_Occurrence_Of
(Target_Base_Type
, Loc
),
5920 Constant_Present
=> True,
5922 Make_Unchecked_Type_Conversion
(Loc
,
5924 New_Occurrence_Of
(Target_Base_Type
, Loc
),
5925 Expression
=> Duplicate_Subexpr
(N
))),
5927 Make_Raise_Constraint_Error
(Loc
,
5932 Left_Opnd
=> Duplicate_Subexpr
(N
),
5933 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
5937 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
5939 New_Occurrence_Of
(Target_Type
, Loc
))),
5942 Suppress
=> All_Checks
);
5944 -- Set the Etype explicitly, because Insert_Actions may have
5945 -- placed the declaration in the freeze list for an enclosing
5946 -- construct, and thus it is not analyzed yet.
5948 Set_Etype
(Tnn
, Target_Base_Type
);
5949 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
5953 end Generate_Range_Check
;
5959 function Get_Check_Id
(N
: Name_Id
) return Check_Id
is
5961 -- For standard check name, we can do a direct computation
5963 if N
in First_Check_Name
.. Last_Check_Name
then
5964 return Check_Id
(N
- (First_Check_Name
- 1));
5966 -- For non-standard names added by pragma Check_Name, search table
5969 for J
in All_Checks
+ 1 .. Check_Names
.Last
loop
5970 if Check_Names
.Table
(J
) = N
then
5976 -- No matching name found
5981 ---------------------
5982 -- Get_Discriminal --
5983 ---------------------
5985 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
5986 Loc
: constant Source_Ptr
:= Sloc
(E
);
5991 -- The bound can be a bona fide parameter of a protected operation,
5992 -- rather than a prival encoded as an in-parameter.
5994 if No
(Discriminal_Link
(Entity
(Bound
))) then
5998 -- Climb the scope stack looking for an enclosing protected type. If
5999 -- we run out of scopes, return the bound itself.
6002 while Present
(Sc
) loop
6003 if Sc
= Standard_Standard
then
6006 elsif Ekind
(Sc
) = E_Protected_Type
then
6013 D
:= First_Discriminant
(Sc
);
6014 while Present
(D
) loop
6015 if Chars
(D
) = Chars
(Bound
) then
6016 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
6019 Next_Discriminant
(D
);
6023 end Get_Discriminal
;
6025 ----------------------
6026 -- Get_Range_Checks --
6027 ----------------------
6029 function Get_Range_Checks
6031 Target_Typ
: Entity_Id
;
6032 Source_Typ
: Entity_Id
:= Empty
;
6033 Warn_Node
: Node_Id
:= Empty
) return Check_Result
6036 return Selected_Range_Checks
6037 (Ck_Node
, Target_Typ
, Source_Typ
, Warn_Node
);
6038 end Get_Range_Checks
;
6044 function Guard_Access
6047 Ck_Node
: Node_Id
) return Node_Id
6050 if Nkind
(Cond
) = N_Or_Else
then
6051 Set_Paren_Count
(Cond
, 1);
6054 if Nkind
(Ck_Node
) = N_Allocator
then
6061 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
6062 Right_Opnd
=> Make_Null
(Loc
)),
6063 Right_Opnd
=> Cond
);
6067 -----------------------------
6068 -- Index_Checks_Suppressed --
6069 -----------------------------
6071 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6073 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6074 return Is_Check_Suppressed
(E
, Index_Check
);
6076 return Scope_Suppress
.Suppress
(Index_Check
);
6078 end Index_Checks_Suppressed
;
6084 procedure Initialize
is
6086 for J
in Determine_Range_Cache_N
'Range loop
6087 Determine_Range_Cache_N
(J
) := Empty
;
6092 for J
in Int
range 1 .. All_Checks
loop
6093 Check_Names
.Append
(Name_Id
(Int
(First_Check_Name
) + J
- 1));
6097 -------------------------
6098 -- Insert_Range_Checks --
6099 -------------------------
6101 procedure Insert_Range_Checks
6102 (Checks
: Check_Result
;
6104 Suppress_Typ
: Entity_Id
;
6105 Static_Sloc
: Source_Ptr
:= No_Location
;
6106 Flag_Node
: Node_Id
:= Empty
;
6107 Do_Before
: Boolean := False)
6109 Internal_Flag_Node
: Node_Id
:= Flag_Node
;
6110 Internal_Static_Sloc
: Source_Ptr
:= Static_Sloc
;
6112 Check_Node
: Node_Id
;
6113 Checks_On
: constant Boolean :=
6114 (not Index_Checks_Suppressed
(Suppress_Typ
))
6115 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
6118 -- For now we just return if Checks_On is false, however this should be
6119 -- enhanced to check for an always True value in the condition and to
6120 -- generate a compilation warning???
6122 if not Full_Expander_Active
or else not Checks_On
then
6126 if Static_Sloc
= No_Location
then
6127 Internal_Static_Sloc
:= Sloc
(Node
);
6130 if No
(Flag_Node
) then
6131 Internal_Flag_Node
:= Node
;
6134 for J
in 1 .. 2 loop
6135 exit when No
(Checks
(J
));
6137 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
6138 and then Present
(Condition
(Checks
(J
)))
6140 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
6141 Check_Node
:= Checks
(J
);
6142 Mark_Rewrite_Insertion
(Check_Node
);
6145 Insert_Before_And_Analyze
(Node
, Check_Node
);
6147 Insert_After_And_Analyze
(Node
, Check_Node
);
6150 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
6155 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
6156 Reason
=> CE_Range_Check_Failed
);
6157 Mark_Rewrite_Insertion
(Check_Node
);
6160 Insert_Before_And_Analyze
(Node
, Check_Node
);
6162 Insert_After_And_Analyze
(Node
, Check_Node
);
6166 end Insert_Range_Checks
;
6168 ------------------------
6169 -- Insert_Valid_Check --
6170 ------------------------
6172 procedure Insert_Valid_Check
(Expr
: Node_Id
) is
6173 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6177 -- Do not insert if checks off, or if not checking validity or
6178 -- if expression is known to be valid
6180 if not Validity_Checks_On
6181 or else Range_Or_Validity_Checks_Suppressed
(Expr
)
6182 or else Expr_Known_Valid
(Expr
)
6187 -- If we have a checked conversion, then validity check applies to
6188 -- the expression inside the conversion, not the result, since if
6189 -- the expression inside is valid, then so is the conversion result.
6192 while Nkind
(Exp
) = N_Type_Conversion
loop
6193 Exp
:= Expression
(Exp
);
6196 -- We are about to insert the validity check for Exp. We save and
6197 -- reset the Do_Range_Check flag over this validity check, and then
6198 -- put it back for the final original reference (Exp may be rewritten).
6201 DRC
: constant Boolean := Do_Range_Check
(Exp
);
6204 Set_Do_Range_Check
(Exp
, False);
6206 -- Force evaluation to avoid multiple reads for atomic/volatile
6208 if Is_Entity_Name
(Exp
)
6209 and then Is_Volatile
(Entity
(Exp
))
6211 Force_Evaluation
(Exp
, Name_Req
=> True);
6214 -- Insert the validity check. Note that we do this with validity
6215 -- checks turned off, to avoid recursion, we do not want validity
6216 -- checks on the validity checking code itself!
6220 Make_Raise_Constraint_Error
(Loc
,
6224 Make_Attribute_Reference
(Loc
,
6226 Duplicate_Subexpr_No_Checks
(Exp
, Name_Req
=> True),
6227 Attribute_Name
=> Name_Valid
)),
6228 Reason
=> CE_Invalid_Data
),
6229 Suppress
=> Validity_Check
);
6231 -- If the expression is a reference to an element of a bit-packed
6232 -- array, then it is rewritten as a renaming declaration. If the
6233 -- expression is an actual in a call, it has not been expanded,
6234 -- waiting for the proper point at which to do it. The same happens
6235 -- with renamings, so that we have to force the expansion now. This
6236 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
6239 if Is_Entity_Name
(Exp
)
6240 and then Nkind
(Parent
(Entity
(Exp
))) =
6241 N_Object_Renaming_Declaration
6244 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
6246 if Nkind
(Old_Exp
) = N_Indexed_Component
6247 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
6249 Expand_Packed_Element_Reference
(Old_Exp
);
6254 -- Put back the Do_Range_Check flag on the resulting (possibly
6255 -- rewritten) expression.
6257 -- Note: it might be thought that a validity check is not required
6258 -- when a range check is present, but that's not the case, because
6259 -- the back end is allowed to assume for the range check that the
6260 -- operand is within its declared range (an assumption that validity
6261 -- checking is all about NOT assuming!)
6263 -- Note: no need to worry about Possible_Local_Raise here, it will
6264 -- already have been called if original node has Do_Range_Check set.
6266 Set_Do_Range_Check
(Exp
, DRC
);
6268 end Insert_Valid_Check
;
6270 -------------------------------------
6271 -- Is_Signed_Integer_Arithmetic_Op --
6272 -------------------------------------
6274 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean is
6277 when N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
6278 N_Op_Minus | N_Op_Mod | N_Op_Multiply | N_Op_Plus |
6279 N_Op_Rem | N_Op_Subtract
=>
6280 return Is_Signed_Integer_Type
(Etype
(N
));
6282 when N_If_Expression | N_Case_Expression
=>
6283 return Is_Signed_Integer_Type
(Etype
(N
));
6288 end Is_Signed_Integer_Arithmetic_Op
;
6290 ----------------------------------
6291 -- Install_Null_Excluding_Check --
6292 ----------------------------------
6294 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
6295 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
6296 Typ
: constant Entity_Id
:= Etype
(N
);
6298 function Safe_To_Capture_In_Parameter_Value
return Boolean;
6299 -- Determines if it is safe to capture Known_Non_Null status for an
6300 -- the entity referenced by node N. The caller ensures that N is indeed
6301 -- an entity name. It is safe to capture the non-null status for an IN
6302 -- parameter when the reference occurs within a declaration that is sure
6303 -- to be executed as part of the declarative region.
6305 procedure Mark_Non_Null
;
6306 -- After installation of check, if the node in question is an entity
6307 -- name, then mark this entity as non-null if possible.
6309 function Safe_To_Capture_In_Parameter_Value
return Boolean is
6310 E
: constant Entity_Id
:= Entity
(N
);
6311 S
: constant Entity_Id
:= Current_Scope
;
6315 if Ekind
(E
) /= E_In_Parameter
then
6319 -- Two initial context checks. We must be inside a subprogram body
6320 -- with declarations and reference must not appear in nested scopes.
6322 if (Ekind
(S
) /= E_Function
and then Ekind
(S
) /= E_Procedure
)
6323 or else Scope
(E
) /= S
6328 S_Par
:= Parent
(Parent
(S
));
6330 if Nkind
(S_Par
) /= N_Subprogram_Body
6331 or else No
(Declarations
(S_Par
))
6341 -- Retrieve the declaration node of N (if any). Note that N
6342 -- may be a part of a complex initialization expression.
6346 while Present
(P
) loop
6348 -- If we have a short circuit form, and we are within the right
6349 -- hand expression, we return false, since the right hand side
6350 -- is not guaranteed to be elaborated.
6352 if Nkind
(P
) in N_Short_Circuit
6353 and then N
= Right_Opnd
(P
)
6358 -- Similarly, if we are in an if expression and not part of the
6359 -- condition, then we return False, since neither the THEN or
6360 -- ELSE dependent expressions will always be elaborated.
6362 if Nkind
(P
) = N_If_Expression
6363 and then N
/= First
(Expressions
(P
))
6368 -- If we are in a case expression, and not part of the
6369 -- expression, then we return False, since a particular
6370 -- dependent expression may not always be elaborated
6372 if Nkind
(P
) = N_Case_Expression
6373 and then N
/= Expression
(P
)
6378 -- While traversing the parent chain, we find that N
6379 -- belongs to a statement, thus it may never appear in
6380 -- a declarative region.
6382 if Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
6383 or else Nkind
(P
) = N_Procedure_Call_Statement
6388 -- If we are at a declaration, record it and exit
6390 if Nkind
(P
) in N_Declaration
6391 and then Nkind
(P
) not in N_Subprogram_Specification
6404 return List_Containing
(N_Decl
) = Declarations
(S_Par
);
6406 end Safe_To_Capture_In_Parameter_Value
;
6412 procedure Mark_Non_Null
is
6414 -- Only case of interest is if node N is an entity name
6416 if Is_Entity_Name
(N
) then
6418 -- For sure, we want to clear an indication that this is known to
6419 -- be null, since if we get past this check, it definitely is not!
6421 Set_Is_Known_Null
(Entity
(N
), False);
6423 -- We can mark the entity as known to be non-null if either it is
6424 -- safe to capture the value, or in the case of an IN parameter,
6425 -- which is a constant, if the check we just installed is in the
6426 -- declarative region of the subprogram body. In this latter case,
6427 -- a check is decisive for the rest of the body if the expression
6428 -- is sure to be elaborated, since we know we have to elaborate
6429 -- all declarations before executing the body.
6431 -- Couldn't this always be part of Safe_To_Capture_Value ???
6433 if Safe_To_Capture_Value
(N
, Entity
(N
))
6434 or else Safe_To_Capture_In_Parameter_Value
6436 Set_Is_Known_Non_Null
(Entity
(N
));
6441 -- Start of processing for Install_Null_Excluding_Check
6444 pragma Assert
(Is_Access_Type
(Typ
));
6446 -- No check inside a generic (why not???)
6448 if Inside_A_Generic
then
6452 -- No check needed if known to be non-null
6454 if Known_Non_Null
(N
) then
6458 -- If known to be null, here is where we generate a compile time check
6460 if Known_Null
(N
) then
6462 -- Avoid generating warning message inside init procs
6464 if not Inside_Init_Proc
then
6465 Apply_Compile_Time_Constraint_Error
6467 "null value not allowed here?",
6468 CE_Access_Check_Failed
);
6471 Make_Raise_Constraint_Error
(Loc
,
6472 Reason
=> CE_Access_Check_Failed
));
6479 -- If entity is never assigned, for sure a warning is appropriate
6481 if Is_Entity_Name
(N
) then
6482 Check_Unset_Reference
(N
);
6485 -- No check needed if checks are suppressed on the range. Note that we
6486 -- don't set Is_Known_Non_Null in this case (we could legitimately do
6487 -- so, since the program is erroneous, but we don't like to casually
6488 -- propagate such conclusions from erroneosity).
6490 if Access_Checks_Suppressed
(Typ
) then
6494 -- No check needed for access to concurrent record types generated by
6495 -- the expander. This is not just an optimization (though it does indeed
6496 -- remove junk checks). It also avoids generation of junk warnings.
6498 if Nkind
(N
) in N_Has_Chars
6499 and then Chars
(N
) = Name_uObject
6500 and then Is_Concurrent_Record_Type
6501 (Directly_Designated_Type
(Etype
(N
)))
6506 -- No check needed for the Get_Current_Excep.all.all idiom generated by
6507 -- the expander within exception handlers, since we know that the value
6508 -- can never be null.
6510 -- Is this really the right way to do this? Normally we generate such
6511 -- code in the expander with checks off, and that's how we suppress this
6512 -- kind of junk check ???
6514 if Nkind
(N
) = N_Function_Call
6515 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
6516 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
6517 and then Is_RTE
(Entity
(Prefix
(Name
(N
))), RE_Get_Current_Excep
)
6522 -- Otherwise install access check
6525 Make_Raise_Constraint_Error
(Loc
,
6528 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
6529 Right_Opnd
=> Make_Null
(Loc
)),
6530 Reason
=> CE_Access_Check_Failed
));
6533 end Install_Null_Excluding_Check
;
6535 --------------------------
6536 -- Install_Static_Check --
6537 --------------------------
6539 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
6540 Stat
: constant Boolean := Is_Static_Expression
(R_Cno
);
6541 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
6545 Make_Raise_Constraint_Error
(Loc
,
6546 Reason
=> CE_Range_Check_Failed
));
6547 Set_Analyzed
(R_Cno
);
6548 Set_Etype
(R_Cno
, Typ
);
6549 Set_Raises_Constraint_Error
(R_Cno
);
6550 Set_Is_Static_Expression
(R_Cno
, Stat
);
6552 -- Now deal with possible local raise handling
6554 Possible_Local_Raise
(R_Cno
, Standard_Constraint_Error
);
6555 end Install_Static_Check
;
6557 -------------------------
6558 -- Is_Check_Suppressed --
6559 -------------------------
6561 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
6562 Ptr
: Suppress_Stack_Entry_Ptr
;
6565 -- First search the local entity suppress stack. We search this from the
6566 -- top of the stack down so that we get the innermost entry that applies
6567 -- to this case if there are nested entries.
6569 Ptr
:= Local_Suppress_Stack_Top
;
6570 while Ptr
/= null loop
6571 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
6572 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
6574 return Ptr
.Suppress
;
6580 -- Now search the global entity suppress table for a matching entry.
6581 -- We also search this from the top down so that if there are multiple
6582 -- pragmas for the same entity, the last one applies (not clear what
6583 -- or whether the RM specifies this handling, but it seems reasonable).
6585 Ptr
:= Global_Suppress_Stack_Top
;
6586 while Ptr
/= null loop
6587 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
6588 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
6590 return Ptr
.Suppress
;
6596 -- If we did not find a matching entry, then use the normal scope
6597 -- suppress value after all (actually this will be the global setting
6598 -- since it clearly was not overridden at any point). For a predefined
6599 -- check, we test the specific flag. For a user defined check, we check
6600 -- the All_Checks flag. The Overflow flag requires special handling to
6601 -- deal with the General vs Assertion case
6603 if C
= Overflow_Check
then
6604 return Overflow_Checks_Suppressed
(Empty
);
6605 elsif C
in Predefined_Check_Id
then
6606 return Scope_Suppress
.Suppress
(C
);
6608 return Scope_Suppress
.Suppress
(All_Checks
);
6610 end Is_Check_Suppressed
;
6612 ---------------------
6613 -- Kill_All_Checks --
6614 ---------------------
6616 procedure Kill_All_Checks
is
6618 if Debug_Flag_CC
then
6619 w
("Kill_All_Checks");
6622 -- We reset the number of saved checks to zero, and also modify all
6623 -- stack entries for statement ranges to indicate that the number of
6624 -- checks at each level is now zero.
6626 Num_Saved_Checks
:= 0;
6628 -- Note: the Int'Min here avoids any possibility of J being out of
6629 -- range when called from e.g. Conditional_Statements_Begin.
6631 for J
in 1 .. Int
'Min (Saved_Checks_TOS
, Saved_Checks_Stack
'Last) loop
6632 Saved_Checks_Stack
(J
) := 0;
6634 end Kill_All_Checks
;
6640 procedure Kill_Checks
(V
: Entity_Id
) is
6642 if Debug_Flag_CC
then
6643 w
("Kill_Checks for entity", Int
(V
));
6646 for J
in 1 .. Num_Saved_Checks
loop
6647 if Saved_Checks
(J
).Entity
= V
then
6648 if Debug_Flag_CC
then
6649 w
(" Checks killed for saved check ", J
);
6652 Saved_Checks
(J
).Killed
:= True;
6657 ------------------------------
6658 -- Length_Checks_Suppressed --
6659 ------------------------------
6661 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6663 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6664 return Is_Check_Suppressed
(E
, Length_Check
);
6666 return Scope_Suppress
.Suppress
(Length_Check
);
6668 end Length_Checks_Suppressed
;
6670 -----------------------
6671 -- Make_Bignum_Block --
6672 -----------------------
6674 function Make_Bignum_Block
(Loc
: Source_Ptr
) return Node_Id
is
6675 M
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uM
);
6679 Make_Block_Statement
(Loc
,
6680 Declarations
=> New_List
(
6681 Make_Object_Declaration
(Loc
,
6682 Defining_Identifier
=> M
,
6683 Object_Definition
=>
6684 New_Occurrence_Of
(RTE
(RE_Mark_Id
), Loc
),
6686 Make_Function_Call
(Loc
,
6687 Name
=> New_Reference_To
(RTE
(RE_SS_Mark
), Loc
)))),
6689 Handled_Statement_Sequence
=>
6690 Make_Handled_Sequence_Of_Statements
(Loc
,
6691 Statements
=> New_List
(
6692 Make_Procedure_Call_Statement
(Loc
,
6693 Name
=> New_Occurrence_Of
(RTE
(RE_SS_Release
), Loc
),
6694 Parameter_Associations
=> New_List
(
6695 New_Reference_To
(M
, Loc
))))));
6696 end Make_Bignum_Block
;
6698 ----------------------------------
6699 -- Minimize_Eliminate_Overflows --
6700 ----------------------------------
6702 -- This is a recursive routine that is called at the top of an expression
6703 -- tree to properly process overflow checking for a whole subtree by making
6704 -- recursive calls to process operands. This processing may involve the use
6705 -- of bignum or long long integer arithmetic, which will change the types
6706 -- of operands and results. That's why we can't do this bottom up (since
6707 -- it would interfere with semantic analysis).
6709 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
6710 -- the operator expansion routines, as well as the expansion routines for
6711 -- if/case expression, do nothing (for the moment) except call the routine
6712 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
6713 -- routine does nothing for non top-level nodes, so at the point where the
6714 -- call is made for the top level node, the entire expression subtree has
6715 -- not been expanded, or processed for overflow. All that has to happen as
6716 -- a result of the top level call to this routine.
6718 -- As noted above, the overflow processing works by making recursive calls
6719 -- for the operands, and figuring out what to do, based on the processing
6720 -- of these operands (e.g. if a bignum operand appears, the parent op has
6721 -- to be done in bignum mode), and the determined ranges of the operands.
6723 -- After possible rewriting of a constituent subexpression node, a call is
6724 -- made to either reexpand the node (if nothing has changed) or reanalyze
6725 -- the node (if it has been modified by the overflow check processing). The
6726 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
6727 -- a recursive call into the whole overflow apparatus, an important rule
6728 -- for this call is that the overflow handling mode must be temporarily set
6731 procedure Minimize_Eliminate_Overflows
6735 Top_Level
: Boolean)
6737 Rtyp
: constant Entity_Id
:= Etype
(N
);
6738 pragma Assert
(Is_Signed_Integer_Type
(Rtyp
));
6739 -- Result type, must be a signed integer type
6741 Check_Mode
: constant Overflow_Check_Type
:= Overflow_Check_Mode
;
6742 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
6744 Loc
: constant Source_Ptr
:= Sloc
(N
);
6747 -- Ranges of values for right operand (operator case)
6750 -- Ranges of values for left operand (operator case)
6752 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
6753 -- Operands and results are of this type when we convert
6755 LLLo
: constant Uint
:= Intval
(Type_Low_Bound
(LLIB
));
6756 LLHi
: constant Uint
:= Intval
(Type_High_Bound
(LLIB
));
6757 -- Bounds of Long_Long_Integer
6759 Binary
: constant Boolean := Nkind
(N
) in N_Binary_Op
;
6760 -- Indicates binary operator case
6763 -- Used in call to Determine_Range
6765 Bignum_Operands
: Boolean;
6766 -- Set True if one or more operands is already of type Bignum, meaning
6767 -- that for sure (regardless of Top_Level setting) we are committed to
6768 -- doing the operation in Bignum mode (or in the case of a case or if
6769 -- expression, converting all the dependent expressions to Bignum).
6771 Long_Long_Integer_Operands
: Boolean;
6772 -- Set True if one or more operands is already of type Long_Long_Integer
6773 -- which means that if the result is known to be in the result type
6774 -- range, then we must convert such operands back to the result type.
6776 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False);
6777 -- This is called when we have modified the node and we therefore need
6778 -- to reanalyze it. It is important that we reset the mode to STRICT for
6779 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
6780 -- we would reenter this routine recursively which would not be good!
6781 -- The argument Suppress is set True if we also want to suppress
6782 -- overflow checking for the reexpansion (this is set when we know
6783 -- overflow is not possible). Typ is the type for the reanalysis.
6785 procedure Reexpand
(Suppress
: Boolean := False);
6786 -- This is like Reanalyze, but does not do the Analyze step, it only
6787 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
6788 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
6789 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
6790 -- Note that skipping reanalysis is not just an optimization, testing
6791 -- has showed up several complex cases in which reanalyzing an already
6792 -- analyzed node causes incorrect behavior.
6794 function In_Result_Range
return Boolean;
6795 -- Returns True iff Lo .. Hi are within range of the result type
6797 procedure Max
(A
: in out Uint
; B
: Uint
);
6798 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
6800 procedure Min
(A
: in out Uint
; B
: Uint
);
6801 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
6803 ---------------------
6804 -- In_Result_Range --
6805 ---------------------
6807 function In_Result_Range
return Boolean is
6809 if Lo
= No_Uint
or else Hi
= No_Uint
then
6812 elsif Is_Static_Subtype
(Etype
(N
)) then
6813 return Lo
>= Expr_Value
(Type_Low_Bound
(Rtyp
))
6815 Hi
<= Expr_Value
(Type_High_Bound
(Rtyp
));
6818 return Lo
>= Expr_Value
(Type_Low_Bound
(Base_Type
(Rtyp
)))
6820 Hi
<= Expr_Value
(Type_High_Bound
(Base_Type
(Rtyp
)));
6822 end In_Result_Range
;
6828 procedure Max
(A
: in out Uint
; B
: Uint
) is
6830 if A
= No_Uint
or else B
> A
then
6839 procedure Min
(A
: in out Uint
; B
: Uint
) is
6841 if A
= No_Uint
or else B
< A
then
6850 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False) is
6851 Svg
: constant Overflow_Check_Type
:=
6852 Scope_Suppress
.Overflow_Checks_General
;
6853 Sva
: constant Overflow_Check_Type
:=
6854 Scope_Suppress
.Overflow_Checks_Assertions
;
6855 Svo
: constant Boolean :=
6856 Scope_Suppress
.Suppress
(Overflow_Check
);
6859 Scope_Suppress
.Overflow_Checks_General
:= Strict
;
6860 Scope_Suppress
.Overflow_Checks_Assertions
:= Strict
;
6863 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
6866 Analyze_And_Resolve
(N
, Typ
);
6868 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
6869 Scope_Suppress
.Overflow_Checks_General
:= Svg
;
6870 Scope_Suppress
.Overflow_Checks_Assertions
:= Sva
;
6877 procedure Reexpand
(Suppress
: Boolean := False) is
6878 Svg
: constant Overflow_Check_Type
:=
6879 Scope_Suppress
.Overflow_Checks_General
;
6880 Sva
: constant Overflow_Check_Type
:=
6881 Scope_Suppress
.Overflow_Checks_Assertions
;
6882 Svo
: constant Boolean :=
6883 Scope_Suppress
.Suppress
(Overflow_Check
);
6886 Scope_Suppress
.Overflow_Checks_General
:= Strict
;
6887 Scope_Suppress
.Overflow_Checks_Assertions
:= Strict
;
6888 Set_Analyzed
(N
, False);
6891 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
6896 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
6897 Scope_Suppress
.Overflow_Checks_General
:= Svg
;
6898 Scope_Suppress
.Overflow_Checks_Assertions
:= Sva
;
6901 -- Start of processing for Minimize_Eliminate_Overflows
6904 -- Case where we do not have a signed integer arithmetic operation
6906 if not Is_Signed_Integer_Arithmetic_Op
(N
) then
6908 -- Use the normal Determine_Range routine to get the range. We
6909 -- don't require operands to be valid, invalid values may result in
6910 -- rubbish results where the result has not been properly checked for
6911 -- overflow, that's fine!
6913 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> False);
6915 -- If Determine_Range did not work (can this in fact happen? Not
6916 -- clear but might as well protect), use type bounds.
6919 Lo
:= Intval
(Type_Low_Bound
(Base_Type
(Etype
(N
))));
6920 Hi
:= Intval
(Type_High_Bound
(Base_Type
(Etype
(N
))));
6923 -- If we don't have a binary operator, all we have to do is to set
6924 -- the Hi/Lo range, so we are done
6928 -- Processing for if expression
6930 elsif Nkind
(N
) = N_If_Expression
then
6932 Then_DE
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
6933 Else_DE
: constant Node_Id
:= Next
(Then_DE
);
6936 Bignum_Operands
:= False;
6938 Minimize_Eliminate_Overflows
6939 (Then_DE
, Lo
, Hi
, Top_Level
=> False);
6941 if Lo
= No_Uint
then
6942 Bignum_Operands
:= True;
6945 Minimize_Eliminate_Overflows
6946 (Else_DE
, Rlo
, Rhi
, Top_Level
=> False);
6948 if Rlo
= No_Uint
then
6949 Bignum_Operands
:= True;
6951 Long_Long_Integer_Operands
:=
6952 Etype
(Then_DE
) = LLIB
or else Etype
(Else_DE
) = LLIB
;
6958 -- If at least one of our operands is now Bignum, we must rebuild
6959 -- the if expression to use Bignum operands. We will analyze the
6960 -- rebuilt if expression with overflow checks off, since once we
6961 -- are in bignum mode, we are all done with overflow checks!
6963 if Bignum_Operands
then
6965 Make_If_Expression
(Loc
,
6966 Expressions
=> New_List
(
6967 Remove_Head
(Expressions
(N
)),
6968 Convert_To_Bignum
(Then_DE
),
6969 Convert_To_Bignum
(Else_DE
)),
6970 Is_Elsif
=> Is_Elsif
(N
)));
6972 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
6974 -- If we have no Long_Long_Integer operands, then we are in result
6975 -- range, since it means that none of our operands felt the need
6976 -- to worry about overflow (otherwise it would have already been
6977 -- converted to long long integer or bignum). We reexpand to
6978 -- complete the expansion of the if expression (but we do not
6979 -- need to reanalyze).
6981 elsif not Long_Long_Integer_Operands
then
6982 Set_Do_Overflow_Check
(N
, False);
6985 -- Otherwise convert us to long long integer mode. Note that we
6986 -- don't need any further overflow checking at this level.
6989 Convert_To_And_Rewrite
(LLIB
, Then_DE
);
6990 Convert_To_And_Rewrite
(LLIB
, Else_DE
);
6991 Set_Etype
(N
, LLIB
);
6993 -- Now reanalyze with overflow checks off
6995 Set_Do_Overflow_Check
(N
, False);
6996 Reanalyze
(LLIB
, Suppress
=> True);
7002 -- Here for case expression
7004 elsif Nkind
(N
) = N_Case_Expression
then
7005 Bignum_Operands
:= False;
7006 Long_Long_Integer_Operands
:= False;
7012 -- Loop through expressions applying recursive call
7014 Alt
:= First
(Alternatives
(N
));
7015 while Present
(Alt
) loop
7017 Aexp
: constant Node_Id
:= Expression
(Alt
);
7020 Minimize_Eliminate_Overflows
7021 (Aexp
, Lo
, Hi
, Top_Level
=> False);
7023 if Lo
= No_Uint
then
7024 Bignum_Operands
:= True;
7025 elsif Etype
(Aexp
) = LLIB
then
7026 Long_Long_Integer_Operands
:= True;
7033 -- If we have no bignum or long long integer operands, it means
7034 -- that none of our dependent expressions could raise overflow.
7035 -- In this case, we simply return with no changes except for
7036 -- resetting the overflow flag, since we are done with overflow
7037 -- checks for this node. We will reexpand to get the needed
7038 -- expansion for the case expression, but we do not need to
7039 -- reanalyze, since nothing has changed.
7041 if not (Bignum_Operands
or Long_Long_Integer_Operands
) then
7042 Set_Do_Overflow_Check
(N
, False);
7043 Reexpand
(Suppress
=> True);
7045 -- Otherwise we are going to rebuild the case expression using
7046 -- either bignum or long long integer operands throughout.
7055 New_Alts
:= New_List
;
7056 Alt
:= First
(Alternatives
(N
));
7057 while Present
(Alt
) loop
7058 if Bignum_Operands
then
7059 New_Exp
:= Convert_To_Bignum
(Expression
(Alt
));
7060 Rtype
:= RTE
(RE_Bignum
);
7062 New_Exp
:= Convert_To
(LLIB
, Expression
(Alt
));
7066 Append_To
(New_Alts
,
7067 Make_Case_Expression_Alternative
(Sloc
(Alt
),
7069 Discrete_Choices
=> Discrete_Choices
(Alt
),
7070 Expression
=> New_Exp
));
7076 Make_Case_Expression
(Loc
,
7077 Expression
=> Expression
(N
),
7078 Alternatives
=> New_Alts
));
7080 Reanalyze
(Rtype
, Suppress
=> True);
7088 -- If we have an arithmetic operator we make recursive calls on the
7089 -- operands to get the ranges (and to properly process the subtree
7090 -- that lies below us!)
7092 Minimize_Eliminate_Overflows
7093 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
7096 Minimize_Eliminate_Overflows
7097 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
7100 -- Record if we have Long_Long_Integer operands
7102 Long_Long_Integer_Operands
:=
7103 Etype
(Right_Opnd
(N
)) = LLIB
7104 or else (Binary
and then Etype
(Left_Opnd
(N
)) = LLIB
);
7106 -- If either operand is a bignum, then result will be a bignum and we
7107 -- don't need to do any range analysis. As previously discussed we could
7108 -- do range analysis in such cases, but it could mean working with giant
7109 -- numbers at compile time for very little gain (the number of cases
7110 -- in which we could slip back from bignum mode is small).
7112 if Rlo
= No_Uint
or else (Binary
and then Llo
= No_Uint
) then
7115 Bignum_Operands
:= True;
7117 -- Otherwise compute result range
7120 Bignum_Operands
:= False;
7128 Hi
:= UI_Max
(abs Rlo
, abs Rhi
);
7140 -- If the right operand can only be zero, set 0..0
7142 if Rlo
= 0 and then Rhi
= 0 then
7146 -- Possible bounds of division must come from dividing end
7147 -- values of the input ranges (four possibilities), provided
7148 -- zero is not included in the possible values of the right
7151 -- Otherwise, we just consider two intervals of values for
7152 -- the right operand: the interval of negative values (up to
7153 -- -1) and the interval of positive values (starting at 1).
7154 -- Since division by 1 is the identity, and division by -1
7155 -- is negation, we get all possible bounds of division in that
7156 -- case by considering:
7157 -- - all values from the division of end values of input
7159 -- - the end values of the left operand;
7160 -- - the negation of the end values of the left operand.
7164 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
7165 -- Mark so we can release the RR and Ev values
7173 -- Discard extreme values of zero for the divisor, since
7174 -- they will simply result in an exception in any case.
7182 -- Compute possible bounds coming from dividing end
7183 -- values of the input ranges.
7190 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
7191 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
7193 -- If the right operand can be both negative or positive,
7194 -- include the end values of the left operand in the
7195 -- extreme values, as well as their negation.
7197 if Rlo
< 0 and then Rhi
> 0 then
7204 UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
)));
7206 UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
)));
7209 -- Release the RR and Ev values
7211 Release_And_Save
(Mrk
, Lo
, Hi
);
7219 -- Discard negative values for the exponent, since they will
7220 -- simply result in an exception in any case.
7228 -- Estimate number of bits in result before we go computing
7229 -- giant useless bounds. Basically the number of bits in the
7230 -- result is the number of bits in the base multiplied by the
7231 -- value of the exponent. If this is big enough that the result
7232 -- definitely won't fit in Long_Long_Integer, switch to bignum
7233 -- mode immediately, and avoid computing giant bounds.
7235 -- The comparison here is approximate, but conservative, it
7236 -- only clicks on cases that are sure to exceed the bounds.
7238 if Num_Bits
(UI_Max
(abs Llo
, abs Lhi
)) * Rhi
+ 1 > 100 then
7242 -- If right operand is zero then result is 1
7249 -- High bound comes either from exponentiation of largest
7250 -- positive value to largest exponent value, or from
7251 -- the exponentiation of most negative value to an
7265 if Rhi
mod 2 = 0 then
7268 Hi2
:= Llo
** (Rhi
- 1);
7274 Hi
:= UI_Max
(Hi1
, Hi2
);
7277 -- Result can only be negative if base can be negative
7280 if Rhi
mod 2 = 0 then
7281 Lo
:= Llo
** (Rhi
- 1);
7286 -- Otherwise low bound is minimum ** minimum
7303 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
7304 -- This is the maximum absolute value of the result
7310 -- The result depends only on the sign and magnitude of
7311 -- the right operand, it does not depend on the sign or
7312 -- magnitude of the left operand.
7325 when N_Op_Multiply
=>
7327 -- Possible bounds of multiplication must come from multiplying
7328 -- end values of the input ranges (four possibilities).
7331 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
7332 -- Mark so we can release the Ev values
7334 Ev1
: constant Uint
:= Llo
* Rlo
;
7335 Ev2
: constant Uint
:= Llo
* Rhi
;
7336 Ev3
: constant Uint
:= Lhi
* Rlo
;
7337 Ev4
: constant Uint
:= Lhi
* Rhi
;
7340 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
7341 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
7343 -- Release the Ev values
7345 Release_And_Save
(Mrk
, Lo
, Hi
);
7348 -- Plus operator (affirmation)
7358 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
7359 -- This is the maximum absolute value of the result. Note
7360 -- that the result range does not depend on the sign of the
7367 -- Case of left operand negative, which results in a range
7368 -- of -Maxabs .. 0 for those negative values. If there are
7369 -- no negative values then Lo value of result is always 0.
7375 -- Case of left operand positive
7384 when N_Op_Subtract
=>
7388 -- Nothing else should be possible
7391 raise Program_Error
;
7395 -- Here for the case where we have not rewritten anything (no bignum
7396 -- operands or long long integer operands), and we know the result.
7397 -- If we know we are in the result range, and we do not have Bignum
7398 -- operands or Long_Long_Integer operands, we can just reexpand with
7399 -- overflow checks turned off (since we know we cannot have overflow).
7400 -- As always the reexpansion is required to complete expansion of the
7401 -- operator, but we do not need to reanalyze, and we prevent recursion
7402 -- by suppressing the check.
7404 if not (Bignum_Operands
or Long_Long_Integer_Operands
)
7405 and then In_Result_Range
7407 Set_Do_Overflow_Check
(N
, False);
7408 Reexpand
(Suppress
=> True);
7411 -- Here we know that we are not in the result range, and in the general
7412 -- case we will move into either the Bignum or Long_Long_Integer domain
7413 -- to compute the result. However, there is one exception. If we are
7414 -- at the top level, and we do not have Bignum or Long_Long_Integer
7415 -- operands, we will have to immediately convert the result back to
7416 -- the result type, so there is no point in Bignum/Long_Long_Integer
7420 and then not (Bignum_Operands
or Long_Long_Integer_Operands
)
7422 -- One further refinement. If we are at the top level, but our parent
7423 -- is a type conversion, then go into bignum or long long integer node
7424 -- since the result will be converted to that type directly without
7425 -- going through the result type, and we may avoid an overflow. This
7426 -- is the case for example of Long_Long_Integer (A ** 4), where A is
7427 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
7428 -- but does not fit in Integer.
7430 and then Nkind
(Parent
(N
)) /= N_Type_Conversion
7432 -- Here keep original types, but we need to complete analysis
7434 -- One subtlety. We can't just go ahead and do an analyze operation
7435 -- here because it will cause recursion into the whole MINIMIZED/
7436 -- ELIMINATED overflow processing which is not what we want. Here
7437 -- we are at the top level, and we need a check against the result
7438 -- mode (i.e. we want to use STRICT mode). So do exactly that!
7439 -- Also, we have not modified the node, so this is a case where
7440 -- we need to reexpand, but not reanalyze.
7445 -- Cases where we do the operation in Bignum mode. This happens either
7446 -- because one of our operands is in Bignum mode already, or because
7447 -- the computed bounds are outside the bounds of Long_Long_Integer,
7448 -- which in some cases can be indicated by Hi and Lo being No_Uint.
7450 -- Note: we could do better here and in some cases switch back from
7451 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
7452 -- 0 .. 1, but the cases are rare and it is not worth the effort.
7453 -- Failing to do this switching back is only an efficiency issue.
7455 elsif Lo
= No_Uint
or else Lo
< LLLo
or else Hi
> LLHi
then
7457 -- OK, we are definitely outside the range of Long_Long_Integer. The
7458 -- question is whether to move to Bignum mode, or stay in the domain
7459 -- of Long_Long_Integer, signalling that an overflow check is needed.
7461 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
7462 -- the Bignum business. In ELIMINATED mode, we will normally move
7463 -- into Bignum mode, but there is an exception if neither of our
7464 -- operands is Bignum now, and we are at the top level (Top_Level
7465 -- set True). In this case, there is no point in moving into Bignum
7466 -- mode to prevent overflow if the caller will immediately convert
7467 -- the Bignum value back to LLI with an overflow check. It's more
7468 -- efficient to stay in LLI mode with an overflow check (if needed)
7470 if Check_Mode
= Minimized
7471 or else (Top_Level
and not Bignum_Operands
)
7473 if Do_Overflow_Check
(N
) then
7474 Enable_Overflow_Check
(N
);
7477 -- The result now has to be in Long_Long_Integer mode, so adjust
7478 -- the possible range to reflect this. Note these calls also
7479 -- change No_Uint values from the top level case to LLI bounds.
7484 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
7487 pragma Assert
(Check_Mode
= Eliminated
);
7496 Fent
:= RTE
(RE_Big_Abs
);
7499 Fent
:= RTE
(RE_Big_Add
);
7502 Fent
:= RTE
(RE_Big_Div
);
7505 Fent
:= RTE
(RE_Big_Exp
);
7508 Fent
:= RTE
(RE_Big_Neg
);
7511 Fent
:= RTE
(RE_Big_Mod
);
7513 when N_Op_Multiply
=>
7514 Fent
:= RTE
(RE_Big_Mul
);
7517 Fent
:= RTE
(RE_Big_Rem
);
7519 when N_Op_Subtract
=>
7520 Fent
:= RTE
(RE_Big_Sub
);
7522 -- Anything else is an internal error, this includes the
7523 -- N_Op_Plus case, since how can plus cause the result
7524 -- to be out of range if the operand is in range?
7527 raise Program_Error
;
7530 -- Construct argument list for Bignum call, converting our
7531 -- operands to Bignum form if they are not already there.
7536 Append_To
(Args
, Convert_To_Bignum
(Left_Opnd
(N
)));
7539 Append_To
(Args
, Convert_To_Bignum
(Right_Opnd
(N
)));
7541 -- Now rewrite the arithmetic operator with a call to the
7542 -- corresponding bignum function.
7545 Make_Function_Call
(Loc
,
7546 Name
=> New_Occurrence_Of
(Fent
, Loc
),
7547 Parameter_Associations
=> Args
));
7548 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
7550 -- Indicate result is Bignum mode
7558 -- Otherwise we are in range of Long_Long_Integer, so no overflow
7559 -- check is required, at least not yet.
7562 Set_Do_Overflow_Check
(N
, False);
7565 -- Here we are not in Bignum territory, but we may have long long
7566 -- integer operands that need special handling. First a special check:
7567 -- If an exponentiation operator exponent is of type Long_Long_Integer,
7568 -- it means we converted it to prevent overflow, but exponentiation
7569 -- requires a Natural right operand, so convert it back to Natural.
7570 -- This conversion may raise an exception which is fine.
7572 if Nkind
(N
) = N_Op_Expon
and then Etype
(Right_Opnd
(N
)) = LLIB
then
7573 Convert_To_And_Rewrite
(Standard_Natural
, Right_Opnd
(N
));
7576 -- Here we will do the operation in Long_Long_Integer. We do this even
7577 -- if we know an overflow check is required, better to do this in long
7578 -- long integer mode, since we are less likely to overflow!
7580 -- Convert right or only operand to Long_Long_Integer, except that
7581 -- we do not touch the exponentiation right operand.
7583 if Nkind
(N
) /= N_Op_Expon
then
7584 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
7587 -- Convert left operand to Long_Long_Integer for binary case
7590 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
7593 -- Reset node to unanalyzed
7595 Set_Analyzed
(N
, False);
7596 Set_Etype
(N
, Empty
);
7597 Set_Entity
(N
, Empty
);
7599 -- Now analyze this new node. This reanalysis will complete processing
7600 -- for the node. In particular we will complete the expansion of an
7601 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
7602 -- we will complete any division checks (since we have not changed the
7603 -- setting of the Do_Division_Check flag).
7605 -- We do this reanalysis in STRICT mode to avoid recursion into the
7606 -- MINIMIZED/ELIMINATED handling, since we are now done with that!
7609 SG
: constant Overflow_Check_Type
:=
7610 Scope_Suppress
.Overflow_Checks_General
;
7611 SA
: constant Overflow_Check_Type
:=
7612 Scope_Suppress
.Overflow_Checks_Assertions
;
7615 Scope_Suppress
.Overflow_Checks_General
:= Strict
;
7616 Scope_Suppress
.Overflow_Checks_Assertions
:= Strict
;
7618 if not Do_Overflow_Check
(N
) then
7619 Reanalyze
(LLIB
, Suppress
=> True);
7624 Scope_Suppress
.Overflow_Checks_General
:= SG
;
7625 Scope_Suppress
.Overflow_Checks_Assertions
:= SA
;
7627 end Minimize_Eliminate_Overflows
;
7629 -------------------------
7630 -- Overflow_Check_Mode --
7631 -------------------------
7633 function Overflow_Check_Mode
return Overflow_Check_Type
is
7635 if In_Assertion_Expr
= 0 then
7636 return Scope_Suppress
.Overflow_Checks_General
;
7638 return Scope_Suppress
.Overflow_Checks_Assertions
;
7640 end Overflow_Check_Mode
;
7642 --------------------------------
7643 -- Overflow_Checks_Suppressed --
7644 --------------------------------
7646 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7648 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7649 return Is_Check_Suppressed
(E
, Overflow_Check
);
7651 return Scope_Suppress
.Suppress
(Overflow_Check
);
7653 end Overflow_Checks_Suppressed
;
7655 -----------------------------
7656 -- Range_Checks_Suppressed --
7657 -----------------------------
7659 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7663 -- Note: for now we always suppress range checks on Vax float types,
7664 -- since Gigi does not know how to generate these checks.
7666 if Vax_Float
(E
) then
7668 elsif Kill_Range_Checks
(E
) then
7670 elsif Checks_May_Be_Suppressed
(E
) then
7671 return Is_Check_Suppressed
(E
, Range_Check
);
7675 return Scope_Suppress
.Suppress
(Range_Check
);
7676 end Range_Checks_Suppressed
;
7678 -----------------------------------------
7679 -- Range_Or_Validity_Checks_Suppressed --
7680 -----------------------------------------
7682 -- Note: the coding would be simpler here if we simply made appropriate
7683 -- calls to Range/Validity_Checks_Suppressed, but that would result in
7684 -- duplicated checks which we prefer to avoid.
7686 function Range_Or_Validity_Checks_Suppressed
7687 (Expr
: Node_Id
) return Boolean
7690 -- Immediate return if scope checks suppressed for either check
7692 if Scope_Suppress
.Suppress
(Range_Check
)
7694 Scope_Suppress
.Suppress
(Validity_Check
)
7699 -- If no expression, that's odd, decide that checks are suppressed,
7700 -- since we don't want anyone trying to do checks in this case, which
7701 -- is most likely the result of some other error.
7707 -- Expression is present, so perform suppress checks on type
7710 Typ
: constant Entity_Id
:= Etype
(Expr
);
7712 if Vax_Float
(Typ
) then
7714 elsif Checks_May_Be_Suppressed
(Typ
)
7715 and then (Is_Check_Suppressed
(Typ
, Range_Check
)
7717 Is_Check_Suppressed
(Typ
, Validity_Check
))
7723 -- If expression is an entity name, perform checks on this entity
7725 if Is_Entity_Name
(Expr
) then
7727 Ent
: constant Entity_Id
:= Entity
(Expr
);
7729 if Checks_May_Be_Suppressed
(Ent
) then
7730 return Is_Check_Suppressed
(Ent
, Range_Check
)
7731 or else Is_Check_Suppressed
(Ent
, Validity_Check
);
7736 -- If we fall through, no checks suppressed
7739 end Range_Or_Validity_Checks_Suppressed
;
7745 procedure Remove_Checks
(Expr
: Node_Id
) is
7746 function Process
(N
: Node_Id
) return Traverse_Result
;
7747 -- Process a single node during the traversal
7749 procedure Traverse
is new Traverse_Proc
(Process
);
7750 -- The traversal procedure itself
7756 function Process
(N
: Node_Id
) return Traverse_Result
is
7758 if Nkind
(N
) not in N_Subexpr
then
7762 Set_Do_Range_Check
(N
, False);
7766 Traverse
(Left_Opnd
(N
));
7769 when N_Attribute_Reference
=>
7770 Set_Do_Overflow_Check
(N
, False);
7772 when N_Function_Call
=>
7773 Set_Do_Tag_Check
(N
, False);
7776 Set_Do_Overflow_Check
(N
, False);
7780 Set_Do_Division_Check
(N
, False);
7783 Set_Do_Length_Check
(N
, False);
7786 Set_Do_Division_Check
(N
, False);
7789 Set_Do_Length_Check
(N
, False);
7792 Set_Do_Division_Check
(N
, False);
7795 Set_Do_Length_Check
(N
, False);
7802 Traverse
(Left_Opnd
(N
));
7805 when N_Selected_Component
=>
7806 Set_Do_Discriminant_Check
(N
, False);
7808 when N_Type_Conversion
=>
7809 Set_Do_Length_Check
(N
, False);
7810 Set_Do_Tag_Check
(N
, False);
7811 Set_Do_Overflow_Check
(N
, False);
7820 -- Start of processing for Remove_Checks
7826 ----------------------------
7827 -- Selected_Length_Checks --
7828 ----------------------------
7830 function Selected_Length_Checks
7832 Target_Typ
: Entity_Id
;
7833 Source_Typ
: Entity_Id
;
7834 Warn_Node
: Node_Id
) return Check_Result
7836 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
7839 Expr_Actual
: Node_Id
;
7841 Cond
: Node_Id
:= Empty
;
7842 Do_Access
: Boolean := False;
7843 Wnode
: Node_Id
:= Warn_Node
;
7844 Ret_Result
: Check_Result
:= (Empty
, Empty
);
7845 Num_Checks
: Natural := 0;
7847 procedure Add_Check
(N
: Node_Id
);
7848 -- Adds the action given to Ret_Result if N is non-Empty
7850 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
7851 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
7852 -- Comments required ???
7854 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
7855 -- True for equal literals and for nodes that denote the same constant
7856 -- entity, even if its value is not a static constant. This includes the
7857 -- case of a discriminal reference within an init proc. Removes some
7858 -- obviously superfluous checks.
7860 function Length_E_Cond
7861 (Exptyp
: Entity_Id
;
7863 Indx
: Nat
) return Node_Id
;
7864 -- Returns expression to compute:
7865 -- Typ'Length /= Exptyp'Length
7867 function Length_N_Cond
7870 Indx
: Nat
) return Node_Id
;
7871 -- Returns expression to compute:
7872 -- Typ'Length /= Expr'Length
7878 procedure Add_Check
(N
: Node_Id
) is
7882 -- For now, ignore attempt to place more than 2 checks ???
7884 if Num_Checks
= 2 then
7888 pragma Assert
(Num_Checks
<= 1);
7889 Num_Checks
:= Num_Checks
+ 1;
7890 Ret_Result
(Num_Checks
) := N
;
7898 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
7899 SE
: constant Entity_Id
:= Scope
(E
);
7901 E1
: Entity_Id
:= E
;
7904 if Ekind
(Scope
(E
)) = E_Record_Type
7905 and then Has_Discriminants
(Scope
(E
))
7907 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
7910 Insert_Action
(Ck_Node
, N
);
7911 E1
:= Defining_Identifier
(N
);
7915 if Ekind
(E1
) = E_String_Literal_Subtype
then
7917 Make_Integer_Literal
(Loc
,
7918 Intval
=> String_Literal_Length
(E1
));
7920 elsif SE
/= Standard_Standard
7921 and then Ekind
(Scope
(SE
)) = E_Protected_Type
7922 and then Has_Discriminants
(Scope
(SE
))
7923 and then Has_Completion
(Scope
(SE
))
7924 and then not Inside_Init_Proc
7926 -- If the type whose length is needed is a private component
7927 -- constrained by a discriminant, we must expand the 'Length
7928 -- attribute into an explicit computation, using the discriminal
7929 -- of the current protected operation. This is because the actual
7930 -- type of the prival is constructed after the protected opera-
7931 -- tion has been fully expanded.
7934 Indx_Type
: Node_Id
;
7937 Do_Expand
: Boolean := False;
7940 Indx_Type
:= First_Index
(E
);
7942 for J
in 1 .. Indx
- 1 loop
7943 Next_Index
(Indx_Type
);
7946 Get_Index_Bounds
(Indx_Type
, Lo
, Hi
);
7948 if Nkind
(Lo
) = N_Identifier
7949 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
7951 Lo
:= Get_Discriminal
(E
, Lo
);
7955 if Nkind
(Hi
) = N_Identifier
7956 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
7958 Hi
:= Get_Discriminal
(E
, Hi
);
7963 if not Is_Entity_Name
(Lo
) then
7964 Lo
:= Duplicate_Subexpr_No_Checks
(Lo
);
7967 if not Is_Entity_Name
(Hi
) then
7968 Lo
:= Duplicate_Subexpr_No_Checks
(Hi
);
7974 Make_Op_Subtract
(Loc
,
7978 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
7983 Make_Attribute_Reference
(Loc
,
7984 Attribute_Name
=> Name_Length
,
7986 New_Occurrence_Of
(E1
, Loc
));
7989 Set_Expressions
(N
, New_List
(
7990 Make_Integer_Literal
(Loc
, Indx
)));
7999 Make_Attribute_Reference
(Loc
,
8000 Attribute_Name
=> Name_Length
,
8002 New_Occurrence_Of
(E1
, Loc
));
8005 Set_Expressions
(N
, New_List
(
8006 Make_Integer_Literal
(Loc
, Indx
)));
8017 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8020 Make_Attribute_Reference
(Loc
,
8021 Attribute_Name
=> Name_Length
,
8023 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8024 Expressions
=> New_List
(
8025 Make_Integer_Literal
(Loc
, Indx
)));
8032 function Length_E_Cond
8033 (Exptyp
: Entity_Id
;
8035 Indx
: Nat
) return Node_Id
8040 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8041 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
8048 function Length_N_Cond
8051 Indx
: Nat
) return Node_Id
8056 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8057 Right_Opnd
=> Get_N_Length
(Expr
, Indx
));
8064 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
8067 (Nkind
(L
) = N_Integer_Literal
8068 and then Nkind
(R
) = N_Integer_Literal
8069 and then Intval
(L
) = Intval
(R
))
8073 and then Ekind
(Entity
(L
)) = E_Constant
8074 and then ((Is_Entity_Name
(R
)
8075 and then Entity
(L
) = Entity
(R
))
8077 (Nkind
(R
) = N_Type_Conversion
8078 and then Is_Entity_Name
(Expression
(R
))
8079 and then Entity
(L
) = Entity
(Expression
(R
)))))
8083 and then Ekind
(Entity
(R
)) = E_Constant
8084 and then Nkind
(L
) = N_Type_Conversion
8085 and then Is_Entity_Name
(Expression
(L
))
8086 and then Entity
(R
) = Entity
(Expression
(L
)))
8090 and then Is_Entity_Name
(R
)
8091 and then Entity
(L
) = Entity
(R
)
8092 and then Ekind
(Entity
(L
)) = E_In_Parameter
8093 and then Inside_Init_Proc
);
8096 -- Start of processing for Selected_Length_Checks
8099 if not Full_Expander_Active
then
8103 if Target_Typ
= Any_Type
8104 or else Target_Typ
= Any_Composite
8105 or else Raises_Constraint_Error
(Ck_Node
)
8114 T_Typ
:= Target_Typ
;
8116 if No
(Source_Typ
) then
8117 S_Typ
:= Etype
(Ck_Node
);
8119 S_Typ
:= Source_Typ
;
8122 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
8126 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
8127 S_Typ
:= Designated_Type
(S_Typ
);
8128 T_Typ
:= Designated_Type
(T_Typ
);
8131 -- A simple optimization for the null case
8133 if Known_Null
(Ck_Node
) then
8138 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
8139 if Is_Constrained
(T_Typ
) then
8141 -- The checking code to be generated will freeze the corresponding
8142 -- array type. However, we must freeze the type now, so that the
8143 -- freeze node does not appear within the generated if expression,
8146 Freeze_Before
(Ck_Node
, T_Typ
);
8148 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
8149 Exptyp
:= Get_Actual_Subtype
(Ck_Node
);
8151 if Is_Access_Type
(Exptyp
) then
8152 Exptyp
:= Designated_Type
(Exptyp
);
8155 -- String_Literal case. This needs to be handled specially be-
8156 -- cause no index types are available for string literals. The
8157 -- condition is simply:
8159 -- T_Typ'Length = string-literal-length
8161 if Nkind
(Expr_Actual
) = N_String_Literal
8162 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
8166 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
8168 Make_Integer_Literal
(Loc
,
8170 String_Literal_Length
(Etype
(Expr_Actual
))));
8172 -- General array case. Here we have a usable actual subtype for
8173 -- the expression, and the condition is built from the two types
8176 -- T_Typ'Length /= Exptyp'Length or else
8177 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
8178 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
8181 elsif Is_Constrained
(Exptyp
) then
8183 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
8196 -- At the library level, we need to ensure that the type of
8197 -- the object is elaborated before the check itself is
8198 -- emitted. This is only done if the object is in the
8199 -- current compilation unit, otherwise the type is frozen
8200 -- and elaborated in its unit.
8202 if Is_Itype
(Exptyp
)
8204 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
8206 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
8207 and then In_Open_Scopes
(Scope
(Exptyp
))
8209 Ref_Node
:= Make_Itype_Reference
(Sloc
(Ck_Node
));
8210 Set_Itype
(Ref_Node
, Exptyp
);
8211 Insert_Action
(Ck_Node
, Ref_Node
);
8214 L_Index
:= First_Index
(T_Typ
);
8215 R_Index
:= First_Index
(Exptyp
);
8217 for Indx
in 1 .. Ndims
loop
8218 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
8220 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
8222 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
8223 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
8225 -- Deal with compile time length check. Note that we
8226 -- skip this in the access case, because the access
8227 -- value may be null, so we cannot know statically.
8230 and then Compile_Time_Known_Value
(L_Low
)
8231 and then Compile_Time_Known_Value
(L_High
)
8232 and then Compile_Time_Known_Value
(R_Low
)
8233 and then Compile_Time_Known_Value
(R_High
)
8235 if Expr_Value
(L_High
) >= Expr_Value
(L_Low
) then
8236 L_Length
:= Expr_Value
(L_High
) -
8237 Expr_Value
(L_Low
) + 1;
8239 L_Length
:= UI_From_Int
(0);
8242 if Expr_Value
(R_High
) >= Expr_Value
(R_Low
) then
8243 R_Length
:= Expr_Value
(R_High
) -
8244 Expr_Value
(R_Low
) + 1;
8246 R_Length
:= UI_From_Int
(0);
8249 if L_Length
> R_Length
then
8251 (Compile_Time_Constraint_Error
8252 (Wnode
, "too few elements for}?", T_Typ
));
8254 elsif L_Length
< R_Length
then
8256 (Compile_Time_Constraint_Error
8257 (Wnode
, "too many elements for}?", T_Typ
));
8260 -- The comparison for an individual index subtype
8261 -- is omitted if the corresponding index subtypes
8262 -- statically match, since the result is known to
8263 -- be true. Note that this test is worth while even
8264 -- though we do static evaluation, because non-static
8265 -- subtypes can statically match.
8268 Subtypes_Statically_Match
8269 (Etype
(L_Index
), Etype
(R_Index
))
8272 (Same_Bounds
(L_Low
, R_Low
)
8273 and then Same_Bounds
(L_High
, R_High
))
8276 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
8285 -- Handle cases where we do not get a usable actual subtype that
8286 -- is constrained. This happens for example in the function call
8287 -- and explicit dereference cases. In these cases, we have to get
8288 -- the length or range from the expression itself, making sure we
8289 -- do not evaluate it more than once.
8291 -- Here Ck_Node is the original expression, or more properly the
8292 -- result of applying Duplicate_Expr to the original tree, forcing
8293 -- the result to be a name.
8297 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
8300 -- Build the condition for the explicit dereference case
8302 for Indx
in 1 .. Ndims
loop
8304 (Cond
, Length_N_Cond
(Ck_Node
, T_Typ
, Indx
));
8311 -- Construct the test and insert into the tree
8313 if Present
(Cond
) then
8315 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
8319 (Make_Raise_Constraint_Error
(Loc
,
8321 Reason
=> CE_Length_Check_Failed
));
8325 end Selected_Length_Checks
;
8327 ---------------------------
8328 -- Selected_Range_Checks --
8329 ---------------------------
8331 function Selected_Range_Checks
8333 Target_Typ
: Entity_Id
;
8334 Source_Typ
: Entity_Id
;
8335 Warn_Node
: Node_Id
) return Check_Result
8337 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
8340 Expr_Actual
: Node_Id
;
8342 Cond
: Node_Id
:= Empty
;
8343 Do_Access
: Boolean := False;
8344 Wnode
: Node_Id
:= Warn_Node
;
8345 Ret_Result
: Check_Result
:= (Empty
, Empty
);
8346 Num_Checks
: Integer := 0;
8348 procedure Add_Check
(N
: Node_Id
);
8349 -- Adds the action given to Ret_Result if N is non-Empty
8351 function Discrete_Range_Cond
8353 Typ
: Entity_Id
) return Node_Id
;
8354 -- Returns expression to compute:
8355 -- Low_Bound (Expr) < Typ'First
8357 -- High_Bound (Expr) > Typ'Last
8359 function Discrete_Expr_Cond
8361 Typ
: Entity_Id
) return Node_Id
;
8362 -- Returns expression to compute:
8367 function Get_E_First_Or_Last
8371 Nam
: Name_Id
) return Node_Id
;
8372 -- Returns an attribute reference
8373 -- E'First or E'Last
8374 -- with a source location of Loc.
8376 -- Nam is Name_First or Name_Last, according to which attribute is
8377 -- desired. If Indx is non-zero, it is passed as a literal in the
8378 -- Expressions of the attribute reference (identifying the desired
8379 -- array dimension).
8381 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8382 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8383 -- Returns expression to compute:
8384 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
8386 function Range_E_Cond
8387 (Exptyp
: Entity_Id
;
8391 -- Returns expression to compute:
8392 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
8394 function Range_Equal_E_Cond
8395 (Exptyp
: Entity_Id
;
8397 Indx
: Nat
) return Node_Id
;
8398 -- Returns expression to compute:
8399 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
8401 function Range_N_Cond
8404 Indx
: Nat
) return Node_Id
;
8405 -- Return expression to compute:
8406 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
8412 procedure Add_Check
(N
: Node_Id
) is
8416 -- For now, ignore attempt to place more than 2 checks ???
8418 if Num_Checks
= 2 then
8422 pragma Assert
(Num_Checks
<= 1);
8423 Num_Checks
:= Num_Checks
+ 1;
8424 Ret_Result
(Num_Checks
) := N
;
8428 -------------------------
8429 -- Discrete_Expr_Cond --
8430 -------------------------
8432 function Discrete_Expr_Cond
8434 Typ
: Entity_Id
) return Node_Id
8442 Convert_To
(Base_Type
(Typ
),
8443 Duplicate_Subexpr_No_Checks
(Expr
)),
8445 Convert_To
(Base_Type
(Typ
),
8446 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
))),
8451 Convert_To
(Base_Type
(Typ
),
8452 Duplicate_Subexpr_No_Checks
(Expr
)),
8456 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
))));
8457 end Discrete_Expr_Cond
;
8459 -------------------------
8460 -- Discrete_Range_Cond --
8461 -------------------------
8463 function Discrete_Range_Cond
8465 Typ
: Entity_Id
) return Node_Id
8467 LB
: Node_Id
:= Low_Bound
(Expr
);
8468 HB
: Node_Id
:= High_Bound
(Expr
);
8470 Left_Opnd
: Node_Id
;
8471 Right_Opnd
: Node_Id
;
8474 if Nkind
(LB
) = N_Identifier
8475 and then Ekind
(Entity
(LB
)) = E_Discriminant
8477 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
8484 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
8489 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
)));
8491 if Nkind
(HB
) = N_Identifier
8492 and then Ekind
(Entity
(HB
)) = E_Discriminant
8494 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
8501 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
8506 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
)));
8508 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
8509 end Discrete_Range_Cond
;
8511 -------------------------
8512 -- Get_E_First_Or_Last --
8513 -------------------------
8515 function Get_E_First_Or_Last
8519 Nam
: Name_Id
) return Node_Id
8524 Exprs
:= New_List
(Make_Integer_Literal
(Loc
, UI_From_Int
(Indx
)));
8529 return Make_Attribute_Reference
(Loc
,
8530 Prefix
=> New_Occurrence_Of
(E
, Loc
),
8531 Attribute_Name
=> Nam
,
8532 Expressions
=> Exprs
);
8533 end Get_E_First_Or_Last
;
8539 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8542 Make_Attribute_Reference
(Loc
,
8543 Attribute_Name
=> Name_First
,
8545 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8546 Expressions
=> New_List
(
8547 Make_Integer_Literal
(Loc
, Indx
)));
8554 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8557 Make_Attribute_Reference
(Loc
,
8558 Attribute_Name
=> Name_Last
,
8560 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8561 Expressions
=> New_List
(
8562 Make_Integer_Literal
(Loc
, Indx
)));
8569 function Range_E_Cond
8570 (Exptyp
: Entity_Id
;
8572 Indx
: Nat
) return Node_Id
8580 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
8582 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8587 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
8589 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8592 ------------------------
8593 -- Range_Equal_E_Cond --
8594 ------------------------
8596 function Range_Equal_E_Cond
8597 (Exptyp
: Entity_Id
;
8599 Indx
: Nat
) return Node_Id
8607 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
8609 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8614 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
8616 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8617 end Range_Equal_E_Cond
;
8623 function Range_N_Cond
8626 Indx
: Nat
) return Node_Id
8634 Get_N_First
(Expr
, Indx
),
8636 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8641 Get_N_Last
(Expr
, Indx
),
8643 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8646 -- Start of processing for Selected_Range_Checks
8649 if not Full_Expander_Active
then
8653 if Target_Typ
= Any_Type
8654 or else Target_Typ
= Any_Composite
8655 or else Raises_Constraint_Error
(Ck_Node
)
8664 T_Typ
:= Target_Typ
;
8666 if No
(Source_Typ
) then
8667 S_Typ
:= Etype
(Ck_Node
);
8669 S_Typ
:= Source_Typ
;
8672 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
8676 -- The order of evaluating T_Typ before S_Typ seems to be critical
8677 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
8678 -- in, and since Node can be an N_Range node, it might be invalid.
8679 -- Should there be an assert check somewhere for taking the Etype of
8680 -- an N_Range node ???
8682 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
8683 S_Typ
:= Designated_Type
(S_Typ
);
8684 T_Typ
:= Designated_Type
(T_Typ
);
8687 -- A simple optimization for the null case
8689 if Known_Null
(Ck_Node
) then
8694 -- For an N_Range Node, check for a null range and then if not
8695 -- null generate a range check action.
8697 if Nkind
(Ck_Node
) = N_Range
then
8699 -- There's no point in checking a range against itself
8701 if Ck_Node
= Scalar_Range
(T_Typ
) then
8706 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
8707 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
8708 Known_T_LB
: constant Boolean := Compile_Time_Known_Value
(T_LB
);
8709 Known_T_HB
: constant Boolean := Compile_Time_Known_Value
(T_HB
);
8711 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
8712 HB
: Node_Id
:= High_Bound
(Ck_Node
);
8716 Null_Range
: Boolean;
8717 Out_Of_Range_L
: Boolean;
8718 Out_Of_Range_H
: Boolean;
8721 -- Compute what is known at compile time
8723 if Known_T_LB
and Known_T_HB
then
8724 if Compile_Time_Known_Value
(LB
) then
8727 -- There's no point in checking that a bound is within its
8728 -- own range so pretend that it is known in this case. First
8729 -- deal with low bound.
8731 elsif Ekind
(Etype
(LB
)) = E_Signed_Integer_Subtype
8732 and then Scalar_Range
(Etype
(LB
)) = Scalar_Range
(T_Typ
)
8741 -- Likewise for the high bound
8743 if Compile_Time_Known_Value
(HB
) then
8746 elsif Ekind
(Etype
(HB
)) = E_Signed_Integer_Subtype
8747 and then Scalar_Range
(Etype
(HB
)) = Scalar_Range
(T_Typ
)
8757 -- Check for case where everything is static and we can do the
8758 -- check at compile time. This is skipped if we have an access
8759 -- type, since the access value may be null.
8761 -- ??? This code can be improved since you only need to know that
8762 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
8763 -- compile time to emit pertinent messages.
8765 if Known_T_LB
and Known_T_HB
and Known_LB
and Known_HB
8768 -- Floating-point case
8770 if Is_Floating_Point_Type
(S_Typ
) then
8771 Null_Range
:= Expr_Value_R
(HB
) < Expr_Value_R
(LB
);
8773 (Expr_Value_R
(LB
) < Expr_Value_R
(T_LB
))
8775 (Expr_Value_R
(LB
) > Expr_Value_R
(T_HB
));
8778 (Expr_Value_R
(HB
) > Expr_Value_R
(T_HB
))
8780 (Expr_Value_R
(HB
) < Expr_Value_R
(T_LB
));
8782 -- Fixed or discrete type case
8785 Null_Range
:= Expr_Value
(HB
) < Expr_Value
(LB
);
8787 (Expr_Value
(LB
) < Expr_Value
(T_LB
))
8789 (Expr_Value
(LB
) > Expr_Value
(T_HB
));
8792 (Expr_Value
(HB
) > Expr_Value
(T_HB
))
8794 (Expr_Value
(HB
) < Expr_Value
(T_LB
));
8797 if not Null_Range
then
8798 if Out_Of_Range_L
then
8799 if No
(Warn_Node
) then
8801 (Compile_Time_Constraint_Error
8802 (Low_Bound
(Ck_Node
),
8803 "static value out of range of}?", T_Typ
));
8807 (Compile_Time_Constraint_Error
8809 "static range out of bounds of}?", T_Typ
));
8813 if Out_Of_Range_H
then
8814 if No
(Warn_Node
) then
8816 (Compile_Time_Constraint_Error
8817 (High_Bound
(Ck_Node
),
8818 "static value out of range of}?", T_Typ
));
8822 (Compile_Time_Constraint_Error
8824 "static range out of bounds of}?", T_Typ
));
8831 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
8832 HB
: Node_Id
:= High_Bound
(Ck_Node
);
8835 -- If either bound is a discriminant and we are within the
8836 -- record declaration, it is a use of the discriminant in a
8837 -- constraint of a component, and nothing can be checked
8838 -- here. The check will be emitted within the init proc.
8839 -- Before then, the discriminal has no real meaning.
8840 -- Similarly, if the entity is a discriminal, there is no
8841 -- check to perform yet.
8843 -- The same holds within a discriminated synchronized type,
8844 -- where the discriminant may constrain a component or an
8847 if Nkind
(LB
) = N_Identifier
8848 and then Denotes_Discriminant
(LB
, True)
8850 if Current_Scope
= Scope
(Entity
(LB
))
8851 or else Is_Concurrent_Type
(Current_Scope
)
8852 or else Ekind
(Entity
(LB
)) /= E_Discriminant
8857 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
8861 if Nkind
(HB
) = N_Identifier
8862 and then Denotes_Discriminant
(HB
, True)
8864 if Current_Scope
= Scope
(Entity
(HB
))
8865 or else Is_Concurrent_Type
(Current_Scope
)
8866 or else Ekind
(Entity
(HB
)) /= E_Discriminant
8871 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
8875 Cond
:= Discrete_Range_Cond
(Ck_Node
, T_Typ
);
8876 Set_Paren_Count
(Cond
, 1);
8882 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(HB
),
8883 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(LB
)),
8884 Right_Opnd
=> Cond
);
8889 elsif Is_Scalar_Type
(S_Typ
) then
8891 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
8892 -- except the above simply sets a flag in the node and lets
8893 -- gigi generate the check base on the Etype of the expression.
8894 -- Sometimes, however we want to do a dynamic check against an
8895 -- arbitrary target type, so we do that here.
8897 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
8898 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
8900 -- For literals, we can tell if the constraint error will be
8901 -- raised at compile time, so we never need a dynamic check, but
8902 -- if the exception will be raised, then post the usual warning,
8903 -- and replace the literal with a raise constraint error
8904 -- expression. As usual, skip this for access types
8906 elsif Compile_Time_Known_Value
(Ck_Node
)
8907 and then not Do_Access
8910 LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
8911 UB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
8913 Out_Of_Range
: Boolean;
8914 Static_Bounds
: constant Boolean :=
8915 Compile_Time_Known_Value
(LB
)
8916 and Compile_Time_Known_Value
(UB
);
8919 -- Following range tests should use Sem_Eval routine ???
8921 if Static_Bounds
then
8922 if Is_Floating_Point_Type
(S_Typ
) then
8924 (Expr_Value_R
(Ck_Node
) < Expr_Value_R
(LB
))
8926 (Expr_Value_R
(Ck_Node
) > Expr_Value_R
(UB
));
8928 -- Fixed or discrete type
8932 Expr_Value
(Ck_Node
) < Expr_Value
(LB
)
8934 Expr_Value
(Ck_Node
) > Expr_Value
(UB
);
8937 -- Bounds of the type are static and the literal is out of
8938 -- range so output a warning message.
8940 if Out_Of_Range
then
8941 if No
(Warn_Node
) then
8943 (Compile_Time_Constraint_Error
8945 "static value out of range of}?", T_Typ
));
8949 (Compile_Time_Constraint_Error
8951 "static value out of range of}?", T_Typ
));
8956 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
8960 -- Here for the case of a non-static expression, we need a runtime
8961 -- check unless the source type range is guaranteed to be in the
8962 -- range of the target type.
8965 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
8966 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
8971 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
8972 if Is_Constrained
(T_Typ
) then
8974 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
8975 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
8977 if Is_Access_Type
(Exptyp
) then
8978 Exptyp
:= Designated_Type
(Exptyp
);
8981 -- String_Literal case. This needs to be handled specially be-
8982 -- cause no index types are available for string literals. The
8983 -- condition is simply:
8985 -- T_Typ'Length = string-literal-length
8987 if Nkind
(Expr_Actual
) = N_String_Literal
then
8990 -- General array case. Here we have a usable actual subtype for
8991 -- the expression, and the condition is built from the two types
8993 -- T_Typ'First < Exptyp'First or else
8994 -- T_Typ'Last > Exptyp'Last or else
8995 -- T_Typ'First(1) < Exptyp'First(1) or else
8996 -- T_Typ'Last(1) > Exptyp'Last(1) or else
8999 elsif Is_Constrained
(Exptyp
) then
9001 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9007 L_Index
:= First_Index
(T_Typ
);
9008 R_Index
:= First_Index
(Exptyp
);
9010 for Indx
in 1 .. Ndims
loop
9011 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
9013 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
9015 -- Deal with compile time length check. Note that we
9016 -- skip this in the access case, because the access
9017 -- value may be null, so we cannot know statically.
9020 Subtypes_Statically_Match
9021 (Etype
(L_Index
), Etype
(R_Index
))
9023 -- If the target type is constrained then we
9024 -- have to check for exact equality of bounds
9025 -- (required for qualified expressions).
9027 if Is_Constrained
(T_Typ
) then
9030 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
9033 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
9043 -- Handle cases where we do not get a usable actual subtype that
9044 -- is constrained. This happens for example in the function call
9045 -- and explicit dereference cases. In these cases, we have to get
9046 -- the length or range from the expression itself, making sure we
9047 -- do not evaluate it more than once.
9049 -- Here Ck_Node is the original expression, or more properly the
9050 -- result of applying Duplicate_Expr to the original tree,
9051 -- forcing the result to be a name.
9055 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9058 -- Build the condition for the explicit dereference case
9060 for Indx
in 1 .. Ndims
loop
9062 (Cond
, Range_N_Cond
(Ck_Node
, T_Typ
, Indx
));
9068 -- For a conversion to an unconstrained array type, generate an
9069 -- Action to check that the bounds of the source value are within
9070 -- the constraints imposed by the target type (RM 4.6(38)). No
9071 -- check is needed for a conversion to an access to unconstrained
9072 -- array type, as 4.6(24.15/2) requires the designated subtypes
9073 -- of the two access types to statically match.
9075 if Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
9076 and then not Do_Access
9079 Opnd_Index
: Node_Id
;
9080 Targ_Index
: Node_Id
;
9081 Opnd_Range
: Node_Id
;
9084 Opnd_Index
:= First_Index
(Get_Actual_Subtype
(Ck_Node
));
9085 Targ_Index
:= First_Index
(T_Typ
);
9086 while Present
(Opnd_Index
) loop
9088 -- If the index is a range, use its bounds. If it is an
9089 -- entity (as will be the case if it is a named subtype
9090 -- or an itype created for a slice) retrieve its range.
9092 if Is_Entity_Name
(Opnd_Index
)
9093 and then Is_Type
(Entity
(Opnd_Index
))
9095 Opnd_Range
:= Scalar_Range
(Entity
(Opnd_Index
));
9097 Opnd_Range
:= Opnd_Index
;
9100 if Nkind
(Opnd_Range
) = N_Range
then
9102 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9103 Assume_Valid
=> True)
9106 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9107 Assume_Valid
=> True)
9111 -- If null range, no check needed
9114 Compile_Time_Known_Value
(High_Bound
(Opnd_Range
))
9116 Compile_Time_Known_Value
(Low_Bound
(Opnd_Range
))
9118 Expr_Value
(High_Bound
(Opnd_Range
)) <
9119 Expr_Value
(Low_Bound
(Opnd_Range
))
9123 elsif Is_Out_Of_Range
9124 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9125 Assume_Valid
=> True)
9128 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9129 Assume_Valid
=> True)
9132 (Compile_Time_Constraint_Error
9133 (Wnode
, "value out of range of}?", T_Typ
));
9139 (Opnd_Range
, Etype
(Targ_Index
)));
9143 Next_Index
(Opnd_Index
);
9144 Next_Index
(Targ_Index
);
9151 -- Construct the test and insert into the tree
9153 if Present
(Cond
) then
9155 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
9159 (Make_Raise_Constraint_Error
(Loc
,
9161 Reason
=> CE_Range_Check_Failed
));
9165 end Selected_Range_Checks
;
9167 -------------------------------
9168 -- Storage_Checks_Suppressed --
9169 -------------------------------
9171 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9173 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9174 return Is_Check_Suppressed
(E
, Storage_Check
);
9176 return Scope_Suppress
.Suppress
(Storage_Check
);
9178 end Storage_Checks_Suppressed
;
9180 ---------------------------
9181 -- Tag_Checks_Suppressed --
9182 ---------------------------
9184 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9187 and then Checks_May_Be_Suppressed
(E
)
9189 return Is_Check_Suppressed
(E
, Tag_Check
);
9192 return Scope_Suppress
.Suppress
(Tag_Check
);
9193 end Tag_Checks_Suppressed
;
9195 --------------------------
9196 -- Validity_Check_Range --
9197 --------------------------
9199 procedure Validity_Check_Range
(N
: Node_Id
) is
9201 if Validity_Checks_On
and Validity_Check_Operands
then
9202 if Nkind
(N
) = N_Range
then
9203 Ensure_Valid
(Low_Bound
(N
));
9204 Ensure_Valid
(High_Bound
(N
));
9207 end Validity_Check_Range
;
9209 --------------------------------
9210 -- Validity_Checks_Suppressed --
9211 --------------------------------
9213 function Validity_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9215 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9216 return Is_Check_Suppressed
(E
, Validity_Check
);
9218 return Scope_Suppress
.Suppress
(Validity_Check
);
9220 end Validity_Checks_Suppressed
;