1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Casing
; use Casing
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Errout
; use Errout
;
31 with Exp_Ch2
; use Exp_Ch2
;
32 with Exp_Ch4
; use Exp_Ch4
;
33 with Exp_Ch11
; use Exp_Ch11
;
34 with Exp_Pakd
; use Exp_Pakd
;
35 with Exp_Util
; use Exp_Util
;
36 with Elists
; use Elists
;
37 with Expander
; use Expander
;
38 with Eval_Fat
; use Eval_Fat
;
39 with Freeze
; use Freeze
;
41 with Nlists
; use Nlists
;
42 with Nmake
; use Nmake
;
44 with Output
; use Output
;
45 with Restrict
; use Restrict
;
46 with Rident
; use Rident
;
47 with Rtsfind
; use Rtsfind
;
49 with Sem_Aux
; use Sem_Aux
;
50 with Sem_Eval
; use Sem_Eval
;
51 with Sem_Ch3
; use Sem_Ch3
;
52 with Sem_Ch8
; use Sem_Ch8
;
53 with Sem_Res
; use Sem_Res
;
54 with Sem_Util
; use Sem_Util
;
55 with Sem_Warn
; use Sem_Warn
;
56 with Sinfo
; use Sinfo
;
57 with Sinput
; use Sinput
;
58 with Snames
; use Snames
;
59 with Sprint
; use Sprint
;
60 with Stand
; use Stand
;
61 with Stringt
; use Stringt
;
62 with Targparm
; use Targparm
;
63 with Tbuild
; use Tbuild
;
64 with Ttypes
; use Ttypes
;
65 with Urealp
; use Urealp
;
66 with Validsw
; use Validsw
;
68 package body Checks
is
70 -- General note: many of these routines are concerned with generating
71 -- checking code to make sure that constraint error is raised at runtime.
72 -- Clearly this code is only needed if the expander is active, since
73 -- otherwise we will not be generating code or going into the runtime
76 -- We therefore disconnect most of these checks if the expander is
77 -- inactive. This has the additional benefit that we do not need to
78 -- worry about the tree being messed up by previous errors (since errors
79 -- turn off expansion anyway).
81 -- There are a few exceptions to the above rule. For instance routines
82 -- such as Apply_Scalar_Range_Check that do not insert any code can be
83 -- safely called even when the Expander is inactive (but Errors_Detected
84 -- is 0). The benefit of executing this code when expansion is off, is
85 -- the ability to emit constraint error warning for static expressions
86 -- even when we are not generating code.
88 -- The above is modified in gnatprove mode to ensure that proper check
89 -- flags are always placed, even if expansion is off.
91 -------------------------------------
92 -- Suppression of Redundant Checks --
93 -------------------------------------
95 -- This unit implements a limited circuit for removal of redundant
96 -- checks. The processing is based on a tracing of simple sequential
97 -- flow. For any sequence of statements, we save expressions that are
98 -- marked to be checked, and then if the same expression appears later
99 -- with the same check, then under certain circumstances, the second
100 -- check can be suppressed.
102 -- Basically, we can suppress the check if we know for certain that
103 -- the previous expression has been elaborated (together with its
104 -- check), and we know that the exception frame is the same, and that
105 -- nothing has happened to change the result of the exception.
107 -- Let us examine each of these three conditions in turn to describe
108 -- how we ensure that this condition is met.
110 -- First, we need to know for certain that the previous expression has
111 -- been executed. This is done principally by the mechanism of calling
112 -- Conditional_Statements_Begin at the start of any statement sequence
113 -- and Conditional_Statements_End at the end. The End call causes all
114 -- checks remembered since the Begin call to be discarded. This does
115 -- miss a few cases, notably the case of a nested BEGIN-END block with
116 -- no exception handlers. But the important thing is to be conservative.
117 -- The other protection is that all checks are discarded if a label
118 -- is encountered, since then the assumption of sequential execution
119 -- is violated, and we don't know enough about the flow.
121 -- Second, we need to know that the exception frame is the same. We
122 -- do this by killing all remembered checks when we enter a new frame.
123 -- Again, that's over-conservative, but generally the cases we can help
124 -- with are pretty local anyway (like the body of a loop for example).
126 -- Third, we must be sure to forget any checks which are no longer valid.
127 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
128 -- used to note any changes to local variables. We only attempt to deal
129 -- with checks involving local variables, so we do not need to worry
130 -- about global variables. Second, a call to any non-global procedure
131 -- causes us to abandon all stored checks, since such a all may affect
132 -- the values of any local variables.
134 -- The following define the data structures used to deal with remembering
135 -- checks so that redundant checks can be eliminated as described above.
137 -- Right now, the only expressions that we deal with are of the form of
138 -- simple local objects (either declared locally, or IN parameters) or
139 -- such objects plus/minus a compile time known constant. We can do
140 -- more later on if it seems worthwhile, but this catches many simple
141 -- cases in practice.
143 -- The following record type reflects a single saved check. An entry
144 -- is made in the stack of saved checks if and only if the expression
145 -- has been elaborated with the indicated checks.
147 type Saved_Check
is record
149 -- Set True if entry is killed by Kill_Checks
152 -- The entity involved in the expression that is checked
155 -- A compile time value indicating the result of adding or
156 -- subtracting a compile time value. This value is to be
157 -- added to the value of the Entity. A value of zero is
158 -- used for the case of a simple entity reference.
160 Check_Type
: Character;
161 -- This is set to 'R' for a range check (in which case Target_Type
162 -- is set to the target type for the range check) or to 'O' for an
163 -- overflow check (in which case Target_Type is set to Empty).
165 Target_Type
: Entity_Id
;
166 -- Used only if Do_Range_Check is set. Records the target type for
167 -- the check. We need this, because a check is a duplicate only if
168 -- it has the same target type (or more accurately one with a
169 -- range that is smaller or equal to the stored target type of a
173 -- The following table keeps track of saved checks. Rather than use an
174 -- extensible table. We just use a table of fixed size, and we discard
175 -- any saved checks that do not fit. That's very unlikely to happen and
176 -- this is only an optimization in any case.
178 Saved_Checks
: array (Int
range 1 .. 200) of Saved_Check
;
179 -- Array of saved checks
181 Num_Saved_Checks
: Nat
:= 0;
182 -- Number of saved checks
184 -- The following stack keeps track of statement ranges. It is treated
185 -- as a stack. When Conditional_Statements_Begin is called, an entry
186 -- is pushed onto this stack containing the value of Num_Saved_Checks
187 -- at the time of the call. Then when Conditional_Statements_End is
188 -- called, this value is popped off and used to reset Num_Saved_Checks.
190 -- Note: again, this is a fixed length stack with a size that should
191 -- always be fine. If the value of the stack pointer goes above the
192 -- limit, then we just forget all saved checks.
194 Saved_Checks_Stack
: array (Int
range 1 .. 100) of Nat
;
195 Saved_Checks_TOS
: Nat
:= 0;
197 -----------------------
198 -- Local Subprograms --
199 -----------------------
201 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
);
202 -- Used to apply arithmetic overflow checks for all cases except operators
203 -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we
204 -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a
205 -- signed integer arithmetic operator (but not an if or case expression).
206 -- It is also called for types other than signed integers.
208 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
);
209 -- Used to apply arithmetic overflow checks for the case where the overflow
210 -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer
211 -- arithmetic op (which includes the case of if and case expressions). Note
212 -- that Do_Overflow_Check may or may not be set for node Op. In these modes
213 -- we have work to do even if overflow checking is suppressed.
215 procedure Apply_Division_Check
220 -- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies
221 -- division checks as required if the Do_Division_Check flag is set.
222 -- Rlo and Rhi give the possible range of the right operand, these values
223 -- can be referenced and trusted only if ROK is set True.
225 procedure Apply_Float_Conversion_Check
227 Target_Typ
: Entity_Id
);
228 -- The checks on a conversion from a floating-point type to an integer
229 -- type are delicate. They have to be performed before conversion, they
230 -- have to raise an exception when the operand is a NaN, and rounding must
231 -- be taken into account to determine the safe bounds of the operand.
233 procedure Apply_Selected_Length_Checks
235 Target_Typ
: Entity_Id
;
236 Source_Typ
: Entity_Id
;
237 Do_Static
: Boolean);
238 -- This is the subprogram that does all the work for Apply_Length_Check
239 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
240 -- described for the above routines. The Do_Static flag indicates that
241 -- only a static check is to be done.
243 procedure Apply_Selected_Range_Checks
245 Target_Typ
: Entity_Id
;
246 Source_Typ
: Entity_Id
;
247 Do_Static
: Boolean);
248 -- This is the subprogram that does all the work for Apply_Range_Check.
249 -- Expr, Target_Typ and Source_Typ are as described for the above
250 -- routine. The Do_Static flag indicates that only a static check is
253 type Check_Type
is new Check_Id
range Access_Check
.. Division_Check
;
254 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean;
255 -- This function is used to see if an access or division by zero check is
256 -- needed. The check is to be applied to a single variable appearing in the
257 -- source, and N is the node for the reference. If N is not of this form,
258 -- True is returned with no further processing. If N is of the right form,
259 -- then further processing determines if the given Check is needed.
261 -- The particular circuit is to see if we have the case of a check that is
262 -- not needed because it appears in the right operand of a short circuited
263 -- conditional where the left operand guards the check. For example:
265 -- if Var = 0 or else Q / Var > 12 then
269 -- In this example, the division check is not required. At the same time
270 -- we can issue warnings for suspicious use of non-short-circuited forms,
273 -- if Var = 0 or Q / Var > 12 then
279 Check_Type
: Character;
280 Target_Type
: Entity_Id
;
281 Entry_OK
: out Boolean;
285 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
286 -- to see if a check is of the form for optimization, and if so, to see
287 -- if it has already been performed. Expr is the expression to check,
288 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
289 -- Target_Type is the target type for a range check, and Empty for an
290 -- overflow check. If the entry is not of the form for optimization,
291 -- then Entry_OK is set to False, and the remaining out parameters
292 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
293 -- entity and offset from the expression. Check_Num is the number of
294 -- a matching saved entry in Saved_Checks, or zero if no such entry
297 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
;
298 -- If a discriminal is used in constraining a prival, Return reference
299 -- to the discriminal of the protected body (which renames the parameter
300 -- of the enclosing protected operation). This clumsy transformation is
301 -- needed because privals are created too late and their actual subtypes
302 -- are not available when analysing the bodies of the protected operations.
303 -- This function is called whenever the bound is an entity and the scope
304 -- indicates a protected operation. If the bound is an in-parameter of
305 -- a protected operation that is not a prival, the function returns the
307 -- To be cleaned up???
309 function Guard_Access
312 Ck_Node
: Node_Id
) return Node_Id
;
313 -- In the access type case, guard the test with a test to ensure
314 -- that the access value is non-null, since the checks do not
315 -- not apply to null access values.
317 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
);
318 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
319 -- Constraint_Error node.
321 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean;
322 -- Returns True if node N is for an arithmetic operation with signed
323 -- integer operands. This includes unary and binary operators, and also
324 -- if and case expression nodes where the dependent expressions are of
325 -- a signed integer type. These are the kinds of nodes for which special
326 -- handling applies in MINIMIZED or ELIMINATED overflow checking mode.
328 function Range_Or_Validity_Checks_Suppressed
329 (Expr
: Node_Id
) return Boolean;
330 -- Returns True if either range or validity checks or both are suppressed
331 -- for the type of the given expression, or, if the expression is the name
332 -- of an entity, if these checks are suppressed for the entity.
334 function Selected_Length_Checks
336 Target_Typ
: Entity_Id
;
337 Source_Typ
: Entity_Id
;
338 Warn_Node
: Node_Id
) return Check_Result
;
339 -- Like Apply_Selected_Length_Checks, except it doesn't modify
340 -- anything, just returns a list of nodes as described in the spec of
341 -- this package for the Range_Check function.
343 function Selected_Range_Checks
345 Target_Typ
: Entity_Id
;
346 Source_Typ
: Entity_Id
;
347 Warn_Node
: Node_Id
) return Check_Result
;
348 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
349 -- just returns a list of nodes as described in the spec of this package
350 -- for the Range_Check function.
352 ------------------------------
353 -- Access_Checks_Suppressed --
354 ------------------------------
356 function Access_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
358 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
359 return Is_Check_Suppressed
(E
, Access_Check
);
361 return Scope_Suppress
.Suppress
(Access_Check
);
363 end Access_Checks_Suppressed
;
365 -------------------------------------
366 -- Accessibility_Checks_Suppressed --
367 -------------------------------------
369 function Accessibility_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
371 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
372 return Is_Check_Suppressed
(E
, Accessibility_Check
);
374 return Scope_Suppress
.Suppress
(Accessibility_Check
);
376 end Accessibility_Checks_Suppressed
;
378 -----------------------------
379 -- Activate_Division_Check --
380 -----------------------------
382 procedure Activate_Division_Check
(N
: Node_Id
) is
384 Set_Do_Division_Check
(N
, True);
385 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
386 end Activate_Division_Check
;
388 -----------------------------
389 -- Activate_Overflow_Check --
390 -----------------------------
392 procedure Activate_Overflow_Check
(N
: Node_Id
) is
394 if not Nkind_In
(N
, N_Op_Rem
, N_Op_Mod
, N_Op_Plus
) then
395 Set_Do_Overflow_Check
(N
, True);
396 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
398 end Activate_Overflow_Check
;
400 --------------------------
401 -- Activate_Range_Check --
402 --------------------------
404 procedure Activate_Range_Check
(N
: Node_Id
) is
406 Set_Do_Range_Check
(N
, True);
407 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
408 end Activate_Range_Check
;
410 ---------------------------------
411 -- Alignment_Checks_Suppressed --
412 ---------------------------------
414 function Alignment_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
416 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
417 return Is_Check_Suppressed
(E
, Alignment_Check
);
419 return Scope_Suppress
.Suppress
(Alignment_Check
);
421 end Alignment_Checks_Suppressed
;
423 -------------------------
424 -- Append_Range_Checks --
425 -------------------------
427 procedure Append_Range_Checks
428 (Checks
: Check_Result
;
430 Suppress_Typ
: Entity_Id
;
431 Static_Sloc
: Source_Ptr
;
434 Internal_Flag_Node
: constant Node_Id
:= Flag_Node
;
435 Internal_Static_Sloc
: constant Source_Ptr
:= Static_Sloc
;
437 Checks_On
: constant Boolean :=
438 (not Index_Checks_Suppressed
(Suppress_Typ
))
439 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
442 -- For now we just return if Checks_On is false, however this should
443 -- be enhanced to check for an always True value in the condition
444 -- and to generate a compilation warning???
446 if not Checks_On
then
451 exit when No
(Checks
(J
));
453 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
454 and then Present
(Condition
(Checks
(J
)))
456 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
457 Append_To
(Stmts
, Checks
(J
));
458 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
464 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
465 Reason
=> CE_Range_Check_Failed
));
468 end Append_Range_Checks
;
470 ------------------------
471 -- Apply_Access_Check --
472 ------------------------
474 procedure Apply_Access_Check
(N
: Node_Id
) is
475 P
: constant Node_Id
:= Prefix
(N
);
478 -- We do not need checks if we are not generating code (i.e. the
479 -- expander is not active). This is not just an optimization, there
480 -- are cases (e.g. with pragma Debug) where generating the checks
481 -- can cause real trouble).
483 if not Expander_Active
then
487 -- No check if short circuiting makes check unnecessary
489 if not Check_Needed
(P
, Access_Check
) then
493 -- No check if accessing the Offset_To_Top component of a dispatch
494 -- table. They are safe by construction.
496 if Tagged_Type_Expansion
497 and then Present
(Etype
(P
))
498 and then RTU_Loaded
(Ada_Tags
)
499 and then RTE_Available
(RE_Offset_To_Top_Ptr
)
500 and then Etype
(P
) = RTE
(RE_Offset_To_Top_Ptr
)
505 -- Otherwise go ahead and install the check
507 Install_Null_Excluding_Check
(P
);
508 end Apply_Access_Check
;
510 -------------------------------
511 -- Apply_Accessibility_Check --
512 -------------------------------
514 procedure Apply_Accessibility_Check
517 Insert_Node
: Node_Id
)
519 Loc
: constant Source_Ptr
:= Sloc
(N
);
520 Param_Ent
: Entity_Id
:= Param_Entity
(N
);
521 Param_Level
: Node_Id
;
522 Type_Level
: Node_Id
;
525 if Ada_Version
>= Ada_2012
526 and then not Present
(Param_Ent
)
527 and then Is_Entity_Name
(N
)
528 and then Ekind_In
(Entity
(N
), E_Constant
, E_Variable
)
529 and then Present
(Effective_Extra_Accessibility
(Entity
(N
)))
531 Param_Ent
:= Entity
(N
);
532 while Present
(Renamed_Object
(Param_Ent
)) loop
534 -- Renamed_Object must return an Entity_Name here
535 -- because of preceding "Present (E_E_A (...))" test.
537 Param_Ent
:= Entity
(Renamed_Object
(Param_Ent
));
541 if Inside_A_Generic
then
544 -- Only apply the run-time check if the access parameter has an
545 -- associated extra access level parameter and when the level of the
546 -- type is less deep than the level of the access parameter, and
547 -- accessibility checks are not suppressed.
549 elsif Present
(Param_Ent
)
550 and then Present
(Extra_Accessibility
(Param_Ent
))
551 and then UI_Gt
(Object_Access_Level
(N
),
552 Deepest_Type_Access_Level
(Typ
))
553 and then not Accessibility_Checks_Suppressed
(Param_Ent
)
554 and then not Accessibility_Checks_Suppressed
(Typ
)
557 New_Occurrence_Of
(Extra_Accessibility
(Param_Ent
), Loc
);
560 Make_Integer_Literal
(Loc
, Deepest_Type_Access_Level
(Typ
));
562 -- Raise Program_Error if the accessibility level of the access
563 -- parameter is deeper than the level of the target access type.
565 Insert_Action
(Insert_Node
,
566 Make_Raise_Program_Error
(Loc
,
569 Left_Opnd
=> Param_Level
,
570 Right_Opnd
=> Type_Level
),
571 Reason
=> PE_Accessibility_Check_Failed
));
573 Analyze_And_Resolve
(N
);
575 end Apply_Accessibility_Check
;
577 --------------------------------
578 -- Apply_Address_Clause_Check --
579 --------------------------------
581 procedure Apply_Address_Clause_Check
(E
: Entity_Id
; N
: Node_Id
) is
582 pragma Assert
(Nkind
(N
) = N_Freeze_Entity
);
584 AC
: constant Node_Id
:= Address_Clause
(E
);
585 Loc
: constant Source_Ptr
:= Sloc
(AC
);
586 Typ
: constant Entity_Id
:= Etype
(E
);
587 Aexp
: constant Node_Id
:= Expression
(AC
);
590 -- Address expression (not necessarily the same as Aexp, for example
591 -- when Aexp is a reference to a constant, in which case Expr gets
592 -- reset to reference the value expression of the constant.
594 procedure Compile_Time_Bad_Alignment
;
595 -- Post error warnings when alignment is known to be incompatible. Note
596 -- that we do not go as far as inserting a raise of Program_Error since
597 -- this is an erroneous case, and it may happen that we are lucky and an
598 -- underaligned address turns out to be OK after all.
600 --------------------------------
601 -- Compile_Time_Bad_Alignment --
602 --------------------------------
604 procedure Compile_Time_Bad_Alignment
is
606 if Address_Clause_Overlay_Warnings
then
608 ("?o?specified address for& may be inconsistent with alignment",
611 ("\?o?program execution may be erroneous (RM 13.3(27))",
613 Set_Address_Warning_Posted
(AC
);
615 end Compile_Time_Bad_Alignment
;
617 -- Start of processing for Apply_Address_Clause_Check
620 -- See if alignment check needed. Note that we never need a check if the
621 -- maximum alignment is one, since the check will always succeed.
623 -- Note: we do not check for checks suppressed here, since that check
624 -- was done in Sem_Ch13 when the address clause was processed. We are
625 -- only called if checks were not suppressed. The reason for this is
626 -- that we have to delay the call to Apply_Alignment_Check till freeze
627 -- time (so that all types etc are elaborated), but we have to check
628 -- the status of check suppressing at the point of the address clause.
631 or else not Check_Address_Alignment
(AC
)
632 or else Maximum_Alignment
= 1
637 -- Obtain expression from address clause
639 Expr
:= Expression
(AC
);
641 -- The following loop digs for the real expression to use in the check
644 -- For constant, get constant expression
646 if Is_Entity_Name
(Expr
)
647 and then Ekind
(Entity
(Expr
)) = E_Constant
649 Expr
:= Constant_Value
(Entity
(Expr
));
651 -- For unchecked conversion, get result to convert
653 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
654 Expr
:= Expression
(Expr
);
656 -- For (common case) of To_Address call, get argument
658 elsif Nkind
(Expr
) = N_Function_Call
659 and then Is_Entity_Name
(Name
(Expr
))
660 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
662 Expr
:= First
(Parameter_Associations
(Expr
));
664 if Nkind
(Expr
) = N_Parameter_Association
then
665 Expr
:= Explicit_Actual_Parameter
(Expr
);
668 -- We finally have the real expression
675 -- See if we know that Expr has a bad alignment at compile time
677 if Compile_Time_Known_Value
(Expr
)
678 and then (Known_Alignment
(E
) or else Known_Alignment
(Typ
))
681 AL
: Uint
:= Alignment
(Typ
);
684 -- The object alignment might be more restrictive than the
687 if Known_Alignment
(E
) then
691 if Expr_Value
(Expr
) mod AL
/= 0 then
692 Compile_Time_Bad_Alignment
;
698 -- If the expression has the form X'Address, then we can find out if
699 -- the object X has an alignment that is compatible with the object E.
700 -- If it hasn't or we don't know, we defer issuing the warning until
701 -- the end of the compilation to take into account back end annotations.
703 elsif Nkind
(Expr
) = N_Attribute_Reference
704 and then Attribute_Name
(Expr
) = Name_Address
705 and then Has_Compatible_Alignment
(E
, Prefix
(Expr
)) = Known_Compatible
710 -- Here we do not know if the value is acceptable. Strictly we don't
711 -- have to do anything, since if the alignment is bad, we have an
712 -- erroneous program. However we are allowed to check for erroneous
713 -- conditions and we decide to do this by default if the check is not
716 -- However, don't do the check if elaboration code is unwanted
718 if Restriction_Active
(No_Elaboration_Code
) then
721 -- Generate a check to raise PE if alignment may be inappropriate
724 -- If the original expression is a non-static constant, use the
725 -- name of the constant itself rather than duplicating its
726 -- defining expression, which was extracted above.
728 -- Note: Expr is empty if the address-clause is applied to in-mode
729 -- actuals (allowed by 13.1(22)).
731 if not Present
(Expr
)
733 (Is_Entity_Name
(Expression
(AC
))
734 and then Ekind
(Entity
(Expression
(AC
))) = E_Constant
735 and then Nkind
(Parent
(Entity
(Expression
(AC
))))
736 = N_Object_Declaration
)
738 Expr
:= New_Copy_Tree
(Expression
(AC
));
740 Remove_Side_Effects
(Expr
);
743 if No
(Actions
(N
)) then
744 Set_Actions
(N
, New_List
);
747 Prepend_To
(Actions
(N
),
748 Make_Raise_Program_Error
(Loc
,
755 (RTE
(RE_Integer_Address
), Expr
),
757 Make_Attribute_Reference
(Loc
,
758 Prefix
=> New_Occurrence_Of
(E
, Loc
),
759 Attribute_Name
=> Name_Alignment
)),
760 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
761 Reason
=> PE_Misaligned_Address_Value
));
762 Analyze
(First
(Actions
(N
)), Suppress
=> All_Checks
);
764 -- If the address clause generates an alignment check and we are
765 -- in ZPF or some restricted run-time, add a warning to explain
766 -- the propagation warning that is generated by the check.
768 if Nkind
(First
(Actions
(N
))) = N_Raise_Program_Error
769 and then not Warnings_Off
(E
)
770 and then Restriction_Active
(No_Exception_Propagation
)
773 ("address value may be incompatible with alignment of object?",
781 -- If we have some missing run time component in configurable run time
782 -- mode then just skip the check (it is not required in any case).
784 when RE_Not_Available
=>
786 end Apply_Address_Clause_Check
;
788 -------------------------------------
789 -- Apply_Arithmetic_Overflow_Check --
790 -------------------------------------
792 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
794 -- Use old routine in almost all cases (the only case we are treating
795 -- specially is the case of a signed integer arithmetic op with the
796 -- overflow checking mode set to MINIMIZED or ELIMINATED).
798 if Overflow_Check_Mode
= Strict
799 or else not Is_Signed_Integer_Arithmetic_Op
(N
)
801 Apply_Arithmetic_Overflow_Strict
(N
);
803 -- Otherwise use the new routine for the case of a signed integer
804 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
805 -- mode is MINIMIZED or ELIMINATED.
808 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
810 end Apply_Arithmetic_Overflow_Check
;
812 --------------------------------------
813 -- Apply_Arithmetic_Overflow_Strict --
814 --------------------------------------
816 -- This routine is called only if the type is an integer type, and a
817 -- software arithmetic overflow check may be needed for op (add, subtract,
818 -- or multiply). This check is performed only if Software_Overflow_Checking
819 -- is enabled and Do_Overflow_Check is set. In this case we expand the
820 -- operation into a more complex sequence of tests that ensures that
821 -- overflow is properly caught.
823 -- This is used in CHECKED modes. It is identical to the code for this
824 -- cases before the big overflow earthquake, thus ensuring that in this
825 -- modes we have compatible behavior (and reliability) to what was there
826 -- before. It is also called for types other than signed integers, and if
827 -- the Do_Overflow_Check flag is off.
829 -- Note: we also call this routine if we decide in the MINIMIZED case
830 -- to give up and just generate an overflow check without any fuss.
832 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
) is
833 Loc
: constant Source_Ptr
:= Sloc
(N
);
834 Typ
: constant Entity_Id
:= Etype
(N
);
835 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
838 -- Nothing to do if Do_Overflow_Check not set or overflow checks
841 if not Do_Overflow_Check
(N
) then
845 -- An interesting special case. If the arithmetic operation appears as
846 -- the operand of a type conversion:
850 -- and all the following conditions apply:
852 -- arithmetic operation is for a signed integer type
853 -- target type type1 is a static integer subtype
854 -- range of x and y are both included in the range of type1
855 -- range of x op y is included in the range of type1
856 -- size of type1 is at least twice the result size of op
858 -- then we don't do an overflow check in any case, instead we transform
859 -- the operation so that we end up with:
861 -- type1 (type1 (x) op type1 (y))
863 -- This avoids intermediate overflow before the conversion. It is
864 -- explicitly permitted by RM 3.5.4(24):
866 -- For the execution of a predefined operation of a signed integer
867 -- type, the implementation need not raise Constraint_Error if the
868 -- result is outside the base range of the type, so long as the
869 -- correct result is produced.
871 -- It's hard to imagine that any programmer counts on the exception
872 -- being raised in this case, and in any case it's wrong coding to
873 -- have this expectation, given the RM permission. Furthermore, other
874 -- Ada compilers do allow such out of range results.
876 -- Note that we do this transformation even if overflow checking is
877 -- off, since this is precisely about giving the "right" result and
878 -- avoiding the need for an overflow check.
880 -- Note: this circuit is partially redundant with respect to the similar
881 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
882 -- with cases that do not come through here. We still need the following
883 -- processing even with the Exp_Ch4 code in place, since we want to be
884 -- sure not to generate the arithmetic overflow check in these cases
885 -- (Exp_Ch4 would have a hard time removing them once generated).
887 if Is_Signed_Integer_Type
(Typ
)
888 and then Nkind
(Parent
(N
)) = N_Type_Conversion
890 Conversion_Optimization
: declare
891 Target_Type
: constant Entity_Id
:=
892 Base_Type
(Entity
(Subtype_Mark
(Parent
(N
))));
906 if Is_Integer_Type
(Target_Type
)
907 and then RM_Size
(Root_Type
(Target_Type
)) >= 2 * RM_Size
(Rtyp
)
909 Tlo
:= Expr_Value
(Type_Low_Bound
(Target_Type
));
910 Thi
:= Expr_Value
(Type_High_Bound
(Target_Type
));
913 (Left_Opnd
(N
), LOK
, Llo
, Lhi
, Assume_Valid
=> True);
915 (Right_Opnd
(N
), ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
918 and then Tlo
<= Llo
and then Lhi
<= Thi
919 and then Tlo
<= Rlo
and then Rhi
<= Thi
921 Determine_Range
(N
, VOK
, Vlo
, Vhi
, Assume_Valid
=> True);
923 if VOK
and then Tlo
<= Vlo
and then Vhi
<= Thi
then
924 Rewrite
(Left_Opnd
(N
),
925 Make_Type_Conversion
(Loc
,
926 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
927 Expression
=> Relocate_Node
(Left_Opnd
(N
))));
929 Rewrite
(Right_Opnd
(N
),
930 Make_Type_Conversion
(Loc
,
931 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
932 Expression
=> Relocate_Node
(Right_Opnd
(N
))));
934 -- Rewrite the conversion operand so that the original
935 -- node is retained, in order to avoid the warning for
936 -- redundant conversions in Resolve_Type_Conversion.
938 Rewrite
(N
, Relocate_Node
(N
));
940 Set_Etype
(N
, Target_Type
);
942 Analyze_And_Resolve
(Left_Opnd
(N
), Target_Type
);
943 Analyze_And_Resolve
(Right_Opnd
(N
), Target_Type
);
945 -- Given that the target type is twice the size of the
946 -- source type, overflow is now impossible, so we can
947 -- safely kill the overflow check and return.
949 Set_Do_Overflow_Check
(N
, False);
954 end Conversion_Optimization
;
957 -- Now see if an overflow check is required
960 Siz
: constant Int
:= UI_To_Int
(Esize
(Rtyp
));
961 Dsiz
: constant Int
:= Siz
* 2;
968 -- Skip check if back end does overflow checks, or the overflow flag
969 -- is not set anyway, or we are not doing code expansion, or the
970 -- parent node is a type conversion whose operand is an arithmetic
971 -- operation on signed integers on which the expander can promote
972 -- later the operands to type Integer (see Expand_N_Type_Conversion).
974 -- Special case CLI target, where arithmetic overflow checks can be
975 -- performed for integer and long_integer
977 if Backend_Overflow_Checks_On_Target
978 or else not Do_Overflow_Check
(N
)
979 or else not Expander_Active
980 or else (Present
(Parent
(N
))
981 and then Nkind
(Parent
(N
)) = N_Type_Conversion
982 and then Integer_Promotion_Possible
(Parent
(N
)))
984 (VM_Target
= CLI_Target
and then Siz
>= Standard_Integer_Size
)
989 -- Otherwise, generate the full general code for front end overflow
990 -- detection, which works by doing arithmetic in a larger type:
996 -- Typ (Checktyp (x) op Checktyp (y));
998 -- where Typ is the type of the original expression, and Checktyp is
999 -- an integer type of sufficient length to hold the largest possible
1002 -- If the size of check type exceeds the size of Long_Long_Integer,
1003 -- we use a different approach, expanding to:
1005 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
1007 -- where xxx is Add, Multiply or Subtract as appropriate
1009 -- Find check type if one exists
1011 if Dsiz
<= Standard_Integer_Size
then
1012 Ctyp
:= Standard_Integer
;
1014 elsif Dsiz
<= Standard_Long_Long_Integer_Size
then
1015 Ctyp
:= Standard_Long_Long_Integer
;
1017 -- No check type exists, use runtime call
1020 if Nkind
(N
) = N_Op_Add
then
1021 Cent
:= RE_Add_With_Ovflo_Check
;
1023 elsif Nkind
(N
) = N_Op_Multiply
then
1024 Cent
:= RE_Multiply_With_Ovflo_Check
;
1027 pragma Assert
(Nkind
(N
) = N_Op_Subtract
);
1028 Cent
:= RE_Subtract_With_Ovflo_Check
;
1033 Make_Function_Call
(Loc
,
1034 Name
=> New_Occurrence_Of
(RTE
(Cent
), Loc
),
1035 Parameter_Associations
=> New_List
(
1036 OK_Convert_To
(RTE
(RE_Integer_64
), Left_Opnd
(N
)),
1037 OK_Convert_To
(RTE
(RE_Integer_64
), Right_Opnd
(N
))))));
1039 Analyze_And_Resolve
(N
, Typ
);
1043 -- If we fall through, we have the case where we do the arithmetic
1044 -- in the next higher type and get the check by conversion. In these
1045 -- cases Ctyp is set to the type to be used as the check type.
1047 Opnod
:= Relocate_Node
(N
);
1049 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
1052 Set_Etype
(Opnd
, Ctyp
);
1053 Set_Analyzed
(Opnd
, True);
1054 Set_Left_Opnd
(Opnod
, Opnd
);
1056 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
1059 Set_Etype
(Opnd
, Ctyp
);
1060 Set_Analyzed
(Opnd
, True);
1061 Set_Right_Opnd
(Opnod
, Opnd
);
1063 -- The type of the operation changes to the base type of the check
1064 -- type, and we reset the overflow check indication, since clearly no
1065 -- overflow is possible now that we are using a double length type.
1066 -- We also set the Analyzed flag to avoid a recursive attempt to
1069 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
1070 Set_Do_Overflow_Check
(Opnod
, False);
1071 Set_Analyzed
(Opnod
, True);
1073 -- Now build the outer conversion
1075 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
1077 Set_Etype
(Opnd
, Typ
);
1079 -- In the discrete type case, we directly generate the range check
1080 -- for the outer operand. This range check will implement the
1081 -- required overflow check.
1083 if Is_Discrete_Type
(Typ
) then
1085 Generate_Range_Check
1086 (Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
1088 -- For other types, we enable overflow checking on the conversion,
1089 -- after setting the node as analyzed to prevent recursive attempts
1090 -- to expand the conversion node.
1093 Set_Analyzed
(Opnd
, True);
1094 Enable_Overflow_Check
(Opnd
);
1099 when RE_Not_Available
=>
1102 end Apply_Arithmetic_Overflow_Strict
;
1104 ----------------------------------------------------
1105 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1106 ----------------------------------------------------
1108 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
) is
1109 pragma Assert
(Is_Signed_Integer_Arithmetic_Op
(Op
));
1111 Loc
: constant Source_Ptr
:= Sloc
(Op
);
1112 P
: constant Node_Id
:= Parent
(Op
);
1114 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
1115 -- Operands and results are of this type when we convert
1117 Result_Type
: constant Entity_Id
:= Etype
(Op
);
1118 -- Original result type
1120 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1121 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
1124 -- Ranges of values for result
1127 -- Nothing to do if our parent is one of the following:
1129 -- Another signed integer arithmetic op
1130 -- A membership operation
1131 -- A comparison operation
1133 -- In all these cases, we will process at the higher level (and then
1134 -- this node will be processed during the downwards recursion that
1135 -- is part of the processing in Minimize_Eliminate_Overflows).
1137 if Is_Signed_Integer_Arithmetic_Op
(P
)
1138 or else Nkind
(P
) in N_Membership_Test
1139 or else Nkind
(P
) in N_Op_Compare
1141 -- This is also true for an alternative in a case expression
1143 or else Nkind
(P
) = N_Case_Expression_Alternative
1145 -- This is also true for a range operand in a membership test
1147 or else (Nkind
(P
) = N_Range
1148 and then Nkind
(Parent
(P
)) in N_Membership_Test
)
1153 -- Otherwise, we have a top level arithmetic operation node, and this
1154 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1155 -- modes. This is the case where we tell the machinery not to move into
1156 -- Bignum mode at this top level (of course the top level operation
1157 -- will still be in Bignum mode if either of its operands are of type
1160 Minimize_Eliminate_Overflows
(Op
, Lo
, Hi
, Top_Level
=> True);
1162 -- That call may but does not necessarily change the result type of Op.
1163 -- It is the job of this routine to undo such changes, so that at the
1164 -- top level, we have the proper type. This "undoing" is a point at
1165 -- which a final overflow check may be applied.
1167 -- If the result type was not fiddled we are all set. We go to base
1168 -- types here because things may have been rewritten to generate the
1169 -- base type of the operand types.
1171 if Base_Type
(Etype
(Op
)) = Base_Type
(Result_Type
) then
1176 elsif Is_RTE
(Etype
(Op
), RE_Bignum
) then
1178 -- We need a sequence that looks like:
1180 -- Rnn : Result_Type;
1183 -- M : Mark_Id := SS_Mark;
1185 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1189 -- This block is inserted (using Insert_Actions), and then the node
1190 -- is replaced with a reference to Rnn.
1192 -- A special case arises if our parent is a conversion node. In this
1193 -- case no point in generating a conversion to Result_Type, we will
1194 -- let the parent handle this. Note that this special case is not
1195 -- just about optimization. Consider
1199 -- X := Long_Long_Integer'Base (A * (B ** C));
1201 -- Now the product may fit in Long_Long_Integer but not in Integer.
1202 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1203 -- overflow exception for this intermediate value.
1206 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
1207 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R', Op
);
1213 RHS
:= Convert_From_Bignum
(Op
);
1215 if Nkind
(P
) /= N_Type_Conversion
then
1216 Convert_To_And_Rewrite
(Result_Type
, RHS
);
1217 Rtype
:= Result_Type
;
1219 -- Interesting question, do we need a check on that conversion
1220 -- operation. Answer, not if we know the result is in range.
1221 -- At the moment we are not taking advantage of this. To be
1222 -- looked at later ???
1229 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
1230 Make_Assignment_Statement
(Loc
,
1231 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
1232 Expression
=> RHS
));
1234 Insert_Actions
(Op
, New_List
(
1235 Make_Object_Declaration
(Loc
,
1236 Defining_Identifier
=> Rnn
,
1237 Object_Definition
=> New_Occurrence_Of
(Rtype
, Loc
)),
1240 Rewrite
(Op
, New_Occurrence_Of
(Rnn
, Loc
));
1241 Analyze_And_Resolve
(Op
);
1244 -- Here we know the result is Long_Long_Integer'Base, of that it has
1245 -- been rewritten because the parent operation is a conversion. See
1246 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1250 (Etype
(Op
) = LLIB
or else Nkind
(Parent
(Op
)) = N_Type_Conversion
);
1252 -- All we need to do here is to convert the result to the proper
1253 -- result type. As explained above for the Bignum case, we can
1254 -- omit this if our parent is a type conversion.
1256 if Nkind
(P
) /= N_Type_Conversion
then
1257 Convert_To_And_Rewrite
(Result_Type
, Op
);
1260 Analyze_And_Resolve
(Op
);
1262 end Apply_Arithmetic_Overflow_Minimized_Eliminated
;
1264 ----------------------------
1265 -- Apply_Constraint_Check --
1266 ----------------------------
1268 procedure Apply_Constraint_Check
1271 No_Sliding
: Boolean := False)
1273 Desig_Typ
: Entity_Id
;
1276 -- No checks inside a generic (check the instantiations)
1278 if Inside_A_Generic
then
1282 -- Apply required constraint checks
1284 if Is_Scalar_Type
(Typ
) then
1285 Apply_Scalar_Range_Check
(N
, Typ
);
1287 elsif Is_Array_Type
(Typ
) then
1289 -- A useful optimization: an aggregate with only an others clause
1290 -- always has the right bounds.
1292 if Nkind
(N
) = N_Aggregate
1293 and then No
(Expressions
(N
))
1295 (First
(Choices
(First
(Component_Associations
(N
)))))
1301 if Is_Constrained
(Typ
) then
1302 Apply_Length_Check
(N
, Typ
);
1305 Apply_Range_Check
(N
, Typ
);
1308 Apply_Range_Check
(N
, Typ
);
1311 elsif (Is_Record_Type
(Typ
) or else Is_Private_Type
(Typ
))
1312 and then Has_Discriminants
(Base_Type
(Typ
))
1313 and then Is_Constrained
(Typ
)
1315 Apply_Discriminant_Check
(N
, Typ
);
1317 elsif Is_Access_Type
(Typ
) then
1319 Desig_Typ
:= Designated_Type
(Typ
);
1321 -- No checks necessary if expression statically null
1323 if Known_Null
(N
) then
1324 if Can_Never_Be_Null
(Typ
) then
1325 Install_Null_Excluding_Check
(N
);
1328 -- No sliding possible on access to arrays
1330 elsif Is_Array_Type
(Desig_Typ
) then
1331 if Is_Constrained
(Desig_Typ
) then
1332 Apply_Length_Check
(N
, Typ
);
1335 Apply_Range_Check
(N
, Typ
);
1337 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
1338 and then Is_Constrained
(Desig_Typ
)
1340 Apply_Discriminant_Check
(N
, Typ
);
1343 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1344 -- this check if the constraint node is illegal, as shown by having
1345 -- an error posted. This additional guard prevents cascaded errors
1346 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1348 if Can_Never_Be_Null
(Typ
)
1349 and then not Can_Never_Be_Null
(Etype
(N
))
1350 and then not Error_Posted
(N
)
1352 Install_Null_Excluding_Check
(N
);
1355 end Apply_Constraint_Check
;
1357 ------------------------------
1358 -- Apply_Discriminant_Check --
1359 ------------------------------
1361 procedure Apply_Discriminant_Check
1364 Lhs
: Node_Id
:= Empty
)
1366 Loc
: constant Source_Ptr
:= Sloc
(N
);
1367 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1368 S_Typ
: Entity_Id
:= Etype
(N
);
1372 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean;
1373 -- A heap object with an indefinite subtype is constrained by its
1374 -- initial value, and assigning to it requires a constraint_check.
1375 -- The target may be an explicit dereference, or a renaming of one.
1377 function Is_Aliased_Unconstrained_Component
return Boolean;
1378 -- It is possible for an aliased component to have a nominal
1379 -- unconstrained subtype (through instantiation). If this is a
1380 -- discriminated component assigned in the expansion of an aggregate
1381 -- in an initialization, the check must be suppressed. This unusual
1382 -- situation requires a predicate of its own.
1384 ----------------------------------
1385 -- Denotes_Explicit_Dereference --
1386 ----------------------------------
1388 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean is
1391 Nkind
(Obj
) = N_Explicit_Dereference
1393 (Is_Entity_Name
(Obj
)
1394 and then Present
(Renamed_Object
(Entity
(Obj
)))
1395 and then Nkind
(Renamed_Object
(Entity
(Obj
))) =
1396 N_Explicit_Dereference
);
1397 end Denotes_Explicit_Dereference
;
1399 ----------------------------------------
1400 -- Is_Aliased_Unconstrained_Component --
1401 ----------------------------------------
1403 function Is_Aliased_Unconstrained_Component
return Boolean is
1408 if Nkind
(Lhs
) /= N_Selected_Component
then
1411 Comp
:= Entity
(Selector_Name
(Lhs
));
1412 Pref
:= Prefix
(Lhs
);
1415 if Ekind
(Comp
) /= E_Component
1416 or else not Is_Aliased
(Comp
)
1421 return not Comes_From_Source
(Pref
)
1422 and then In_Instance
1423 and then not Is_Constrained
(Etype
(Comp
));
1424 end Is_Aliased_Unconstrained_Component
;
1426 -- Start of processing for Apply_Discriminant_Check
1430 T_Typ
:= Designated_Type
(Typ
);
1435 -- Nothing to do if discriminant checks are suppressed or else no code
1436 -- is to be generated
1438 if not Expander_Active
1439 or else Discriminant_Checks_Suppressed
(T_Typ
)
1444 -- No discriminant checks necessary for an access when expression is
1445 -- statically Null. This is not only an optimization, it is fundamental
1446 -- because otherwise discriminant checks may be generated in init procs
1447 -- for types containing an access to a not-yet-frozen record, causing a
1448 -- deadly forward reference.
1450 -- Also, if the expression is of an access type whose designated type is
1451 -- incomplete, then the access value must be null and we suppress the
1454 if Known_Null
(N
) then
1457 elsif Is_Access_Type
(S_Typ
) then
1458 S_Typ
:= Designated_Type
(S_Typ
);
1460 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1465 -- If an assignment target is present, then we need to generate the
1466 -- actual subtype if the target is a parameter or aliased object with
1467 -- an unconstrained nominal subtype.
1469 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1470 -- subtype to the parameter and dereference cases, since other aliased
1471 -- objects are unconstrained (unless the nominal subtype is explicitly
1475 and then (Present
(Param_Entity
(Lhs
))
1476 or else (Ada_Version
< Ada_2005
1477 and then not Is_Constrained
(T_Typ
)
1478 and then Is_Aliased_View
(Lhs
)
1479 and then not Is_Aliased_Unconstrained_Component
)
1480 or else (Ada_Version
>= Ada_2005
1481 and then not Is_Constrained
(T_Typ
)
1482 and then Denotes_Explicit_Dereference
(Lhs
)
1483 and then Nkind
(Original_Node
(Lhs
)) /=
1486 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1489 -- Nothing to do if the type is unconstrained (this is the case where
1490 -- the actual subtype in the RM sense of N is unconstrained and no check
1493 if not Is_Constrained
(T_Typ
) then
1496 -- Ada 2005: nothing to do if the type is one for which there is a
1497 -- partial view that is constrained.
1499 elsif Ada_Version
>= Ada_2005
1500 and then Object_Type_Has_Constrained_Partial_View
1501 (Typ
=> Base_Type
(T_Typ
),
1502 Scop
=> Current_Scope
)
1507 -- Nothing to do if the type is an Unchecked_Union
1509 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
1513 -- Suppress checks if the subtypes are the same. The check must be
1514 -- preserved in an assignment to a formal, because the constraint is
1515 -- given by the actual.
1517 if Nkind
(Original_Node
(N
)) /= N_Allocator
1519 or else not Is_Entity_Name
(Lhs
)
1520 or else No
(Param_Entity
(Lhs
)))
1523 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1524 and then not Is_Aliased_View
(Lhs
)
1529 -- We can also eliminate checks on allocators with a subtype mark that
1530 -- coincides with the context type. The context type may be a subtype
1531 -- without a constraint (common case, a generic actual).
1533 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1534 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1537 Alloc_Typ
: constant Entity_Id
:=
1538 Entity
(Expression
(Original_Node
(N
)));
1541 if Alloc_Typ
= T_Typ
1542 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1543 and then Is_Entity_Name
(
1544 Subtype_Indication
(Parent
(T_Typ
)))
1545 and then Alloc_Typ
= Base_Type
(T_Typ
))
1553 -- See if we have a case where the types are both constrained, and all
1554 -- the constraints are constants. In this case, we can do the check
1555 -- successfully at compile time.
1557 -- We skip this check for the case where the node is rewritten as
1558 -- an allocator, because it already carries the context subtype,
1559 -- and extracting the discriminants from the aggregate is messy.
1561 if Is_Constrained
(S_Typ
)
1562 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1572 -- S_Typ may not have discriminants in the case where it is a
1573 -- private type completed by a default discriminated type. In that
1574 -- case, we need to get the constraints from the underlying type.
1575 -- If the underlying type is unconstrained (i.e. has no default
1576 -- discriminants) no check is needed.
1578 if Has_Discriminants
(S_Typ
) then
1579 Discr
:= First_Discriminant
(S_Typ
);
1580 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1583 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1586 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1592 -- A further optimization: if T_Typ is derived from S_Typ
1593 -- without imposing a constraint, no check is needed.
1595 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1596 N_Full_Type_Declaration
1599 Type_Def
: constant Node_Id
:=
1600 Type_Definition
(Original_Node
(Parent
(T_Typ
)));
1602 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1603 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1604 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1612 -- Constraint may appear in full view of type
1614 if Ekind
(T_Typ
) = E_Private_Subtype
1615 and then Present
(Full_View
(T_Typ
))
1618 First_Elmt
(Discriminant_Constraint
(Full_View
(T_Typ
)));
1621 First_Elmt
(Discriminant_Constraint
(T_Typ
));
1624 while Present
(Discr
) loop
1625 ItemS
:= Node
(DconS
);
1626 ItemT
:= Node
(DconT
);
1628 -- For a discriminated component type constrained by the
1629 -- current instance of an enclosing type, there is no
1630 -- applicable discriminant check.
1632 if Nkind
(ItemT
) = N_Attribute_Reference
1633 and then Is_Access_Type
(Etype
(ItemT
))
1634 and then Is_Entity_Name
(Prefix
(ItemT
))
1635 and then Is_Type
(Entity
(Prefix
(ItemT
)))
1640 -- If the expressions for the discriminants are identical
1641 -- and it is side-effect free (for now just an entity),
1642 -- this may be a shared constraint, e.g. from a subtype
1643 -- without a constraint introduced as a generic actual.
1644 -- Examine other discriminants if any.
1647 and then Is_Entity_Name
(ItemS
)
1651 elsif not Is_OK_Static_Expression
(ItemS
)
1652 or else not Is_OK_Static_Expression
(ItemT
)
1656 elsif Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1657 if Do_Access
then -- needs run-time check.
1660 Apply_Compile_Time_Constraint_Error
1661 (N
, "incorrect value for discriminant&??",
1662 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1669 Next_Discriminant
(Discr
);
1678 -- Here we need a discriminant check. First build the expression
1679 -- for the comparisons of the discriminants:
1681 -- (n.disc1 /= typ.disc1) or else
1682 -- (n.disc2 /= typ.disc2) or else
1684 -- (n.discn /= typ.discn)
1686 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1688 -- If Lhs is set and is a parameter, then the condition is guarded by:
1689 -- lhs'constrained and then (condition built above)
1691 if Present
(Param_Entity
(Lhs
)) then
1695 Make_Attribute_Reference
(Loc
,
1696 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1697 Attribute_Name
=> Name_Constrained
),
1698 Right_Opnd
=> Cond
);
1702 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1706 Make_Raise_Constraint_Error
(Loc
,
1708 Reason
=> CE_Discriminant_Check_Failed
));
1709 end Apply_Discriminant_Check
;
1711 -------------------------
1712 -- Apply_Divide_Checks --
1713 -------------------------
1715 procedure Apply_Divide_Checks
(N
: Node_Id
) is
1716 Loc
: constant Source_Ptr
:= Sloc
(N
);
1717 Typ
: constant Entity_Id
:= Etype
(N
);
1718 Left
: constant Node_Id
:= Left_Opnd
(N
);
1719 Right
: constant Node_Id
:= Right_Opnd
(N
);
1721 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1722 -- Current overflow checking mode
1732 pragma Warnings
(Off
, Lhi
);
1733 -- Don't actually use this value
1736 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1737 -- operating on signed integer types, then the only thing this routine
1738 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1739 -- procedure will (possibly later on during recursive downward calls),
1740 -- ensure that any needed overflow/division checks are properly applied.
1742 if Mode
in Minimized_Or_Eliminated
1743 and then Is_Signed_Integer_Type
(Typ
)
1745 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
1749 -- Proceed here in SUPPRESSED or CHECKED modes
1752 and then not Backend_Divide_Checks_On_Target
1753 and then Check_Needed
(Right
, Division_Check
)
1755 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
1757 -- Deal with division check
1759 if Do_Division_Check
(N
)
1760 and then not Division_Checks_Suppressed
(Typ
)
1762 Apply_Division_Check
(N
, Rlo
, Rhi
, ROK
);
1765 -- Deal with overflow check
1767 if Do_Overflow_Check
(N
)
1768 and then not Overflow_Checks_Suppressed
(Etype
(N
))
1770 -- Test for extremely annoying case of xxx'First divided by -1
1771 -- for division of signed integer types (only overflow case).
1773 if Nkind
(N
) = N_Op_Divide
1774 and then Is_Signed_Integer_Type
(Typ
)
1776 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
1777 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1779 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1781 ((not LOK
) or else (Llo
= LLB
))
1784 Make_Raise_Constraint_Error
(Loc
,
1790 Duplicate_Subexpr_Move_Checks
(Left
),
1791 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1795 Left_Opnd
=> Duplicate_Subexpr
(Right
),
1796 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1))),
1798 Reason
=> CE_Overflow_Check_Failed
));
1803 end Apply_Divide_Checks
;
1805 --------------------------
1806 -- Apply_Division_Check --
1807 --------------------------
1809 procedure Apply_Division_Check
1815 pragma Assert
(Do_Division_Check
(N
));
1817 Loc
: constant Source_Ptr
:= Sloc
(N
);
1818 Right
: constant Node_Id
:= Right_Opnd
(N
);
1822 and then not Backend_Divide_Checks_On_Target
1823 and then Check_Needed
(Right
, Division_Check
)
1825 -- See if division by zero possible, and if so generate test. This
1826 -- part of the test is not controlled by the -gnato switch, since
1827 -- it is a Division_Check and not an Overflow_Check.
1829 if Do_Division_Check
(N
) then
1830 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1832 Make_Raise_Constraint_Error
(Loc
,
1835 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1836 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1837 Reason
=> CE_Divide_By_Zero
));
1841 end Apply_Division_Check
;
1843 ----------------------------------
1844 -- Apply_Float_Conversion_Check --
1845 ----------------------------------
1847 -- Let F and I be the source and target types of the conversion. The RM
1848 -- specifies that a floating-point value X is rounded to the nearest
1849 -- integer, with halfway cases being rounded away from zero. The rounded
1850 -- value of X is checked against I'Range.
1852 -- The catch in the above paragraph is that there is no good way to know
1853 -- whether the round-to-integer operation resulted in overflow. A remedy is
1854 -- to perform a range check in the floating-point domain instead, however:
1856 -- (1) The bounds may not be known at compile time
1857 -- (2) The check must take into account rounding or truncation.
1858 -- (3) The range of type I may not be exactly representable in F.
1859 -- (4) For the rounding case, The end-points I'First - 0.5 and
1860 -- I'Last + 0.5 may or may not be in range, depending on the
1861 -- sign of I'First and I'Last.
1862 -- (5) X may be a NaN, which will fail any comparison
1864 -- The following steps correctly convert X with rounding:
1866 -- (1) If either I'First or I'Last is not known at compile time, use
1867 -- I'Base instead of I in the next three steps and perform a
1868 -- regular range check against I'Range after conversion.
1869 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1870 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1871 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1872 -- In other words, take one of the closest floating-point numbers
1873 -- (which is an integer value) to I'First, and see if it is in
1875 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1876 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1877 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1878 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1879 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1881 -- For the truncating case, replace steps (2) and (3) as follows:
1882 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1883 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1885 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1886 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1889 procedure Apply_Float_Conversion_Check
1891 Target_Typ
: Entity_Id
)
1893 LB
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1894 HB
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1895 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1896 Expr_Type
: constant Entity_Id
:= Base_Type
(Etype
(Ck_Node
));
1897 Target_Base
: constant Entity_Id
:=
1898 Implementation_Base_Type
(Target_Typ
);
1900 Par
: constant Node_Id
:= Parent
(Ck_Node
);
1901 pragma Assert
(Nkind
(Par
) = N_Type_Conversion
);
1902 -- Parent of check node, must be a type conversion
1904 Truncate
: constant Boolean := Float_Truncate
(Par
);
1905 Max_Bound
: constant Uint
:=
1907 (Machine_Radix_Value
(Expr_Type
),
1908 Machine_Mantissa_Value
(Expr_Type
) - 1) - 1;
1910 -- Largest bound, so bound plus or minus half is a machine number of F
1912 Ifirst
, Ilast
: Uint
;
1913 -- Bounds of integer type
1916 -- Bounds to check in floating-point domain
1918 Lo_OK
, Hi_OK
: Boolean;
1919 -- True iff Lo resp. Hi belongs to I'Range
1921 Lo_Chk
, Hi_Chk
: Node_Id
;
1922 -- Expressions that are False iff check fails
1924 Reason
: RT_Exception_Code
;
1927 -- We do not need checks if we are not generating code (i.e. the full
1928 -- expander is not active). In SPARK mode, we specifically don't want
1929 -- the frontend to expand these checks, which are dealt with directly
1930 -- in the formal verification backend.
1932 if not Expander_Active
then
1936 if not Compile_Time_Known_Value
(LB
)
1937 or not Compile_Time_Known_Value
(HB
)
1940 -- First check that the value falls in the range of the base type,
1941 -- to prevent overflow during conversion and then perform a
1942 -- regular range check against the (dynamic) bounds.
1944 pragma Assert
(Target_Base
/= Target_Typ
);
1946 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Par
);
1949 Apply_Float_Conversion_Check
(Ck_Node
, Target_Base
);
1950 Set_Etype
(Temp
, Target_Base
);
1952 Insert_Action
(Parent
(Par
),
1953 Make_Object_Declaration
(Loc
,
1954 Defining_Identifier
=> Temp
,
1955 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
),
1956 Expression
=> New_Copy_Tree
(Par
)),
1957 Suppress
=> All_Checks
);
1960 Make_Raise_Constraint_Error
(Loc
,
1963 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
1964 Right_Opnd
=> New_Occurrence_Of
(Target_Typ
, Loc
)),
1965 Reason
=> CE_Range_Check_Failed
));
1966 Rewrite
(Par
, New_Occurrence_Of
(Temp
, Loc
));
1972 -- Get the (static) bounds of the target type
1974 Ifirst
:= Expr_Value
(LB
);
1975 Ilast
:= Expr_Value
(HB
);
1977 -- A simple optimization: if the expression is a universal literal,
1978 -- we can do the comparison with the bounds and the conversion to
1979 -- an integer type statically. The range checks are unchanged.
1981 if Nkind
(Ck_Node
) = N_Real_Literal
1982 and then Etype
(Ck_Node
) = Universal_Real
1983 and then Is_Integer_Type
(Target_Typ
)
1984 and then Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
1987 Int_Val
: constant Uint
:= UR_To_Uint
(Realval
(Ck_Node
));
1990 if Int_Val
<= Ilast
and then Int_Val
>= Ifirst
then
1992 -- Conversion is safe
1994 Rewrite
(Parent
(Ck_Node
),
1995 Make_Integer_Literal
(Loc
, UI_To_Int
(Int_Val
)));
1996 Analyze_And_Resolve
(Parent
(Ck_Node
), Target_Typ
);
2002 -- Check against lower bound
2004 if Truncate
and then Ifirst
> 0 then
2005 Lo
:= Pred
(Expr_Type
, UR_From_Uint
(Ifirst
));
2009 Lo
:= Succ
(Expr_Type
, UR_From_Uint
(Ifirst
- 1));
2012 elsif abs (Ifirst
) < Max_Bound
then
2013 Lo
:= UR_From_Uint
(Ifirst
) - Ureal_Half
;
2014 Lo_OK
:= (Ifirst
> 0);
2017 Lo
:= Machine
(Expr_Type
, UR_From_Uint
(Ifirst
), Round_Even
, Ck_Node
);
2018 Lo_OK
:= (Lo
>= UR_From_Uint
(Ifirst
));
2023 -- Lo_Chk := (X >= Lo)
2025 Lo_Chk
:= Make_Op_Ge
(Loc
,
2026 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2027 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2030 -- Lo_Chk := (X > Lo)
2032 Lo_Chk
:= Make_Op_Gt
(Loc
,
2033 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2034 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2037 -- Check against higher bound
2039 if Truncate
and then Ilast
< 0 then
2040 Hi
:= Succ
(Expr_Type
, UR_From_Uint
(Ilast
));
2044 Hi
:= Pred
(Expr_Type
, UR_From_Uint
(Ilast
+ 1));
2047 elsif abs (Ilast
) < Max_Bound
then
2048 Hi
:= UR_From_Uint
(Ilast
) + Ureal_Half
;
2049 Hi_OK
:= (Ilast
< 0);
2051 Hi
:= Machine
(Expr_Type
, UR_From_Uint
(Ilast
), Round_Even
, Ck_Node
);
2052 Hi_OK
:= (Hi
<= UR_From_Uint
(Ilast
));
2057 -- Hi_Chk := (X <= Hi)
2059 Hi_Chk
:= Make_Op_Le
(Loc
,
2060 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2061 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2064 -- Hi_Chk := (X < Hi)
2066 Hi_Chk
:= Make_Op_Lt
(Loc
,
2067 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2068 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2071 -- If the bounds of the target type are the same as those of the base
2072 -- type, the check is an overflow check as a range check is not
2073 -- performed in these cases.
2075 if Expr_Value
(Type_Low_Bound
(Target_Base
)) = Ifirst
2076 and then Expr_Value
(Type_High_Bound
(Target_Base
)) = Ilast
2078 Reason
:= CE_Overflow_Check_Failed
;
2080 Reason
:= CE_Range_Check_Failed
;
2083 -- Raise CE if either conditions does not hold
2085 Insert_Action
(Ck_Node
,
2086 Make_Raise_Constraint_Error
(Loc
,
2087 Condition
=> Make_Op_Not
(Loc
, Make_And_Then
(Loc
, Lo_Chk
, Hi_Chk
)),
2089 end Apply_Float_Conversion_Check
;
2091 ------------------------
2092 -- Apply_Length_Check --
2093 ------------------------
2095 procedure Apply_Length_Check
2097 Target_Typ
: Entity_Id
;
2098 Source_Typ
: Entity_Id
:= Empty
)
2101 Apply_Selected_Length_Checks
2102 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2103 end Apply_Length_Check
;
2105 -------------------------------------
2106 -- Apply_Parameter_Aliasing_Checks --
2107 -------------------------------------
2109 procedure Apply_Parameter_Aliasing_Checks
2113 Loc
: constant Source_Ptr
:= Sloc
(Call
);
2115 function May_Cause_Aliasing
2116 (Formal_1
: Entity_Id
;
2117 Formal_2
: Entity_Id
) return Boolean;
2118 -- Determine whether two formal parameters can alias each other
2119 -- depending on their modes.
2121 function Original_Actual
(N
: Node_Id
) return Node_Id
;
2122 -- The expander may replace an actual with a temporary for the sake of
2123 -- side effect removal. The temporary may hide a potential aliasing as
2124 -- it does not share the address of the actual. This routine attempts
2125 -- to retrieve the original actual.
2127 procedure Overlap_Check
2128 (Actual_1
: Node_Id
;
2130 Formal_1
: Entity_Id
;
2131 Formal_2
: Entity_Id
;
2132 Check
: in out Node_Id
);
2133 -- Create a check to determine whether Actual_1 overlaps with Actual_2.
2134 -- If detailed exception messages are enabled, the check is augmented to
2135 -- provide information about the names of the corresponding formals. See
2136 -- the body for details. Actual_1 and Actual_2 denote the two actuals to
2137 -- be tested. Formal_1 and Formal_2 denote the corresponding formals.
2138 -- Check contains all and-ed simple tests generated so far or remains
2139 -- unchanged in the case of detailed exception messaged.
2141 ------------------------
2142 -- May_Cause_Aliasing --
2143 ------------------------
2145 function May_Cause_Aliasing
2146 (Formal_1
: Entity_Id
;
2147 Formal_2
: Entity_Id
) return Boolean
2150 -- The following combination cannot lead to aliasing
2152 -- Formal 1 Formal 2
2155 if Ekind
(Formal_1
) = E_In_Parameter
2157 Ekind
(Formal_2
) = E_In_Parameter
2161 -- The following combinations may lead to aliasing
2163 -- Formal 1 Formal 2
2173 end May_Cause_Aliasing
;
2175 ---------------------
2176 -- Original_Actual --
2177 ---------------------
2179 function Original_Actual
(N
: Node_Id
) return Node_Id
is
2181 if Nkind
(N
) = N_Type_Conversion
then
2182 return Expression
(N
);
2184 -- The expander created a temporary to capture the result of a type
2185 -- conversion where the expression is the real actual.
2187 elsif Nkind
(N
) = N_Identifier
2188 and then Present
(Original_Node
(N
))
2189 and then Nkind
(Original_Node
(N
)) = N_Type_Conversion
2191 return Expression
(Original_Node
(N
));
2195 end Original_Actual
;
2201 procedure Overlap_Check
2202 (Actual_1
: Node_Id
;
2204 Formal_1
: Entity_Id
;
2205 Formal_2
: Entity_Id
;
2206 Check
: in out Node_Id
)
2209 ID_Casing
: constant Casing_Type
:=
2210 Identifier_Casing
(Source_Index
(Current_Sem_Unit
));
2214 -- Actual_1'Overlaps_Storage (Actual_2)
2217 Make_Attribute_Reference
(Loc
,
2218 Prefix
=> New_Copy_Tree
(Original_Actual
(Actual_1
)),
2219 Attribute_Name
=> Name_Overlaps_Storage
,
2221 New_List
(New_Copy_Tree
(Original_Actual
(Actual_2
))));
2223 -- Generate the following check when detailed exception messages are
2226 -- if Actual_1'Overlaps_Storage (Actual_2) then
2227 -- raise Program_Error with <detailed message>;
2230 if Exception_Extra_Info
then
2233 -- Do not generate location information for internal calls
2235 if Comes_From_Source
(Call
) then
2236 Store_String_Chars
(Build_Location_String
(Loc
));
2237 Store_String_Char
(' ');
2240 Store_String_Chars
("aliased parameters, actuals for """);
2242 Get_Name_String
(Chars
(Formal_1
));
2243 Set_Casing
(ID_Casing
);
2244 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2246 Store_String_Chars
(""" and """);
2248 Get_Name_String
(Chars
(Formal_2
));
2249 Set_Casing
(ID_Casing
);
2250 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2252 Store_String_Chars
(""" overlap");
2254 Insert_Action
(Call
,
2255 Make_If_Statement
(Loc
,
2257 Then_Statements
=> New_List
(
2258 Make_Raise_Statement
(Loc
,
2260 New_Occurrence_Of
(Standard_Program_Error
, Loc
),
2261 Expression
=> Make_String_Literal
(Loc
, End_String
)))));
2263 -- Create a sequence of overlapping checks by and-ing them all
2273 Right_Opnd
=> Cond
);
2283 Formal_1
: Entity_Id
;
2284 Formal_2
: Entity_Id
;
2286 -- Start of processing for Apply_Parameter_Aliasing_Checks
2291 Actual_1
:= First_Actual
(Call
);
2292 Formal_1
:= First_Formal
(Subp
);
2293 while Present
(Actual_1
) and then Present
(Formal_1
) loop
2295 -- Ensure that the actual is an object that is not passed by value.
2296 -- Elementary types are always passed by value, therefore actuals of
2297 -- such types cannot lead to aliasing.
2299 if Is_Object_Reference
(Original_Actual
(Actual_1
))
2300 and then not Is_Elementary_Type
(Etype
(Original_Actual
(Actual_1
)))
2302 Actual_2
:= Next_Actual
(Actual_1
);
2303 Formal_2
:= Next_Formal
(Formal_1
);
2304 while Present
(Actual_2
) and then Present
(Formal_2
) loop
2306 -- The other actual we are testing against must also denote
2307 -- a non pass-by-value object. Generate the check only when
2308 -- the mode of the two formals may lead to aliasing.
2310 if Is_Object_Reference
(Original_Actual
(Actual_2
))
2312 Is_Elementary_Type
(Etype
(Original_Actual
(Actual_2
)))
2313 and then May_Cause_Aliasing
(Formal_1
, Formal_2
)
2316 (Actual_1
=> Actual_1
,
2317 Actual_2
=> Actual_2
,
2318 Formal_1
=> Formal_1
,
2319 Formal_2
=> Formal_2
,
2323 Next_Actual
(Actual_2
);
2324 Next_Formal
(Formal_2
);
2328 Next_Actual
(Actual_1
);
2329 Next_Formal
(Formal_1
);
2332 -- Place a simple check right before the call
2334 if Present
(Check
) and then not Exception_Extra_Info
then
2335 Insert_Action
(Call
,
2336 Make_Raise_Program_Error
(Loc
,
2338 Reason
=> PE_Aliased_Parameters
));
2340 end Apply_Parameter_Aliasing_Checks
;
2342 -------------------------------------
2343 -- Apply_Parameter_Validity_Checks --
2344 -------------------------------------
2346 procedure Apply_Parameter_Validity_Checks
(Subp
: Entity_Id
) is
2347 Subp_Decl
: Node_Id
;
2349 procedure Add_Validity_Check
2350 (Context
: Entity_Id
;
2352 For_Result
: Boolean := False);
2353 -- Add a single 'Valid[_Scalar] check which verifies the initialization
2354 -- of Context. PPC_Nam denotes the pre or post condition pragma name.
2355 -- Set flag For_Result when to verify the result of a function.
2357 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
);
2358 -- Create a pre or post condition pragma with name PPC_Nam which
2359 -- tests expression Check.
2361 ------------------------
2362 -- Add_Validity_Check --
2363 ------------------------
2365 procedure Add_Validity_Check
2366 (Context
: Entity_Id
;
2368 For_Result
: Boolean := False)
2370 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2371 Typ
: constant Entity_Id
:= Etype
(Context
);
2376 -- Pick the proper version of 'Valid depending on the type of the
2377 -- context. If the context is not eligible for such a check, return.
2379 if Is_Scalar_Type
(Typ
) then
2381 elsif not No_Scalar_Parts
(Typ
) then
2382 Nam
:= Name_Valid_Scalars
;
2387 -- Step 1: Create the expression to verify the validity of the
2390 Check
:= New_Occurrence_Of
(Context
, Loc
);
2392 -- When processing a function result, use 'Result. Generate
2397 Make_Attribute_Reference
(Loc
,
2399 Attribute_Name
=> Name_Result
);
2403 -- Context['Result]'Valid[_Scalars]
2406 Make_Attribute_Reference
(Loc
,
2408 Attribute_Name
=> Nam
);
2410 -- Step 2: Create a pre or post condition pragma
2412 Build_PPC_Pragma
(PPC_Nam
, Check
);
2413 end Add_Validity_Check
;
2415 ----------------------
2416 -- Build_PPC_Pragma --
2417 ----------------------
2419 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
) is
2420 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2427 Pragma_Identifier
=> Make_Identifier
(Loc
, PPC_Nam
),
2428 Pragma_Argument_Associations
=> New_List
(
2429 Make_Pragma_Argument_Association
(Loc
,
2430 Chars
=> Name_Check
,
2431 Expression
=> Check
)));
2433 -- Add a message unless exception messages are suppressed
2435 if not Exception_Locations_Suppressed
then
2436 Append_To
(Pragma_Argument_Associations
(Prag
),
2437 Make_Pragma_Argument_Association
(Loc
,
2438 Chars
=> Name_Message
,
2440 Make_String_Literal
(Loc
,
2441 Strval
=> "failed " & Get_Name_String
(PPC_Nam
) &
2442 " from " & Build_Location_String
(Loc
))));
2445 -- Insert the pragma in the tree
2447 if Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
then
2448 Add_Global_Declaration
(Prag
);
2451 -- PPC pragmas associated with subprogram bodies must be inserted in
2452 -- the declarative part of the body.
2454 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
then
2455 Decls
:= Declarations
(Subp_Decl
);
2459 Set_Declarations
(Subp_Decl
, Decls
);
2462 Prepend_To
(Decls
, Prag
);
2464 -- Ensure the proper visibility of the subprogram body and its
2471 -- For subprogram declarations insert the PPC pragma right after the
2472 -- declarative node.
2475 Insert_After_And_Analyze
(Subp_Decl
, Prag
);
2477 end Build_PPC_Pragma
;
2482 Subp_Spec
: Node_Id
;
2484 -- Start of processing for Apply_Parameter_Validity_Checks
2487 -- Extract the subprogram specification and declaration nodes
2489 Subp_Spec
:= Parent
(Subp
);
2491 if Nkind
(Subp_Spec
) = N_Defining_Program_Unit_Name
then
2492 Subp_Spec
:= Parent
(Subp_Spec
);
2495 Subp_Decl
:= Parent
(Subp_Spec
);
2497 if not Comes_From_Source
(Subp
)
2499 -- Do not process formal subprograms because the corresponding actual
2500 -- will receive the proper checks when the instance is analyzed.
2502 or else Is_Formal_Subprogram
(Subp
)
2504 -- Do not process imported subprograms since pre and post conditions
2505 -- are never verified on routines coming from a different language.
2507 or else Is_Imported
(Subp
)
2508 or else Is_Intrinsic_Subprogram
(Subp
)
2510 -- The PPC pragmas generated by this routine do not correspond to
2511 -- source aspects, therefore they cannot be applied to abstract
2514 or else Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
2516 -- Do not consider subprogram renaminds because the renamed entity
2517 -- already has the proper PPC pragmas.
2519 or else Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
2521 -- Do not process null procedures because there is no benefit of
2522 -- adding the checks to a no action routine.
2524 or else (Nkind
(Subp_Spec
) = N_Procedure_Specification
2525 and then Null_Present
(Subp_Spec
))
2530 -- Inspect all the formals applying aliasing and scalar initialization
2531 -- checks where applicable.
2533 Formal
:= First_Formal
(Subp
);
2534 while Present
(Formal
) loop
2536 -- Generate the following scalar initialization checks for each
2537 -- formal parameter:
2539 -- mode IN - Pre => Formal'Valid[_Scalars]
2540 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2541 -- mode OUT - Post => Formal'Valid[_Scalars]
2543 if Check_Validity_Of_Parameters
then
2544 if Ekind_In
(Formal
, E_In_Parameter
, E_In_Out_Parameter
) then
2545 Add_Validity_Check
(Formal
, Name_Precondition
, False);
2548 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
2549 Add_Validity_Check
(Formal
, Name_Postcondition
, False);
2553 Next_Formal
(Formal
);
2556 -- Generate following scalar initialization check for function result:
2558 -- Post => Subp'Result'Valid[_Scalars]
2560 if Check_Validity_Of_Parameters
and then Ekind
(Subp
) = E_Function
then
2561 Add_Validity_Check
(Subp
, Name_Postcondition
, True);
2563 end Apply_Parameter_Validity_Checks
;
2565 ---------------------------
2566 -- Apply_Predicate_Check --
2567 ---------------------------
2569 procedure Apply_Predicate_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
2573 if Present
(Predicate_Function
(Typ
)) then
2576 while Present
(S
) and then not Is_Subprogram
(S
) loop
2580 -- A predicate check does not apply within internally generated
2581 -- subprograms, such as TSS functions.
2583 if Within_Internal_Subprogram
then
2586 -- If the check appears within the predicate function itself, it
2587 -- means that the user specified a check whose formal is the
2588 -- predicated subtype itself, rather than some covering type. This
2589 -- is likely to be a common error, and thus deserves a warning.
2591 elsif Present
(S
) and then S
= Predicate_Function
(Typ
) then
2593 ("predicate check includes a function call that "
2594 & "requires a predicate check??", Parent
(N
));
2596 ("\this will result in infinite recursion??", Parent
(N
));
2598 Make_Raise_Storage_Error
(Sloc
(N
),
2599 Reason
=> SE_Infinite_Recursion
));
2601 -- Here for normal case of predicate active
2604 -- If the type has a static predicate and the expression is known
2605 -- at compile time, see if the expression satisfies the predicate.
2607 Check_Expression_Against_Static_Predicate
(N
, Typ
);
2610 Make_Predicate_Check
(Typ
, Duplicate_Subexpr
(N
)));
2613 end Apply_Predicate_Check
;
2615 -----------------------
2616 -- Apply_Range_Check --
2617 -----------------------
2619 procedure Apply_Range_Check
2621 Target_Typ
: Entity_Id
;
2622 Source_Typ
: Entity_Id
:= Empty
)
2625 Apply_Selected_Range_Checks
2626 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2627 end Apply_Range_Check
;
2629 ------------------------------
2630 -- Apply_Scalar_Range_Check --
2631 ------------------------------
2633 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
2634 -- off if it is already set on.
2636 procedure Apply_Scalar_Range_Check
2638 Target_Typ
: Entity_Id
;
2639 Source_Typ
: Entity_Id
:= Empty
;
2640 Fixed_Int
: Boolean := False)
2642 Parnt
: constant Node_Id
:= Parent
(Expr
);
2644 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
2645 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
2648 Is_Subscr_Ref
: Boolean;
2649 -- Set true if Expr is a subscript
2651 Is_Unconstrained_Subscr_Ref
: Boolean;
2652 -- Set true if Expr is a subscript of an unconstrained array. In this
2653 -- case we do not attempt to do an analysis of the value against the
2654 -- range of the subscript, since we don't know the actual subtype.
2657 -- Set to True if Expr should be regarded as a real value even though
2658 -- the type of Expr might be discrete.
2660 procedure Bad_Value
;
2661 -- Procedure called if value is determined to be out of range
2667 procedure Bad_Value
is
2669 Apply_Compile_Time_Constraint_Error
2670 (Expr
, "value not in range of}??", CE_Range_Check_Failed
,
2675 -- Start of processing for Apply_Scalar_Range_Check
2678 -- Return if check obviously not needed
2681 -- Not needed inside generic
2685 -- Not needed if previous error
2687 or else Target_Typ
= Any_Type
2688 or else Nkind
(Expr
) = N_Error
2690 -- Not needed for non-scalar type
2692 or else not Is_Scalar_Type
(Target_Typ
)
2694 -- Not needed if we know node raises CE already
2696 or else Raises_Constraint_Error
(Expr
)
2701 -- Now, see if checks are suppressed
2704 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
2706 if Is_Subscr_Ref
then
2707 Arr
:= Prefix
(Parnt
);
2708 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
2710 if Is_Access_Type
(Arr_Typ
) then
2711 Arr_Typ
:= Designated_Type
(Arr_Typ
);
2715 if not Do_Range_Check
(Expr
) then
2717 -- Subscript reference. Check for Index_Checks suppressed
2719 if Is_Subscr_Ref
then
2721 -- Check array type and its base type
2723 if Index_Checks_Suppressed
(Arr_Typ
)
2724 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
2728 -- Check array itself if it is an entity name
2730 elsif Is_Entity_Name
(Arr
)
2731 and then Index_Checks_Suppressed
(Entity
(Arr
))
2735 -- Check expression itself if it is an entity name
2737 elsif Is_Entity_Name
(Expr
)
2738 and then Index_Checks_Suppressed
(Entity
(Expr
))
2743 -- All other cases, check for Range_Checks suppressed
2746 -- Check target type and its base type
2748 if Range_Checks_Suppressed
(Target_Typ
)
2749 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
2753 -- Check expression itself if it is an entity name
2755 elsif Is_Entity_Name
(Expr
)
2756 and then Range_Checks_Suppressed
(Entity
(Expr
))
2760 -- If Expr is part of an assignment statement, then check left
2761 -- side of assignment if it is an entity name.
2763 elsif Nkind
(Parnt
) = N_Assignment_Statement
2764 and then Is_Entity_Name
(Name
(Parnt
))
2765 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
2772 -- Do not set range checks if they are killed
2774 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
2775 and then Kill_Range_Check
(Expr
)
2780 -- Do not set range checks for any values from System.Scalar_Values
2781 -- since the whole idea of such values is to avoid checking them.
2783 if Is_Entity_Name
(Expr
)
2784 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
2789 -- Now see if we need a check
2791 if No
(Source_Typ
) then
2792 S_Typ
:= Etype
(Expr
);
2794 S_Typ
:= Source_Typ
;
2797 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
2801 Is_Unconstrained_Subscr_Ref
:=
2802 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
2804 -- Special checks for floating-point type
2806 if Is_Floating_Point_Type
(S_Typ
) then
2808 -- Always do a range check if the source type includes infinities and
2809 -- the target type does not include infinities. We do not do this if
2810 -- range checks are killed.
2812 if Has_Infinities
(S_Typ
)
2813 and then not Has_Infinities
(Target_Typ
)
2815 Enable_Range_Check
(Expr
);
2817 -- Always do a range check for operators if option set
2819 elsif Check_Float_Overflow
and then Nkind
(Expr
) in N_Op
then
2820 Enable_Range_Check
(Expr
);
2824 -- Return if we know expression is definitely in the range of the target
2825 -- type as determined by Determine_Range. Right now we only do this for
2826 -- discrete types, and not fixed-point or floating-point types.
2828 -- The additional less-precise tests below catch these cases
2830 -- Note: skip this if we are given a source_typ, since the point of
2831 -- supplying a Source_Typ is to stop us looking at the expression.
2832 -- We could sharpen this test to be out parameters only ???
2834 if Is_Discrete_Type
(Target_Typ
)
2835 and then Is_Discrete_Type
(Etype
(Expr
))
2836 and then not Is_Unconstrained_Subscr_Ref
2837 and then No
(Source_Typ
)
2840 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
2841 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
2846 if Compile_Time_Known_Value
(Tlo
)
2847 and then Compile_Time_Known_Value
(Thi
)
2850 Lov
: constant Uint
:= Expr_Value
(Tlo
);
2851 Hiv
: constant Uint
:= Expr_Value
(Thi
);
2854 -- If range is null, we for sure have a constraint error
2855 -- (we don't even need to look at the value involved,
2856 -- since all possible values will raise CE).
2863 -- Otherwise determine range of value
2865 Determine_Range
(Expr
, OK
, Lo
, Hi
, Assume_Valid
=> True);
2869 -- If definitely in range, all OK
2871 if Lo
>= Lov
and then Hi
<= Hiv
then
2874 -- If definitely not in range, warn
2876 elsif Lov
> Hi
or else Hiv
< Lo
then
2880 -- Otherwise we don't know
2892 Is_Floating_Point_Type
(S_Typ
)
2893 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
2895 -- Check if we can determine at compile time whether Expr is in the
2896 -- range of the target type. Note that if S_Typ is within the bounds
2897 -- of Target_Typ then this must be the case. This check is meaningful
2898 -- only if this is not a conversion between integer and real types.
2900 if not Is_Unconstrained_Subscr_Ref
2901 and then Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
2903 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
2905 Is_In_Range
(Expr
, Target_Typ
,
2906 Assume_Valid
=> True,
2907 Fixed_Int
=> Fixed_Int
,
2908 Int_Real
=> Int_Real
))
2912 elsif Is_Out_Of_Range
(Expr
, Target_Typ
,
2913 Assume_Valid
=> True,
2914 Fixed_Int
=> Fixed_Int
,
2915 Int_Real
=> Int_Real
)
2920 -- Floating-point case
2921 -- In the floating-point case, we only do range checks if the type is
2922 -- constrained. We definitely do NOT want range checks for unconstrained
2923 -- types, since we want to have infinities
2925 elsif Is_Floating_Point_Type
(S_Typ
) then
2927 -- Normally, we only do range checks if the type is constrained. We do
2928 -- NOT want range checks for unconstrained types, since we want to have
2929 -- infinities. Override this decision in Check_Float_Overflow mode.
2931 if Is_Constrained
(S_Typ
) or else Check_Float_Overflow
then
2932 Enable_Range_Check
(Expr
);
2935 -- For all other cases we enable a range check unconditionally
2938 Enable_Range_Check
(Expr
);
2941 end Apply_Scalar_Range_Check
;
2943 ----------------------------------
2944 -- Apply_Selected_Length_Checks --
2945 ----------------------------------
2947 procedure Apply_Selected_Length_Checks
2949 Target_Typ
: Entity_Id
;
2950 Source_Typ
: Entity_Id
;
2951 Do_Static
: Boolean)
2954 R_Result
: Check_Result
;
2957 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
2958 Checks_On
: constant Boolean :=
2959 (not Index_Checks_Suppressed
(Target_Typ
))
2960 or else (not Length_Checks_Suppressed
(Target_Typ
));
2963 -- Note: this means that we lose some useful warnings if the expander
2964 -- is not active, and we also lose these warnings in SPARK mode ???
2966 if not Expander_Active
then
2971 Selected_Length_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
2973 for J
in 1 .. 2 loop
2974 R_Cno
:= R_Result
(J
);
2975 exit when No
(R_Cno
);
2977 -- A length check may mention an Itype which is attached to a
2978 -- subsequent node. At the top level in a package this can cause
2979 -- an order-of-elaboration problem, so we make sure that the itype
2980 -- is referenced now.
2982 if Ekind
(Current_Scope
) = E_Package
2983 and then Is_Compilation_Unit
(Current_Scope
)
2985 Ensure_Defined
(Target_Typ
, Ck_Node
);
2987 if Present
(Source_Typ
) then
2988 Ensure_Defined
(Source_Typ
, Ck_Node
);
2990 elsif Is_Itype
(Etype
(Ck_Node
)) then
2991 Ensure_Defined
(Etype
(Ck_Node
), Ck_Node
);
2995 -- If the item is a conditional raise of constraint error, then have
2996 -- a look at what check is being performed and ???
2998 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
2999 and then Present
(Condition
(R_Cno
))
3001 Cond
:= Condition
(R_Cno
);
3003 -- Case where node does not now have a dynamic check
3005 if not Has_Dynamic_Length_Check
(Ck_Node
) then
3007 -- If checks are on, just insert the check
3010 Insert_Action
(Ck_Node
, R_Cno
);
3012 if not Do_Static
then
3013 Set_Has_Dynamic_Length_Check
(Ck_Node
);
3016 -- If checks are off, then analyze the length check after
3017 -- temporarily attaching it to the tree in case the relevant
3018 -- condition can be evaluated at compile time. We still want a
3019 -- compile time warning in this case.
3022 Set_Parent
(R_Cno
, Ck_Node
);
3027 -- Output a warning if the condition is known to be True
3029 if Is_Entity_Name
(Cond
)
3030 and then Entity
(Cond
) = Standard_True
3032 Apply_Compile_Time_Constraint_Error
3033 (Ck_Node
, "wrong length for array of}??",
3034 CE_Length_Check_Failed
,
3038 -- If we were only doing a static check, or if checks are not
3039 -- on, then we want to delete the check, since it is not needed.
3040 -- We do this by replacing the if statement by a null statement
3042 elsif Do_Static
or else not Checks_On
then
3043 Remove_Warning_Messages
(R_Cno
);
3044 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3048 Install_Static_Check
(R_Cno
, Loc
);
3051 end Apply_Selected_Length_Checks
;
3053 ---------------------------------
3054 -- Apply_Selected_Range_Checks --
3055 ---------------------------------
3057 procedure Apply_Selected_Range_Checks
3059 Target_Typ
: Entity_Id
;
3060 Source_Typ
: Entity_Id
;
3061 Do_Static
: Boolean)
3063 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
3064 Checks_On
: constant Boolean :=
3065 not Index_Checks_Suppressed
(Target_Typ
)
3067 not Range_Checks_Suppressed
(Target_Typ
);
3071 R_Result
: Check_Result
;
3074 if not Expander_Active
or not Checks_On
then
3079 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
3081 for J
in 1 .. 2 loop
3082 R_Cno
:= R_Result
(J
);
3083 exit when No
(R_Cno
);
3085 -- The range check requires runtime evaluation. Depending on what its
3086 -- triggering condition is, the check may be converted into a compile
3087 -- time constraint check.
3089 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
3090 and then Present
(Condition
(R_Cno
))
3092 Cond
:= Condition
(R_Cno
);
3094 -- Insert the range check before the related context. Note that
3095 -- this action analyses the triggering condition.
3097 Insert_Action
(Ck_Node
, R_Cno
);
3099 -- This old code doesn't make sense, why is the context flagged as
3100 -- requiring dynamic range checks now in the middle of generating
3103 if not Do_Static
then
3104 Set_Has_Dynamic_Range_Check
(Ck_Node
);
3107 -- The triggering condition evaluates to True, the range check
3108 -- can be converted into a compile time constraint check.
3110 if Is_Entity_Name
(Cond
)
3111 and then Entity
(Cond
) = Standard_True
3113 -- Since an N_Range is technically not an expression, we have
3114 -- to set one of the bounds to C_E and then just flag the
3115 -- N_Range. The warning message will point to the lower bound
3116 -- and complain about a range, which seems OK.
3118 if Nkind
(Ck_Node
) = N_Range
then
3119 Apply_Compile_Time_Constraint_Error
3120 (Low_Bound
(Ck_Node
),
3121 "static range out of bounds of}??",
3122 CE_Range_Check_Failed
,
3126 Set_Raises_Constraint_Error
(Ck_Node
);
3129 Apply_Compile_Time_Constraint_Error
3131 "static value out of range of}?",
3132 CE_Range_Check_Failed
,
3137 -- If we were only doing a static check, or if checks are not
3138 -- on, then we want to delete the check, since it is not needed.
3139 -- We do this by replacing the if statement by a null statement
3141 -- Why are we even generating checks if checks are turned off ???
3143 elsif Do_Static
or else not Checks_On
then
3144 Remove_Warning_Messages
(R_Cno
);
3145 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3148 -- The range check raises Constrant_Error explicitly
3151 Install_Static_Check
(R_Cno
, Loc
);
3154 end Apply_Selected_Range_Checks
;
3156 -------------------------------
3157 -- Apply_Static_Length_Check --
3158 -------------------------------
3160 procedure Apply_Static_Length_Check
3162 Target_Typ
: Entity_Id
;
3163 Source_Typ
: Entity_Id
:= Empty
)
3166 Apply_Selected_Length_Checks
3167 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
3168 end Apply_Static_Length_Check
;
3170 -------------------------------------
3171 -- Apply_Subscript_Validity_Checks --
3172 -------------------------------------
3174 procedure Apply_Subscript_Validity_Checks
(Expr
: Node_Id
) is
3178 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
3180 -- Loop through subscripts
3182 Sub
:= First
(Expressions
(Expr
));
3183 while Present
(Sub
) loop
3185 -- Check one subscript. Note that we do not worry about enumeration
3186 -- type with holes, since we will convert the value to a Pos value
3187 -- for the subscript, and that convert will do the necessary validity
3190 Ensure_Valid
(Sub
, Holes_OK
=> True);
3192 -- Move to next subscript
3196 end Apply_Subscript_Validity_Checks
;
3198 ----------------------------------
3199 -- Apply_Type_Conversion_Checks --
3200 ----------------------------------
3202 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
3203 Target_Type
: constant Entity_Id
:= Etype
(N
);
3204 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
3205 Expr
: constant Node_Id
:= Expression
(N
);
3207 Expr_Type
: constant Entity_Id
:= Underlying_Type
(Etype
(Expr
));
3208 -- Note: if Etype (Expr) is a private type without discriminants, its
3209 -- full view might have discriminants with defaults, so we need the
3210 -- full view here to retrieve the constraints.
3213 if Inside_A_Generic
then
3216 -- Skip these checks if serious errors detected, there are some nasty
3217 -- situations of incomplete trees that blow things up.
3219 elsif Serious_Errors_Detected
> 0 then
3222 -- Never generate discriminant checks for Unchecked_Union types
3224 elsif Present
(Expr_Type
)
3225 and then Is_Unchecked_Union
(Expr_Type
)
3229 -- Scalar type conversions of the form Target_Type (Expr) require a
3230 -- range check if we cannot be sure that Expr is in the base type of
3231 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3232 -- are not quite the same condition from an implementation point of
3233 -- view, but clearly the second includes the first.
3235 elsif Is_Scalar_Type
(Target_Type
) then
3237 Conv_OK
: constant Boolean := Conversion_OK
(N
);
3238 -- If the Conversion_OK flag on the type conversion is set and no
3239 -- floating-point type is involved in the type conversion then
3240 -- fixed-point values must be read as integral values.
3242 Float_To_Int
: constant Boolean :=
3243 Is_Floating_Point_Type
(Expr_Type
)
3244 and then Is_Integer_Type
(Target_Type
);
3247 if not Overflow_Checks_Suppressed
(Target_Base
)
3248 and then not Overflow_Checks_Suppressed
(Target_Type
)
3250 In_Subrange_Of
(Expr_Type
, Target_Base
, Fixed_Int
=> Conv_OK
)
3251 and then not Float_To_Int
3253 Activate_Overflow_Check
(N
);
3256 if not Range_Checks_Suppressed
(Target_Type
)
3257 and then not Range_Checks_Suppressed
(Expr_Type
)
3259 if Float_To_Int
then
3260 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
3262 Apply_Scalar_Range_Check
3263 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
3265 -- If the target type has predicates, we need to indicate
3266 -- the need for a check, even if Determine_Range finds that
3267 -- the value is within bounds. This may be the case e.g for
3268 -- a division with a constant denominator.
3270 if Has_Predicates
(Target_Type
) then
3271 Enable_Range_Check
(Expr
);
3277 elsif Comes_From_Source
(N
)
3278 and then not Discriminant_Checks_Suppressed
(Target_Type
)
3279 and then Is_Record_Type
(Target_Type
)
3280 and then Is_Derived_Type
(Target_Type
)
3281 and then not Is_Tagged_Type
(Target_Type
)
3282 and then not Is_Constrained
(Target_Type
)
3283 and then Present
(Stored_Constraint
(Target_Type
))
3285 -- An unconstrained derived type may have inherited discriminant.
3286 -- Build an actual discriminant constraint list using the stored
3287 -- constraint, to verify that the expression of the parent type
3288 -- satisfies the constraints imposed by the (unconstrained) derived
3289 -- type. This applies to value conversions, not to view conversions
3293 Loc
: constant Source_Ptr
:= Sloc
(N
);
3295 Constraint
: Elmt_Id
;
3296 Discr_Value
: Node_Id
;
3299 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
3300 Old_Constraints
: constant Elist_Id
:=
3301 Discriminant_Constraint
(Expr_Type
);
3304 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
3305 while Present
(Constraint
) loop
3306 Discr_Value
:= Node
(Constraint
);
3308 if Is_Entity_Name
(Discr_Value
)
3309 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
3311 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
3314 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
3316 -- Parent is constrained by new discriminant. Obtain
3317 -- Value of original discriminant in expression. If the
3318 -- new discriminant has been used to constrain more than
3319 -- one of the stored discriminants, this will provide the
3320 -- required consistency check.
3323 (Make_Selected_Component
(Loc
,
3325 Duplicate_Subexpr_No_Checks
3326 (Expr
, Name_Req
=> True),
3328 Make_Identifier
(Loc
, Chars
(Discr
))),
3332 -- Discriminant of more remote ancestor ???
3337 -- Derived type definition has an explicit value for this
3338 -- stored discriminant.
3342 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
3346 Next_Elmt
(Constraint
);
3349 -- Use the unconstrained expression type to retrieve the
3350 -- discriminants of the parent, and apply momentarily the
3351 -- discriminant constraint synthesized above.
3353 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
3354 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
3355 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
3358 Make_Raise_Constraint_Error
(Loc
,
3360 Reason
=> CE_Discriminant_Check_Failed
));
3363 -- For arrays, checks are set now, but conversions are applied during
3364 -- expansion, to take into accounts changes of representation. The
3365 -- checks become range checks on the base type or length checks on the
3366 -- subtype, depending on whether the target type is unconstrained or
3367 -- constrained. Note that the range check is put on the expression of a
3368 -- type conversion, while the length check is put on the type conversion
3371 elsif Is_Array_Type
(Target_Type
) then
3372 if Is_Constrained
(Target_Type
) then
3373 Set_Do_Length_Check
(N
);
3375 Set_Do_Range_Check
(Expr
);
3378 end Apply_Type_Conversion_Checks
;
3380 ----------------------------------------------
3381 -- Apply_Universal_Integer_Attribute_Checks --
3382 ----------------------------------------------
3384 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
3385 Loc
: constant Source_Ptr
:= Sloc
(N
);
3386 Typ
: constant Entity_Id
:= Etype
(N
);
3389 if Inside_A_Generic
then
3392 -- Nothing to do if checks are suppressed
3394 elsif Range_Checks_Suppressed
(Typ
)
3395 and then Overflow_Checks_Suppressed
(Typ
)
3399 -- Nothing to do if the attribute does not come from source. The
3400 -- internal attributes we generate of this type do not need checks,
3401 -- and furthermore the attempt to check them causes some circular
3402 -- elaboration orders when dealing with packed types.
3404 elsif not Comes_From_Source
(N
) then
3407 -- If the prefix is a selected component that depends on a discriminant
3408 -- the check may improperly expose a discriminant instead of using
3409 -- the bounds of the object itself. Set the type of the attribute to
3410 -- the base type of the context, so that a check will be imposed when
3411 -- needed (e.g. if the node appears as an index).
3413 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
3414 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
3415 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
3417 Set_Etype
(N
, Base_Type
(Typ
));
3419 -- Otherwise, replace the attribute node with a type conversion node
3420 -- whose expression is the attribute, retyped to universal integer, and
3421 -- whose subtype mark is the target type. The call to analyze this
3422 -- conversion will set range and overflow checks as required for proper
3423 -- detection of an out of range value.
3426 Set_Etype
(N
, Universal_Integer
);
3427 Set_Analyzed
(N
, True);
3430 Make_Type_Conversion
(Loc
,
3431 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
3432 Expression
=> Relocate_Node
(N
)));
3434 Analyze_And_Resolve
(N
, Typ
);
3437 end Apply_Universal_Integer_Attribute_Checks
;
3439 -------------------------------------
3440 -- Atomic_Synchronization_Disabled --
3441 -------------------------------------
3443 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3444 -- using a bogus check called Atomic_Synchronization. This is to make it
3445 -- more convenient to get exactly the same semantics as [Un]Suppress.
3447 function Atomic_Synchronization_Disabled
(E
: Entity_Id
) return Boolean is
3449 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3450 -- looks enabled, since it is never disabled.
3452 if Debug_Flag_Dot_E
then
3455 -- If debug flag d.d is set then always return True, i.e. all atomic
3456 -- sync looks disabled, since it always tests True.
3458 elsif Debug_Flag_Dot_D
then
3461 -- If entity present, then check result for that entity
3463 elsif Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3464 return Is_Check_Suppressed
(E
, Atomic_Synchronization
);
3466 -- Otherwise result depends on current scope setting
3469 return Scope_Suppress
.Suppress
(Atomic_Synchronization
);
3471 end Atomic_Synchronization_Disabled
;
3473 -------------------------------
3474 -- Build_Discriminant_Checks --
3475 -------------------------------
3477 function Build_Discriminant_Checks
3479 T_Typ
: Entity_Id
) return Node_Id
3481 Loc
: constant Source_Ptr
:= Sloc
(N
);
3484 Disc_Ent
: Entity_Id
;
3488 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
;
3490 ----------------------------------
3491 -- Aggregate_Discriminant_Value --
3492 ----------------------------------
3494 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
is
3498 -- The aggregate has been normalized with named associations. We use
3499 -- the Chars field to locate the discriminant to take into account
3500 -- discriminants in derived types, which carry the same name as those
3503 Assoc
:= First
(Component_Associations
(N
));
3504 while Present
(Assoc
) loop
3505 if Chars
(First
(Choices
(Assoc
))) = Chars
(Disc
) then
3506 return Expression
(Assoc
);
3512 -- Discriminant must have been found in the loop above
3514 raise Program_Error
;
3515 end Aggregate_Discriminant_Val
;
3517 -- Start of processing for Build_Discriminant_Checks
3520 -- Loop through discriminants evolving the condition
3523 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
3525 -- For a fully private type, use the discriminants of the parent type
3527 if Is_Private_Type
(T_Typ
)
3528 and then No
(Full_View
(T_Typ
))
3530 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
3532 Disc_Ent
:= First_Discriminant
(T_Typ
);
3535 while Present
(Disc
) loop
3536 Dval
:= Node
(Disc
);
3538 if Nkind
(Dval
) = N_Identifier
3539 and then Ekind
(Entity
(Dval
)) = E_Discriminant
3541 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
3543 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
3546 -- If we have an Unchecked_Union node, we can infer the discriminants
3549 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
3551 Get_Discriminant_Value
(
3552 First_Discriminant
(T_Typ
),
3554 Stored_Constraint
(T_Typ
)));
3556 elsif Nkind
(N
) = N_Aggregate
then
3558 Duplicate_Subexpr_No_Checks
3559 (Aggregate_Discriminant_Val
(Disc_Ent
));
3563 Make_Selected_Component
(Loc
,
3565 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
3566 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
3568 Set_Is_In_Discriminant_Check
(Dref
);
3571 Evolve_Or_Else
(Cond
,
3574 Right_Opnd
=> Dval
));
3577 Next_Discriminant
(Disc_Ent
);
3581 end Build_Discriminant_Checks
;
3587 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
3594 function Left_Expression
(Op
: Node_Id
) return Node_Id
;
3595 -- Return the relevant expression from the left operand of the given
3596 -- short circuit form: this is LO itself, except if LO is a qualified
3597 -- expression, a type conversion, or an expression with actions, in
3598 -- which case this is Left_Expression (Expression (LO)).
3600 ---------------------
3601 -- Left_Expression --
3602 ---------------------
3604 function Left_Expression
(Op
: Node_Id
) return Node_Id
is
3605 LE
: Node_Id
:= Left_Opnd
(Op
);
3607 while Nkind_In
(LE
, N_Qualified_Expression
,
3609 N_Expression_With_Actions
)
3611 LE
:= Expression
(LE
);
3615 end Left_Expression
;
3617 -- Start of processing for Check_Needed
3620 -- Always check if not simple entity
3622 if Nkind
(Nod
) not in N_Has_Entity
3623 or else not Comes_From_Source
(Nod
)
3628 -- Look up tree for short circuit
3635 -- Done if out of subexpression (note that we allow generated stuff
3636 -- such as itype declarations in this context, to keep the loop going
3637 -- since we may well have generated such stuff in complex situations.
3638 -- Also done if no parent (probably an error condition, but no point
3639 -- in behaving nasty if we find it).
3642 or else (K
not in N_Subexpr
and then Comes_From_Source
(P
))
3646 -- Or/Or Else case, where test is part of the right operand, or is
3647 -- part of one of the actions associated with the right operand, and
3648 -- the left operand is an equality test.
3650 elsif K
= N_Op_Or
then
3651 exit when N
= Right_Opnd
(P
)
3652 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
3654 elsif K
= N_Or_Else
then
3655 exit when (N
= Right_Opnd
(P
)
3658 and then List_Containing
(N
) = Actions
(P
)))
3659 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
3661 -- Similar test for the And/And then case, where the left operand
3662 -- is an inequality test.
3664 elsif K
= N_Op_And
then
3665 exit when N
= Right_Opnd
(P
)
3666 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
3668 elsif K
= N_And_Then
then
3669 exit when (N
= Right_Opnd
(P
)
3672 and then List_Containing
(N
) = Actions
(P
)))
3673 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
3679 -- If we fall through the loop, then we have a conditional with an
3680 -- appropriate test as its left operand, so look further.
3682 L
:= Left_Expression
(P
);
3684 -- L is an "=" or "/=" operator: extract its operands
3686 R
:= Right_Opnd
(L
);
3689 -- Left operand of test must match original variable
3691 if Nkind
(L
) not in N_Has_Entity
or else Entity
(L
) /= Entity
(Nod
) then
3695 -- Right operand of test must be key value (zero or null)
3698 when Access_Check
=>
3699 if not Known_Null
(R
) then
3703 when Division_Check
=>
3704 if not Compile_Time_Known_Value
(R
)
3705 or else Expr_Value
(R
) /= Uint_0
3711 raise Program_Error
;
3714 -- Here we have the optimizable case, warn if not short-circuited
3716 if K
= N_Op_And
or else K
= N_Op_Or
then
3717 Error_Msg_Warn
:= SPARK_Mode
/= On
;
3720 when Access_Check
=>
3721 if GNATprove_Mode
then
3723 ("Constraint_Error might have been raised (access check)",
3727 ("Constraint_Error may be raised (access check)??",
3731 when Division_Check
=>
3732 if GNATprove_Mode
then
3734 ("Constraint_Error might have been raised (zero divide)",
3738 ("Constraint_Error may be raised (zero divide)??",
3743 raise Program_Error
;
3746 if K
= N_Op_And
then
3747 Error_Msg_N
-- CODEFIX
3748 ("use `AND THEN` instead of AND??", P
);
3750 Error_Msg_N
-- CODEFIX
3751 ("use `OR ELSE` instead of OR??", P
);
3754 -- If not short-circuited, we need the check
3758 -- If short-circuited, we can omit the check
3765 -----------------------------------
3766 -- Check_Valid_Lvalue_Subscripts --
3767 -----------------------------------
3769 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
3771 -- Skip this if range checks are suppressed
3773 if Range_Checks_Suppressed
(Etype
(Expr
)) then
3776 -- Only do this check for expressions that come from source. We assume
3777 -- that expander generated assignments explicitly include any necessary
3778 -- checks. Note that this is not just an optimization, it avoids
3779 -- infinite recursions.
3781 elsif not Comes_From_Source
(Expr
) then
3784 -- For a selected component, check the prefix
3786 elsif Nkind
(Expr
) = N_Selected_Component
then
3787 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3790 -- Case of indexed component
3792 elsif Nkind
(Expr
) = N_Indexed_Component
then
3793 Apply_Subscript_Validity_Checks
(Expr
);
3795 -- Prefix may itself be or contain an indexed component, and these
3796 -- subscripts need checking as well.
3798 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3800 end Check_Valid_Lvalue_Subscripts
;
3802 ----------------------------------
3803 -- Null_Exclusion_Static_Checks --
3804 ----------------------------------
3806 procedure Null_Exclusion_Static_Checks
(N
: Node_Id
) is
3807 Error_Node
: Node_Id
;
3809 Has_Null
: constant Boolean := Has_Null_Exclusion
(N
);
3810 K
: constant Node_Kind
:= Nkind
(N
);
3815 (Nkind_In
(K
, N_Component_Declaration
,
3816 N_Discriminant_Specification
,
3817 N_Function_Specification
,
3818 N_Object_Declaration
,
3819 N_Parameter_Specification
));
3821 if K
= N_Function_Specification
then
3822 Typ
:= Etype
(Defining_Entity
(N
));
3824 Typ
:= Etype
(Defining_Identifier
(N
));
3828 when N_Component_Declaration
=>
3829 if Present
(Access_Definition
(Component_Definition
(N
))) then
3830 Error_Node
:= Component_Definition
(N
);
3832 Error_Node
:= Subtype_Indication
(Component_Definition
(N
));
3835 when N_Discriminant_Specification
=>
3836 Error_Node
:= Discriminant_Type
(N
);
3838 when N_Function_Specification
=>
3839 Error_Node
:= Result_Definition
(N
);
3841 when N_Object_Declaration
=>
3842 Error_Node
:= Object_Definition
(N
);
3844 when N_Parameter_Specification
=>
3845 Error_Node
:= Parameter_Type
(N
);
3848 raise Program_Error
;
3853 -- Enforce legality rule 3.10 (13): A null exclusion can only be
3854 -- applied to an access [sub]type.
3856 if not Is_Access_Type
(Typ
) then
3858 ("`NOT NULL` allowed only for an access type", Error_Node
);
3860 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
3861 -- be applied to a [sub]type that does not exclude null already.
3863 elsif Can_Never_Be_Null
(Typ
)
3864 and then Comes_From_Source
(Typ
)
3867 ("`NOT NULL` not allowed (& already excludes null)",
3872 -- Check that null-excluding objects are always initialized, except for
3873 -- deferred constants, for which the expression will appear in the full
3876 if K
= N_Object_Declaration
3877 and then No
(Expression
(N
))
3878 and then not Constant_Present
(N
)
3879 and then not No_Initialization
(N
)
3881 -- Add an expression that assigns null. This node is needed by
3882 -- Apply_Compile_Time_Constraint_Error, which will replace this with
3883 -- a Constraint_Error node.
3885 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
3886 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
3888 Apply_Compile_Time_Constraint_Error
3889 (N
=> Expression
(N
),
3891 "(Ada 2005) null-excluding objects must be initialized??",
3892 Reason
=> CE_Null_Not_Allowed
);
3895 -- Check that a null-excluding component, formal or object is not being
3896 -- assigned a null value. Otherwise generate a warning message and
3897 -- replace Expression (N) by an N_Constraint_Error node.
3899 if K
/= N_Function_Specification
then
3900 Expr
:= Expression
(N
);
3902 if Present
(Expr
) and then Known_Null
(Expr
) then
3904 when N_Component_Declaration |
3905 N_Discriminant_Specification
=>
3906 Apply_Compile_Time_Constraint_Error
3908 Msg
=> "(Ada 2005) null not allowed "
3909 & "in null-excluding components??",
3910 Reason
=> CE_Null_Not_Allowed
);
3912 when N_Object_Declaration
=>
3913 Apply_Compile_Time_Constraint_Error
3915 Msg
=> "(Ada 2005) null not allowed "
3916 & "in null-excluding objects?",
3917 Reason
=> CE_Null_Not_Allowed
);
3919 when N_Parameter_Specification
=>
3920 Apply_Compile_Time_Constraint_Error
3922 Msg
=> "(Ada 2005) null not allowed "
3923 & "in null-excluding formals??",
3924 Reason
=> CE_Null_Not_Allowed
);
3931 end Null_Exclusion_Static_Checks
;
3933 ----------------------------------
3934 -- Conditional_Statements_Begin --
3935 ----------------------------------
3937 procedure Conditional_Statements_Begin
is
3939 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
3941 -- If stack overflows, kill all checks, that way we know to simply reset
3942 -- the number of saved checks to zero on return. This should never occur
3945 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
3948 -- In the normal case, we just make a new stack entry saving the current
3949 -- number of saved checks for a later restore.
3952 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
3954 if Debug_Flag_CC
then
3955 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
3959 end Conditional_Statements_Begin
;
3961 --------------------------------
3962 -- Conditional_Statements_End --
3963 --------------------------------
3965 procedure Conditional_Statements_End
is
3967 pragma Assert
(Saved_Checks_TOS
> 0);
3969 -- If the saved checks stack overflowed, then we killed all checks, so
3970 -- setting the number of saved checks back to zero is correct. This
3971 -- should never occur in practice.
3973 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
3974 Num_Saved_Checks
:= 0;
3976 -- In the normal case, restore the number of saved checks from the top
3980 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
3982 if Debug_Flag_CC
then
3983 w
("Conditional_Statements_End: Num_Saved_Checks = ",
3988 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
3989 end Conditional_Statements_End
;
3991 -------------------------
3992 -- Convert_From_Bignum --
3993 -------------------------
3995 function Convert_From_Bignum
(N
: Node_Id
) return Node_Id
is
3996 Loc
: constant Source_Ptr
:= Sloc
(N
);
3999 pragma Assert
(Is_RTE
(Etype
(N
), RE_Bignum
));
4001 -- Construct call From Bignum
4004 Make_Function_Call
(Loc
,
4006 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
4007 Parameter_Associations
=> New_List
(Relocate_Node
(N
)));
4008 end Convert_From_Bignum
;
4010 -----------------------
4011 -- Convert_To_Bignum --
4012 -----------------------
4014 function Convert_To_Bignum
(N
: Node_Id
) return Node_Id
is
4015 Loc
: constant Source_Ptr
:= Sloc
(N
);
4018 -- Nothing to do if Bignum already except call Relocate_Node
4020 if Is_RTE
(Etype
(N
), RE_Bignum
) then
4021 return Relocate_Node
(N
);
4023 -- Otherwise construct call to To_Bignum, converting the operand to the
4024 -- required Long_Long_Integer form.
4027 pragma Assert
(Is_Signed_Integer_Type
(Etype
(N
)));
4029 Make_Function_Call
(Loc
,
4031 New_Occurrence_Of
(RTE
(RE_To_Bignum
), Loc
),
4032 Parameter_Associations
=> New_List
(
4033 Convert_To
(Standard_Long_Long_Integer
, Relocate_Node
(N
))));
4035 end Convert_To_Bignum
;
4037 ---------------------
4038 -- Determine_Range --
4039 ---------------------
4041 Cache_Size
: constant := 2 ** 10;
4042 type Cache_Index
is range 0 .. Cache_Size
- 1;
4043 -- Determine size of below cache (power of 2 is more efficient)
4045 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
4046 Determine_Range_Cache_V
: array (Cache_Index
) of Boolean;
4047 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
4048 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
4049 -- The above arrays are used to implement a small direct cache for
4050 -- Determine_Range calls. Because of the way Determine_Range recursively
4051 -- traces subexpressions, and because overflow checking calls the routine
4052 -- on the way up the tree, a quadratic behavior can otherwise be
4053 -- encountered in large expressions. The cache entry for node N is stored
4054 -- in the (N mod Cache_Size) entry, and can be validated by checking the
4055 -- actual node value stored there. The Range_Cache_V array records the
4056 -- setting of Assume_Valid for the cache entry.
4058 procedure Determine_Range
4063 Assume_Valid
: Boolean := False)
4065 Typ
: Entity_Id
:= Etype
(N
);
4066 -- Type to use, may get reset to base type for possibly invalid entity
4070 -- Lo and Hi bounds of left operand
4074 -- Lo and Hi bounds of right (or only) operand
4077 -- Temp variable used to hold a bound node
4080 -- High bound of base type of expression
4084 -- Refined values for low and high bounds, after tightening
4087 -- Used in lower level calls to indicate if call succeeded
4089 Cindex
: Cache_Index
;
4090 -- Used to search cache
4095 function OK_Operands
return Boolean;
4096 -- Used for binary operators. Determines the ranges of the left and
4097 -- right operands, and if they are both OK, returns True, and puts
4098 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4104 function OK_Operands
return Boolean is
4107 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
4114 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4118 -- Start of processing for Determine_Range
4121 -- For temporary constants internally generated to remove side effects
4122 -- we must use the corresponding expression to determine the range of
4125 if Is_Entity_Name
(N
)
4126 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
4127 and then Ekind
(Entity
(N
)) = E_Constant
4128 and then Is_Internal_Name
(Chars
(Entity
(N
)))
4131 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
4135 -- Prevent junk warnings by initializing range variables
4142 -- If type is not defined, we can't determine its range
4146 -- We don't deal with anything except discrete types
4148 or else not Is_Discrete_Type
(Typ
)
4150 -- Ignore type for which an error has been posted, since range in
4151 -- this case may well be a bogosity deriving from the error. Also
4152 -- ignore if error posted on the reference node.
4154 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
4160 -- For all other cases, we can determine the range
4164 -- If value is compile time known, then the possible range is the one
4165 -- value that we know this expression definitely has.
4167 if Compile_Time_Known_Value
(N
) then
4168 Lo
:= Expr_Value
(N
);
4173 -- Return if already in the cache
4175 Cindex
:= Cache_Index
(N
mod Cache_Size
);
4177 if Determine_Range_Cache_N
(Cindex
) = N
4179 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
4181 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
4182 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
4186 -- Otherwise, start by finding the bounds of the type of the expression,
4187 -- the value cannot be outside this range (if it is, then we have an
4188 -- overflow situation, which is a separate check, we are talking here
4189 -- only about the expression value).
4191 -- First a check, never try to find the bounds of a generic type, since
4192 -- these bounds are always junk values, and it is only valid to look at
4193 -- the bounds in an instance.
4195 if Is_Generic_Type
(Typ
) then
4200 -- First step, change to use base type unless we know the value is valid
4202 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
4203 or else Assume_No_Invalid_Values
4204 or else Assume_Valid
4208 Typ
:= Underlying_Type
(Base_Type
(Typ
));
4211 -- Retrieve the base type. Handle the case where the base type is a
4212 -- private enumeration type.
4214 Btyp
:= Base_Type
(Typ
);
4216 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
4217 Btyp
:= Full_View
(Btyp
);
4220 -- We use the actual bound unless it is dynamic, in which case use the
4221 -- corresponding base type bound if possible. If we can't get a bound
4222 -- then we figure we can't determine the range (a peculiar case, that
4223 -- perhaps cannot happen, but there is no point in bombing in this
4224 -- optimization circuit.
4226 -- First the low bound
4228 Bound
:= Type_Low_Bound
(Typ
);
4230 if Compile_Time_Known_Value
(Bound
) then
4231 Lo
:= Expr_Value
(Bound
);
4233 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
4234 Lo
:= Expr_Value
(Type_Low_Bound
(Btyp
));
4241 -- Now the high bound
4243 Bound
:= Type_High_Bound
(Typ
);
4245 -- We need the high bound of the base type later on, and this should
4246 -- always be compile time known. Again, it is not clear that this
4247 -- can ever be false, but no point in bombing.
4249 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
4250 Hbound
:= Expr_Value
(Type_High_Bound
(Btyp
));
4258 -- If we have a static subtype, then that may have a tighter bound so
4259 -- use the upper bound of the subtype instead in this case.
4261 if Compile_Time_Known_Value
(Bound
) then
4262 Hi
:= Expr_Value
(Bound
);
4265 -- We may be able to refine this value in certain situations. If any
4266 -- refinement is possible, then Lor and Hir are set to possibly tighter
4267 -- bounds, and OK1 is set to True.
4271 -- For unary plus, result is limited by range of operand
4275 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4277 -- For unary minus, determine range of operand, and negate it
4281 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4288 -- For binary addition, get range of each operand and do the
4289 -- addition to get the result range.
4293 Lor
:= Lo_Left
+ Lo_Right
;
4294 Hir
:= Hi_Left
+ Hi_Right
;
4297 -- Division is tricky. The only case we consider is where the right
4298 -- operand is a positive constant, and in this case we simply divide
4299 -- the bounds of the left operand
4303 if Lo_Right
= Hi_Right
4304 and then Lo_Right
> 0
4306 Lor
:= Lo_Left
/ Lo_Right
;
4307 Hir
:= Hi_Left
/ Lo_Right
;
4313 -- For binary subtraction, get range of each operand and do the worst
4314 -- case subtraction to get the result range.
4316 when N_Op_Subtract
=>
4318 Lor
:= Lo_Left
- Hi_Right
;
4319 Hir
:= Hi_Left
- Lo_Right
;
4322 -- For MOD, if right operand is a positive constant, then result must
4323 -- be in the allowable range of mod results.
4327 if Lo_Right
= Hi_Right
4328 and then Lo_Right
/= 0
4330 if Lo_Right
> 0 then
4332 Hir
:= Lo_Right
- 1;
4334 else -- Lo_Right < 0
4335 Lor
:= Lo_Right
+ 1;
4344 -- For REM, if right operand is a positive constant, then result must
4345 -- be in the allowable range of mod results.
4349 if Lo_Right
= Hi_Right
4350 and then Lo_Right
/= 0
4353 Dval
: constant Uint
:= (abs Lo_Right
) - 1;
4356 -- The sign of the result depends on the sign of the
4357 -- dividend (but not on the sign of the divisor, hence
4358 -- the abs operation above).
4378 -- Attribute reference cases
4380 when N_Attribute_Reference
=>
4381 case Attribute_Name
(N
) is
4383 -- For Pos/Val attributes, we can refine the range using the
4384 -- possible range of values of the attribute expression.
4386 when Name_Pos | Name_Val
=>
4388 (First
(Expressions
(N
)), OK1
, Lor
, Hir
, Assume_Valid
);
4390 -- For Length attribute, use the bounds of the corresponding
4391 -- index type to refine the range.
4395 Atyp
: Entity_Id
:= Etype
(Prefix
(N
));
4403 if Is_Access_Type
(Atyp
) then
4404 Atyp
:= Designated_Type
(Atyp
);
4407 -- For string literal, we know exact value
4409 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
4411 Lo
:= String_Literal_Length
(Atyp
);
4412 Hi
:= String_Literal_Length
(Atyp
);
4416 -- Otherwise check for expression given
4418 if No
(Expressions
(N
)) then
4422 UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
4425 Indx
:= First_Index
(Atyp
);
4426 for J
in 2 .. Inum
loop
4427 Indx
:= Next_Index
(Indx
);
4430 -- If the index type is a formal type or derived from
4431 -- one, the bounds are not static.
4433 if Is_Generic_Type
(Root_Type
(Etype
(Indx
))) then
4439 (Type_Low_Bound
(Etype
(Indx
)), OK1
, LL
, LU
,
4444 (Type_High_Bound
(Etype
(Indx
)), OK1
, UL
, UU
,
4449 -- The maximum value for Length is the biggest
4450 -- possible gap between the values of the bounds.
4451 -- But of course, this value cannot be negative.
4453 Hir
:= UI_Max
(Uint_0
, UU
- LL
+ 1);
4455 -- For constrained arrays, the minimum value for
4456 -- Length is taken from the actual value of the
4457 -- bounds, since the index will be exactly of this
4460 if Is_Constrained
(Atyp
) then
4461 Lor
:= UI_Max
(Uint_0
, UL
- LU
+ 1);
4463 -- For an unconstrained array, the minimum value
4464 -- for length is always zero.
4473 -- No special handling for other attributes
4474 -- Probably more opportunities exist here???
4481 -- For type conversion from one discrete type to another, we can
4482 -- refine the range using the converted value.
4484 when N_Type_Conversion
=>
4485 Determine_Range
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4487 -- Nothing special to do for all other expression kinds
4495 -- At this stage, if OK1 is true, then we know that the actual result of
4496 -- the computed expression is in the range Lor .. Hir. We can use this
4497 -- to restrict the possible range of results.
4501 -- If the refined value of the low bound is greater than the type
4502 -- high bound, then reset it to the more restrictive value. However,
4503 -- we do NOT do this for the case of a modular type where the
4504 -- possible upper bound on the value is above the base type high
4505 -- bound, because that means the result could wrap.
4508 and then not (Is_Modular_Integer_Type
(Typ
) and then Hir
> Hbound
)
4513 -- Similarly, if the refined value of the high bound is less than the
4514 -- value so far, then reset it to the more restrictive value. Again,
4515 -- we do not do this if the refined low bound is negative for a
4516 -- modular type, since this would wrap.
4519 and then not (Is_Modular_Integer_Type
(Typ
) and then Lor
< Uint_0
)
4525 -- Set cache entry for future call and we are all done
4527 Determine_Range_Cache_N
(Cindex
) := N
;
4528 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
4529 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
4530 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
4533 -- If any exception occurs, it means that we have some bug in the compiler,
4534 -- possibly triggered by a previous error, or by some unforeseen peculiar
4535 -- occurrence. However, this is only an optimization attempt, so there is
4536 -- really no point in crashing the compiler. Instead we just decide, too
4537 -- bad, we can't figure out a range in this case after all.
4542 -- Debug flag K disables this behavior (useful for debugging)
4544 if Debug_Flag_K
then
4552 end Determine_Range
;
4554 ------------------------------------
4555 -- Discriminant_Checks_Suppressed --
4556 ------------------------------------
4558 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4561 if Is_Unchecked_Union
(E
) then
4563 elsif Checks_May_Be_Suppressed
(E
) then
4564 return Is_Check_Suppressed
(E
, Discriminant_Check
);
4568 return Scope_Suppress
.Suppress
(Discriminant_Check
);
4569 end Discriminant_Checks_Suppressed
;
4571 --------------------------------
4572 -- Division_Checks_Suppressed --
4573 --------------------------------
4575 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4577 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4578 return Is_Check_Suppressed
(E
, Division_Check
);
4580 return Scope_Suppress
.Suppress
(Division_Check
);
4582 end Division_Checks_Suppressed
;
4584 -----------------------------------
4585 -- Elaboration_Checks_Suppressed --
4586 -----------------------------------
4588 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4590 -- The complication in this routine is that if we are in the dynamic
4591 -- model of elaboration, we also check All_Checks, since All_Checks
4592 -- does not set Elaboration_Check explicitly.
4595 if Kill_Elaboration_Checks
(E
) then
4598 elsif Checks_May_Be_Suppressed
(E
) then
4599 if Is_Check_Suppressed
(E
, Elaboration_Check
) then
4601 elsif Dynamic_Elaboration_Checks
then
4602 return Is_Check_Suppressed
(E
, All_Checks
);
4609 if Scope_Suppress
.Suppress
(Elaboration_Check
) then
4611 elsif Dynamic_Elaboration_Checks
then
4612 return Scope_Suppress
.Suppress
(All_Checks
);
4616 end Elaboration_Checks_Suppressed
;
4618 ---------------------------
4619 -- Enable_Overflow_Check --
4620 ---------------------------
4622 procedure Enable_Overflow_Check
(N
: Node_Id
) is
4623 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
4624 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
4633 if Debug_Flag_CC
then
4634 w
("Enable_Overflow_Check for node ", Int
(N
));
4635 Write_Str
(" Source location = ");
4640 -- No check if overflow checks suppressed for type of node
4642 if Overflow_Checks_Suppressed
(Etype
(N
)) then
4645 -- Nothing to do for unsigned integer types, which do not overflow
4647 elsif Is_Modular_Integer_Type
(Typ
) then
4651 -- This is the point at which processing for STRICT mode diverges
4652 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
4653 -- probably more extreme that it needs to be, but what is going on here
4654 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
4655 -- to leave the processing for STRICT mode untouched. There were
4656 -- two reasons for this. First it avoided any incompatible change of
4657 -- behavior. Second, it guaranteed that STRICT mode continued to be
4660 -- The big difference is that in STRICT mode there is a fair amount of
4661 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
4662 -- know that no check is needed. We skip all that in the two new modes,
4663 -- since really overflow checking happens over a whole subtree, and we
4664 -- do the corresponding optimizations later on when applying the checks.
4666 if Mode
in Minimized_Or_Eliminated
then
4667 if not (Overflow_Checks_Suppressed
(Etype
(N
)))
4668 and then not (Is_Entity_Name
(N
)
4669 and then Overflow_Checks_Suppressed
(Entity
(N
)))
4671 Activate_Overflow_Check
(N
);
4674 if Debug_Flag_CC
then
4675 w
("Minimized/Eliminated mode");
4681 -- Remainder of processing is for STRICT case, and is unchanged from
4682 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
4684 -- Nothing to do if the range of the result is known OK. We skip this
4685 -- for conversions, since the caller already did the check, and in any
4686 -- case the condition for deleting the check for a type conversion is
4689 if Nkind
(N
) /= N_Type_Conversion
then
4690 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
4692 -- Note in the test below that we assume that the range is not OK
4693 -- if a bound of the range is equal to that of the type. That's not
4694 -- quite accurate but we do this for the following reasons:
4696 -- a) The way that Determine_Range works, it will typically report
4697 -- the bounds of the value as being equal to the bounds of the
4698 -- type, because it either can't tell anything more precise, or
4699 -- does not think it is worth the effort to be more precise.
4701 -- b) It is very unusual to have a situation in which this would
4702 -- generate an unnecessary overflow check (an example would be
4703 -- a subtype with a range 0 .. Integer'Last - 1 to which the
4704 -- literal value one is added).
4706 -- c) The alternative is a lot of special casing in this routine
4707 -- which would partially duplicate Determine_Range processing.
4710 and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
4711 and then Hi
< Expr_Value
(Type_High_Bound
(Typ
))
4713 if Debug_Flag_CC
then
4714 w
("No overflow check required");
4721 -- If not in optimizing mode, set flag and we are done. We are also done
4722 -- (and just set the flag) if the type is not a discrete type, since it
4723 -- is not worth the effort to eliminate checks for other than discrete
4724 -- types. In addition, we take this same path if we have stored the
4725 -- maximum number of checks possible already (a very unlikely situation,
4726 -- but we do not want to blow up).
4728 if Optimization_Level
= 0
4729 or else not Is_Discrete_Type
(Etype
(N
))
4730 or else Num_Saved_Checks
= Saved_Checks
'Last
4732 Activate_Overflow_Check
(N
);
4734 if Debug_Flag_CC
then
4735 w
("Optimization off");
4741 -- Otherwise evaluate and check the expression
4746 Target_Type
=> Empty
,
4752 if Debug_Flag_CC
then
4753 w
("Called Find_Check");
4757 w
(" Check_Num = ", Chk
);
4758 w
(" Ent = ", Int
(Ent
));
4759 Write_Str
(" Ofs = ");
4764 -- If check is not of form to optimize, then set flag and we are done
4767 Activate_Overflow_Check
(N
);
4771 -- If check is already performed, then return without setting flag
4774 if Debug_Flag_CC
then
4775 w
("Check suppressed!");
4781 -- Here we will make a new entry for the new check
4783 Activate_Overflow_Check
(N
);
4784 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
4785 Saved_Checks
(Num_Saved_Checks
) :=
4790 Target_Type
=> Empty
);
4792 if Debug_Flag_CC
then
4793 w
("Make new entry, check number = ", Num_Saved_Checks
);
4794 w
(" Entity = ", Int
(Ent
));
4795 Write_Str
(" Offset = ");
4797 w
(" Check_Type = O");
4798 w
(" Target_Type = Empty");
4801 -- If we get an exception, then something went wrong, probably because of
4802 -- an error in the structure of the tree due to an incorrect program. Or
4803 -- it may be a bug in the optimization circuit. In either case the safest
4804 -- thing is simply to set the check flag unconditionally.
4808 Activate_Overflow_Check
(N
);
4810 if Debug_Flag_CC
then
4811 w
(" exception occurred, overflow flag set");
4815 end Enable_Overflow_Check
;
4817 ------------------------
4818 -- Enable_Range_Check --
4819 ------------------------
4821 procedure Enable_Range_Check
(N
: Node_Id
) is
4830 -- Return if unchecked type conversion with range check killed. In this
4831 -- case we never set the flag (that's what Kill_Range_Check is about).
4833 if Nkind
(N
) = N_Unchecked_Type_Conversion
4834 and then Kill_Range_Check
(N
)
4839 -- Do not set range check flag if parent is assignment statement or
4840 -- object declaration with Suppress_Assignment_Checks flag set
4842 if Nkind_In
(Parent
(N
), N_Assignment_Statement
, N_Object_Declaration
)
4843 and then Suppress_Assignment_Checks
(Parent
(N
))
4848 -- Check for various cases where we should suppress the range check
4850 -- No check if range checks suppressed for type of node
4852 if Present
(Etype
(N
)) and then Range_Checks_Suppressed
(Etype
(N
)) then
4855 -- No check if node is an entity name, and range checks are suppressed
4856 -- for this entity, or for the type of this entity.
4858 elsif Is_Entity_Name
(N
)
4859 and then (Range_Checks_Suppressed
(Entity
(N
))
4860 or else Range_Checks_Suppressed
(Etype
(Entity
(N
))))
4864 -- No checks if index of array, and index checks are suppressed for
4865 -- the array object or the type of the array.
4867 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
then
4869 Pref
: constant Node_Id
:= Prefix
(Parent
(N
));
4871 if Is_Entity_Name
(Pref
)
4872 and then Index_Checks_Suppressed
(Entity
(Pref
))
4875 elsif Index_Checks_Suppressed
(Etype
(Pref
)) then
4881 -- Debug trace output
4883 if Debug_Flag_CC
then
4884 w
("Enable_Range_Check for node ", Int
(N
));
4885 Write_Str
(" Source location = ");
4890 -- If not in optimizing mode, set flag and we are done. We are also done
4891 -- (and just set the flag) if the type is not a discrete type, since it
4892 -- is not worth the effort to eliminate checks for other than discrete
4893 -- types. In addition, we take this same path if we have stored the
4894 -- maximum number of checks possible already (a very unlikely situation,
4895 -- but we do not want to blow up).
4897 if Optimization_Level
= 0
4898 or else No
(Etype
(N
))
4899 or else not Is_Discrete_Type
(Etype
(N
))
4900 or else Num_Saved_Checks
= Saved_Checks
'Last
4902 Activate_Range_Check
(N
);
4904 if Debug_Flag_CC
then
4905 w
("Optimization off");
4911 -- Otherwise find out the target type
4915 -- For assignment, use left side subtype
4917 if Nkind
(P
) = N_Assignment_Statement
4918 and then Expression
(P
) = N
4920 Ttyp
:= Etype
(Name
(P
));
4922 -- For indexed component, use subscript subtype
4924 elsif Nkind
(P
) = N_Indexed_Component
then
4931 Atyp
:= Etype
(Prefix
(P
));
4933 if Is_Access_Type
(Atyp
) then
4934 Atyp
:= Designated_Type
(Atyp
);
4936 -- If the prefix is an access to an unconstrained array,
4937 -- perform check unconditionally: it depends on the bounds of
4938 -- an object and we cannot currently recognize whether the test
4939 -- may be redundant.
4941 if not Is_Constrained
(Atyp
) then
4942 Activate_Range_Check
(N
);
4946 -- Ditto if the prefix is an explicit dereference whose designated
4947 -- type is unconstrained.
4949 elsif Nkind
(Prefix
(P
)) = N_Explicit_Dereference
4950 and then not Is_Constrained
(Atyp
)
4952 Activate_Range_Check
(N
);
4956 Indx
:= First_Index
(Atyp
);
4957 Subs
:= First
(Expressions
(P
));
4960 Ttyp
:= Etype
(Indx
);
4969 -- For now, ignore all other cases, they are not so interesting
4972 if Debug_Flag_CC
then
4973 w
(" target type not found, flag set");
4976 Activate_Range_Check
(N
);
4980 -- Evaluate and check the expression
4985 Target_Type
=> Ttyp
,
4991 if Debug_Flag_CC
then
4992 w
("Called Find_Check");
4993 w
("Target_Typ = ", Int
(Ttyp
));
4997 w
(" Check_Num = ", Chk
);
4998 w
(" Ent = ", Int
(Ent
));
4999 Write_Str
(" Ofs = ");
5004 -- If check is not of form to optimize, then set flag and we are done
5007 if Debug_Flag_CC
then
5008 w
(" expression not of optimizable type, flag set");
5011 Activate_Range_Check
(N
);
5015 -- If check is already performed, then return without setting flag
5018 if Debug_Flag_CC
then
5019 w
("Check suppressed!");
5025 -- Here we will make a new entry for the new check
5027 Activate_Range_Check
(N
);
5028 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
5029 Saved_Checks
(Num_Saved_Checks
) :=
5034 Target_Type
=> Ttyp
);
5036 if Debug_Flag_CC
then
5037 w
("Make new entry, check number = ", Num_Saved_Checks
);
5038 w
(" Entity = ", Int
(Ent
));
5039 Write_Str
(" Offset = ");
5041 w
(" Check_Type = R");
5042 w
(" Target_Type = ", Int
(Ttyp
));
5043 pg
(Union_Id
(Ttyp
));
5046 -- If we get an exception, then something went wrong, probably because of
5047 -- an error in the structure of the tree due to an incorrect program. Or
5048 -- it may be a bug in the optimization circuit. In either case the safest
5049 -- thing is simply to set the check flag unconditionally.
5053 Activate_Range_Check
(N
);
5055 if Debug_Flag_CC
then
5056 w
(" exception occurred, range flag set");
5060 end Enable_Range_Check
;
5066 procedure Ensure_Valid
(Expr
: Node_Id
; Holes_OK
: Boolean := False) is
5067 Typ
: constant Entity_Id
:= Etype
(Expr
);
5070 -- Ignore call if we are not doing any validity checking
5072 if not Validity_Checks_On
then
5075 -- Ignore call if range or validity checks suppressed on entity or type
5077 elsif Range_Or_Validity_Checks_Suppressed
(Expr
) then
5080 -- No check required if expression is from the expander, we assume the
5081 -- expander will generate whatever checks are needed. Note that this is
5082 -- not just an optimization, it avoids infinite recursions.
5084 -- Unchecked conversions must be checked, unless they are initialized
5085 -- scalar values, as in a component assignment in an init proc.
5087 -- In addition, we force a check if Force_Validity_Checks is set
5089 elsif not Comes_From_Source
(Expr
)
5090 and then not Force_Validity_Checks
5091 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
5092 or else Kill_Range_Check
(Expr
))
5096 -- No check required if expression is known to have valid value
5098 elsif Expr_Known_Valid
(Expr
) then
5101 -- Ignore case of enumeration with holes where the flag is set not to
5102 -- worry about holes, since no special validity check is needed
5104 elsif Is_Enumeration_Type
(Typ
)
5105 and then Has_Non_Standard_Rep
(Typ
)
5110 -- No check required on the left-hand side of an assignment
5112 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
5113 and then Expr
= Name
(Parent
(Expr
))
5117 -- No check on a universal real constant. The context will eventually
5118 -- convert it to a machine number for some target type, or report an
5121 elsif Nkind
(Expr
) = N_Real_Literal
5122 and then Etype
(Expr
) = Universal_Real
5126 -- If the expression denotes a component of a packed boolean array,
5127 -- no possible check applies. We ignore the old ACATS chestnuts that
5128 -- involve Boolean range True..True.
5130 -- Note: validity checks are generated for expressions that yield a
5131 -- scalar type, when it is possible to create a value that is outside of
5132 -- the type. If this is a one-bit boolean no such value exists. This is
5133 -- an optimization, and it also prevents compiler blowing up during the
5134 -- elaboration of improperly expanded packed array references.
5136 elsif Nkind
(Expr
) = N_Indexed_Component
5137 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Expr
)))
5138 and then Root_Type
(Etype
(Expr
)) = Standard_Boolean
5142 -- For an expression with actions, we want to insert the validity check
5143 -- on the final Expression.
5145 elsif Nkind
(Expr
) = N_Expression_With_Actions
then
5146 Ensure_Valid
(Expression
(Expr
));
5149 -- An annoying special case. If this is an out parameter of a scalar
5150 -- type, then the value is not going to be accessed, therefore it is
5151 -- inappropriate to do any validity check at the call site.
5154 -- Only need to worry about scalar types
5156 if Is_Scalar_Type
(Typ
) then
5166 -- Find actual argument (which may be a parameter association)
5167 -- and the parent of the actual argument (the call statement)
5172 if Nkind
(P
) = N_Parameter_Association
then
5177 -- Only need to worry if we are argument of a procedure call
5178 -- since functions don't have out parameters. If this is an
5179 -- indirect or dispatching call, get signature from the
5182 if Nkind
(P
) = N_Procedure_Call_Statement
then
5183 L
:= Parameter_Associations
(P
);
5185 if Is_Entity_Name
(Name
(P
)) then
5186 E
:= Entity
(Name
(P
));
5188 pragma Assert
(Nkind
(Name
(P
)) = N_Explicit_Dereference
);
5189 E
:= Etype
(Name
(P
));
5192 -- Only need to worry if there are indeed actuals, and if
5193 -- this could be a procedure call, otherwise we cannot get a
5194 -- match (either we are not an argument, or the mode of the
5195 -- formal is not OUT). This test also filters out the
5198 if Is_Non_Empty_List
(L
) and then Is_Subprogram
(E
) then
5200 -- This is the loop through parameters, looking for an
5201 -- OUT parameter for which we are the argument.
5203 F
:= First_Formal
(E
);
5205 while Present
(F
) loop
5206 if Ekind
(F
) = E_Out_Parameter
and then A
= N
then
5219 -- If this is a boolean expression, only its elementary operands need
5220 -- checking: if they are valid, a boolean or short-circuit operation
5221 -- with them will be valid as well.
5223 if Base_Type
(Typ
) = Standard_Boolean
5225 (Nkind
(Expr
) in N_Op
or else Nkind
(Expr
) in N_Short_Circuit
)
5230 -- If we fall through, a validity check is required
5232 Insert_Valid_Check
(Expr
);
5234 if Is_Entity_Name
(Expr
)
5235 and then Safe_To_Capture_Value
(Expr
, Entity
(Expr
))
5237 Set_Is_Known_Valid
(Entity
(Expr
));
5241 ----------------------
5242 -- Expr_Known_Valid --
5243 ----------------------
5245 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
5246 Typ
: constant Entity_Id
:= Etype
(Expr
);
5249 -- Non-scalar types are always considered valid, since they never give
5250 -- rise to the issues of erroneous or bounded error behavior that are
5251 -- the concern. In formal reference manual terms the notion of validity
5252 -- only applies to scalar types. Note that even when packed arrays are
5253 -- represented using modular types, they are still arrays semantically,
5254 -- so they are also always valid (in particular, the unused bits can be
5255 -- random rubbish without affecting the validity of the array value).
5257 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Type
(Typ
) then
5260 -- If no validity checking, then everything is considered valid
5262 elsif not Validity_Checks_On
then
5265 -- Floating-point types are considered valid unless floating-point
5266 -- validity checks have been specifically turned on.
5268 elsif Is_Floating_Point_Type
(Typ
)
5269 and then not Validity_Check_Floating_Point
5273 -- If the expression is the value of an object that is known to be
5274 -- valid, then clearly the expression value itself is valid.
5276 elsif Is_Entity_Name
(Expr
)
5277 and then Is_Known_Valid
(Entity
(Expr
))
5279 -- Exclude volatile variables
5281 and then not Treat_As_Volatile
(Entity
(Expr
))
5285 -- References to discriminants are always considered valid. The value
5286 -- of a discriminant gets checked when the object is built. Within the
5287 -- record, we consider it valid, and it is important to do so, since
5288 -- otherwise we can try to generate bogus validity checks which
5289 -- reference discriminants out of scope. Discriminants of concurrent
5290 -- types are excluded for the same reason.
5292 elsif Is_Entity_Name
(Expr
)
5293 and then Denotes_Discriminant
(Expr
, Check_Concurrent
=> True)
5297 -- If the type is one for which all values are known valid, then we are
5298 -- sure that the value is valid except in the slightly odd case where
5299 -- the expression is a reference to a variable whose size has been
5300 -- explicitly set to a value greater than the object size.
5302 elsif Is_Known_Valid
(Typ
) then
5303 if Is_Entity_Name
(Expr
)
5304 and then Ekind
(Entity
(Expr
)) = E_Variable
5305 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
5312 -- Integer and character literals always have valid values, where
5313 -- appropriate these will be range checked in any case.
5315 elsif Nkind_In
(Expr
, N_Integer_Literal
, N_Character_Literal
) then
5318 -- Real literals are assumed to be valid in VM targets
5320 elsif VM_Target
/= No_VM
and then Nkind
(Expr
) = N_Real_Literal
then
5323 -- If we have a type conversion or a qualification of a known valid
5324 -- value, then the result will always be valid.
5326 elsif Nkind_In
(Expr
, N_Type_Conversion
, N_Qualified_Expression
) then
5327 return Expr_Known_Valid
(Expression
(Expr
));
5329 -- Case of expression is a non-floating-point operator. In this case we
5330 -- can assume the result is valid the generated code for the operator
5331 -- will include whatever checks are needed (e.g. range checks) to ensure
5332 -- validity. This assumption does not hold for the floating-point case,
5333 -- since floating-point operators can generate Infinite or NaN results
5334 -- which are considered invalid.
5336 -- Historical note: in older versions, the exemption of floating-point
5337 -- types from this assumption was done only in cases where the parent
5338 -- was an assignment, function call or parameter association. Presumably
5339 -- the idea was that in other contexts, the result would be checked
5340 -- elsewhere, but this list of cases was missing tests (at least the
5341 -- N_Object_Declaration case, as shown by a reported missing validity
5342 -- check), and it is not clear why function calls but not procedure
5343 -- calls were tested for. It really seems more accurate and much
5344 -- safer to recognize that expressions which are the result of a
5345 -- floating-point operator can never be assumed to be valid.
5347 elsif Nkind
(Expr
) in N_Op
and then not Is_Floating_Point_Type
(Typ
) then
5350 -- The result of a membership test is always valid, since it is true or
5351 -- false, there are no other possibilities.
5353 elsif Nkind
(Expr
) in N_Membership_Test
then
5356 -- For all other cases, we do not know the expression is valid
5361 end Expr_Known_Valid
;
5367 procedure Find_Check
5369 Check_Type
: Character;
5370 Target_Type
: Entity_Id
;
5371 Entry_OK
: out Boolean;
5372 Check_Num
: out Nat
;
5373 Ent
: out Entity_Id
;
5376 function Within_Range_Of
5377 (Target_Type
: Entity_Id
;
5378 Check_Type
: Entity_Id
) return Boolean;
5379 -- Given a requirement for checking a range against Target_Type, and
5380 -- and a range Check_Type against which a check has already been made,
5381 -- determines if the check against check type is sufficient to ensure
5382 -- that no check against Target_Type is required.
5384 ---------------------
5385 -- Within_Range_Of --
5386 ---------------------
5388 function Within_Range_Of
5389 (Target_Type
: Entity_Id
;
5390 Check_Type
: Entity_Id
) return Boolean
5393 if Target_Type
= Check_Type
then
5398 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
5399 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
5400 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
5401 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
5405 or else (Compile_Time_Known_Value
(Tlo
)
5407 Compile_Time_Known_Value
(Clo
)
5409 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
5412 or else (Compile_Time_Known_Value
(Thi
)
5414 Compile_Time_Known_Value
(Chi
)
5416 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
5424 end Within_Range_Of
;
5426 -- Start of processing for Find_Check
5429 -- Establish default, in case no entry is found
5433 -- Case of expression is simple entity reference
5435 if Is_Entity_Name
(Expr
) then
5436 Ent
:= Entity
(Expr
);
5439 -- Case of expression is entity + known constant
5441 elsif Nkind
(Expr
) = N_Op_Add
5442 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
5443 and then Is_Entity_Name
(Left_Opnd
(Expr
))
5445 Ent
:= Entity
(Left_Opnd
(Expr
));
5446 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
5448 -- Case of expression is entity - known constant
5450 elsif Nkind
(Expr
) = N_Op_Subtract
5451 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
5452 and then Is_Entity_Name
(Left_Opnd
(Expr
))
5454 Ent
:= Entity
(Left_Opnd
(Expr
));
5455 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
5457 -- Any other expression is not of the right form
5466 -- Come here with expression of appropriate form, check if entity is an
5467 -- appropriate one for our purposes.
5469 if (Ekind
(Ent
) = E_Variable
5470 or else Is_Constant_Object
(Ent
))
5471 and then not Is_Library_Level_Entity
(Ent
)
5479 -- See if there is matching check already
5481 for J
in reverse 1 .. Num_Saved_Checks
loop
5483 SC
: Saved_Check
renames Saved_Checks
(J
);
5485 if SC
.Killed
= False
5486 and then SC
.Entity
= Ent
5487 and then SC
.Offset
= Ofs
5488 and then SC
.Check_Type
= Check_Type
5489 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
5497 -- If we fall through entry was not found
5502 ---------------------------------
5503 -- Generate_Discriminant_Check --
5504 ---------------------------------
5506 -- Note: the code for this procedure is derived from the
5507 -- Emit_Discriminant_Check Routine in trans.c.
5509 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
5510 Loc
: constant Source_Ptr
:= Sloc
(N
);
5511 Pref
: constant Node_Id
:= Prefix
(N
);
5512 Sel
: constant Node_Id
:= Selector_Name
(N
);
5514 Orig_Comp
: constant Entity_Id
:=
5515 Original_Record_Component
(Entity
(Sel
));
5516 -- The original component to be checked
5518 Discr_Fct
: constant Entity_Id
:=
5519 Discriminant_Checking_Func
(Orig_Comp
);
5520 -- The discriminant checking function
5523 -- One discriminant to be checked in the type
5525 Real_Discr
: Entity_Id
;
5526 -- Actual discriminant in the call
5528 Pref_Type
: Entity_Id
;
5529 -- Type of relevant prefix (ignoring private/access stuff)
5532 -- List of arguments for function call
5535 -- Keep track of the formal corresponding to the actual we build for
5536 -- each discriminant, in order to be able to perform the necessary type
5540 -- Selected component reference for checking function argument
5543 Pref_Type
:= Etype
(Pref
);
5545 -- Force evaluation of the prefix, so that it does not get evaluated
5546 -- twice (once for the check, once for the actual reference). Such a
5547 -- double evaluation is always a potential source of inefficiency, and
5548 -- is functionally incorrect in the volatile case, or when the prefix
5549 -- may have side-effects. A non-volatile entity or a component of a
5550 -- non-volatile entity requires no evaluation.
5552 if Is_Entity_Name
(Pref
) then
5553 if Treat_As_Volatile
(Entity
(Pref
)) then
5554 Force_Evaluation
(Pref
, Name_Req
=> True);
5557 elsif Treat_As_Volatile
(Etype
(Pref
)) then
5558 Force_Evaluation
(Pref
, Name_Req
=> True);
5560 elsif Nkind
(Pref
) = N_Selected_Component
5561 and then Is_Entity_Name
(Prefix
(Pref
))
5566 Force_Evaluation
(Pref
, Name_Req
=> True);
5569 -- For a tagged type, use the scope of the original component to
5570 -- obtain the type, because ???
5572 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
5573 Pref_Type
:= Scope
(Orig_Comp
);
5575 -- For an untagged derived type, use the discriminants of the parent
5576 -- which have been renamed in the derivation, possibly by a one-to-many
5577 -- discriminant constraint. For non-tagged type, initially get the Etype
5581 if Is_Derived_Type
(Pref_Type
)
5582 and then Number_Discriminants
(Pref_Type
) /=
5583 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
5585 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
5589 -- We definitely should have a checking function, This routine should
5590 -- not be called if no discriminant checking function is present.
5592 pragma Assert
(Present
(Discr_Fct
));
5594 -- Create the list of the actual parameters for the call. This list
5595 -- is the list of the discriminant fields of the record expression to
5596 -- be discriminant checked.
5599 Formal
:= First_Formal
(Discr_Fct
);
5600 Discr
:= First_Discriminant
(Pref_Type
);
5601 while Present
(Discr
) loop
5603 -- If we have a corresponding discriminant field, and a parent
5604 -- subtype is present, then we want to use the corresponding
5605 -- discriminant since this is the one with the useful value.
5607 if Present
(Corresponding_Discriminant
(Discr
))
5608 and then Ekind
(Pref_Type
) = E_Record_Type
5609 and then Present
(Parent_Subtype
(Pref_Type
))
5611 Real_Discr
:= Corresponding_Discriminant
(Discr
);
5613 Real_Discr
:= Discr
;
5616 -- Construct the reference to the discriminant
5619 Make_Selected_Component
(Loc
,
5621 Unchecked_Convert_To
(Pref_Type
,
5622 Duplicate_Subexpr
(Pref
)),
5623 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
5625 -- Manually analyze and resolve this selected component. We really
5626 -- want it just as it appears above, and do not want the expander
5627 -- playing discriminal games etc with this reference. Then we append
5628 -- the argument to the list we are gathering.
5630 Set_Etype
(Scomp
, Etype
(Real_Discr
));
5631 Set_Analyzed
(Scomp
, True);
5632 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
5634 Next_Formal_With_Extras
(Formal
);
5635 Next_Discriminant
(Discr
);
5638 -- Now build and insert the call
5641 Make_Raise_Constraint_Error
(Loc
,
5643 Make_Function_Call
(Loc
,
5644 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
5645 Parameter_Associations
=> Args
),
5646 Reason
=> CE_Discriminant_Check_Failed
));
5647 end Generate_Discriminant_Check
;
5649 ---------------------------
5650 -- Generate_Index_Checks --
5651 ---------------------------
5653 procedure Generate_Index_Checks
(N
: Node_Id
) is
5655 function Entity_Of_Prefix
return Entity_Id
;
5656 -- Returns the entity of the prefix of N (or Empty if not found)
5658 ----------------------
5659 -- Entity_Of_Prefix --
5660 ----------------------
5662 function Entity_Of_Prefix
return Entity_Id
is
5667 while not Is_Entity_Name
(P
) loop
5668 if not Nkind_In
(P
, N_Selected_Component
,
5669 N_Indexed_Component
)
5678 end Entity_Of_Prefix
;
5682 Loc
: constant Source_Ptr
:= Sloc
(N
);
5683 A
: constant Node_Id
:= Prefix
(N
);
5684 A_Ent
: constant Entity_Id
:= Entity_Of_Prefix
;
5687 -- Start of processing for Generate_Index_Checks
5690 -- Ignore call if the prefix is not an array since we have a serious
5691 -- error in the sources. Ignore it also if index checks are suppressed
5692 -- for array object or type.
5694 if not Is_Array_Type
(Etype
(A
))
5695 or else (Present
(A_Ent
) and then Index_Checks_Suppressed
(A_Ent
))
5696 or else Index_Checks_Suppressed
(Etype
(A
))
5700 -- The indexed component we are dealing with contains 'Loop_Entry in its
5701 -- prefix. This case arises when analysis has determined that constructs
5704 -- Prefix'Loop_Entry (Expr)
5705 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
5707 -- require rewriting for error detection purposes. A side effect of this
5708 -- action is the generation of index checks that mention 'Loop_Entry.
5709 -- Delay the generation of the check until 'Loop_Entry has been properly
5710 -- expanded. This is done in Expand_Loop_Entry_Attributes.
5712 elsif Nkind
(Prefix
(N
)) = N_Attribute_Reference
5713 and then Attribute_Name
(Prefix
(N
)) = Name_Loop_Entry
5718 -- Generate a raise of constraint error with the appropriate reason and
5719 -- a condition of the form:
5721 -- Base_Type (Sub) not in Array'Range (Subscript)
5723 -- Note that the reason we generate the conversion to the base type here
5724 -- is that we definitely want the range check to take place, even if it
5725 -- looks like the subtype is OK. Optimization considerations that allow
5726 -- us to omit the check have already been taken into account in the
5727 -- setting of the Do_Range_Check flag earlier on.
5729 Sub
:= First
(Expressions
(N
));
5731 -- Handle string literals
5733 if Ekind
(Etype
(A
)) = E_String_Literal_Subtype
then
5734 if Do_Range_Check
(Sub
) then
5735 Set_Do_Range_Check
(Sub
, False);
5737 -- For string literals we obtain the bounds of the string from the
5738 -- associated subtype.
5741 Make_Raise_Constraint_Error
(Loc
,
5745 Convert_To
(Base_Type
(Etype
(Sub
)),
5746 Duplicate_Subexpr_Move_Checks
(Sub
)),
5748 Make_Attribute_Reference
(Loc
,
5749 Prefix
=> New_Occurrence_Of
(Etype
(A
), Loc
),
5750 Attribute_Name
=> Name_Range
)),
5751 Reason
=> CE_Index_Check_Failed
));
5758 A_Idx
: Node_Id
:= Empty
;
5765 A_Idx
:= First_Index
(Etype
(A
));
5767 while Present
(Sub
) loop
5768 if Do_Range_Check
(Sub
) then
5769 Set_Do_Range_Check
(Sub
, False);
5771 -- Force evaluation except for the case of a simple name of
5772 -- a non-volatile entity.
5774 if not Is_Entity_Name
(Sub
)
5775 or else Treat_As_Volatile
(Entity
(Sub
))
5777 Force_Evaluation
(Sub
);
5780 if Nkind
(A_Idx
) = N_Range
then
5783 elsif Nkind
(A_Idx
) = N_Identifier
5784 or else Nkind
(A_Idx
) = N_Expanded_Name
5786 A_Range
:= Scalar_Range
(Entity
(A_Idx
));
5788 else pragma Assert
(Nkind
(A_Idx
) = N_Subtype_Indication
);
5789 A_Range
:= Range_Expression
(Constraint
(A_Idx
));
5792 -- For array objects with constant bounds we can generate
5793 -- the index check using the bounds of the type of the index
5796 and then Ekind
(A_Ent
) = E_Variable
5797 and then Is_Constant_Bound
(Low_Bound
(A_Range
))
5798 and then Is_Constant_Bound
(High_Bound
(A_Range
))
5801 Make_Attribute_Reference
(Loc
,
5803 New_Occurrence_Of
(Etype
(A_Idx
), Loc
),
5804 Attribute_Name
=> Name_Range
);
5806 -- For arrays with non-constant bounds we cannot generate
5807 -- the index check using the bounds of the type of the index
5808 -- since it may reference discriminants of some enclosing
5809 -- type. We obtain the bounds directly from the prefix
5816 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
5820 Make_Attribute_Reference
(Loc
,
5822 Duplicate_Subexpr_Move_Checks
(A
, Name_Req
=> True),
5823 Attribute_Name
=> Name_Range
,
5824 Expressions
=> Num
);
5828 Make_Raise_Constraint_Error
(Loc
,
5832 Convert_To
(Base_Type
(Etype
(Sub
)),
5833 Duplicate_Subexpr_Move_Checks
(Sub
)),
5834 Right_Opnd
=> Range_N
),
5835 Reason
=> CE_Index_Check_Failed
));
5838 A_Idx
:= Next_Index
(A_Idx
);
5844 end Generate_Index_Checks
;
5846 --------------------------
5847 -- Generate_Range_Check --
5848 --------------------------
5850 procedure Generate_Range_Check
5852 Target_Type
: Entity_Id
;
5853 Reason
: RT_Exception_Code
)
5855 Loc
: constant Source_Ptr
:= Sloc
(N
);
5856 Source_Type
: constant Entity_Id
:= Etype
(N
);
5857 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
5858 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
5861 -- First special case, if the source type is already within the range
5862 -- of the target type, then no check is needed (probably we should have
5863 -- stopped Do_Range_Check from being set in the first place, but better
5864 -- late than never in preventing junk code.
5866 if In_Subrange_Of
(Source_Type
, Target_Type
)
5868 -- We do NOT apply this if the source node is a literal, since in this
5869 -- case the literal has already been labeled as having the subtype of
5873 (Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
, N_Character_Literal
)
5876 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
5878 -- Also do not apply this for floating-point if Check_Float_Overflow
5881 (Is_Floating_Point_Type
(Source_Type
) and Check_Float_Overflow
)
5886 -- We need a check, so force evaluation of the node, so that it does
5887 -- not get evaluated twice (once for the check, once for the actual
5888 -- reference). Such a double evaluation is always a potential source
5889 -- of inefficiency, and is functionally incorrect in the volatile case.
5891 if not Is_Entity_Name
(N
) or else Treat_As_Volatile
(Entity
(N
)) then
5892 Force_Evaluation
(N
);
5895 -- The easiest case is when Source_Base_Type and Target_Base_Type are
5896 -- the same since in this case we can simply do a direct check of the
5897 -- value of N against the bounds of Target_Type.
5899 -- [constraint_error when N not in Target_Type]
5901 -- Note: this is by far the most common case, for example all cases of
5902 -- checks on the RHS of assignments are in this category, but not all
5903 -- cases are like this. Notably conversions can involve two types.
5905 if Source_Base_Type
= Target_Base_Type
then
5907 Make_Raise_Constraint_Error
(Loc
,
5910 Left_Opnd
=> Duplicate_Subexpr
(N
),
5911 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
5914 -- Next test for the case where the target type is within the bounds
5915 -- of the base type of the source type, since in this case we can
5916 -- simply convert these bounds to the base type of T to do the test.
5918 -- [constraint_error when N not in
5919 -- Source_Base_Type (Target_Type'First)
5921 -- Source_Base_Type(Target_Type'Last))]
5923 -- The conversions will always work and need no check
5925 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
5926 -- of converting from an enumeration value to an integer type, such as
5927 -- occurs for the case of generating a range check on Enum'Val(Exp)
5928 -- (which used to be handled by gigi). This is OK, since the conversion
5929 -- itself does not require a check.
5931 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
5933 Make_Raise_Constraint_Error
(Loc
,
5936 Left_Opnd
=> Duplicate_Subexpr
(N
),
5941 Unchecked_Convert_To
(Source_Base_Type
,
5942 Make_Attribute_Reference
(Loc
,
5944 New_Occurrence_Of
(Target_Type
, Loc
),
5945 Attribute_Name
=> Name_First
)),
5948 Unchecked_Convert_To
(Source_Base_Type
,
5949 Make_Attribute_Reference
(Loc
,
5951 New_Occurrence_Of
(Target_Type
, Loc
),
5952 Attribute_Name
=> Name_Last
)))),
5955 -- Note that at this stage we now that the Target_Base_Type is not in
5956 -- the range of the Source_Base_Type (since even the Target_Type itself
5957 -- is not in this range). It could still be the case that Source_Type is
5958 -- in range of the target base type since we have not checked that case.
5960 -- If that is the case, we can freely convert the source to the target,
5961 -- and then test the target result against the bounds.
5963 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
5965 -- We make a temporary to hold the value of the converted value
5966 -- (converted to the base type), and then we will do the test against
5969 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
5970 -- [constraint_error when Tnn not in Target_Type]
5972 -- Then the conversion itself is replaced by an occurrence of Tnn
5975 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
5978 Insert_Actions
(N
, New_List
(
5979 Make_Object_Declaration
(Loc
,
5980 Defining_Identifier
=> Tnn
,
5981 Object_Definition
=>
5982 New_Occurrence_Of
(Target_Base_Type
, Loc
),
5983 Constant_Present
=> True,
5985 Make_Type_Conversion
(Loc
,
5986 Subtype_Mark
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
5987 Expression
=> Duplicate_Subexpr
(N
))),
5989 Make_Raise_Constraint_Error
(Loc
,
5992 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
5993 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
5995 Reason
=> Reason
)));
5997 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
5999 -- Set the type of N, because the declaration for Tnn might not
6000 -- be analyzed yet, as is the case if N appears within a record
6001 -- declaration, as a discriminant constraint or expression.
6003 Set_Etype
(N
, Target_Base_Type
);
6006 -- At this stage, we know that we have two scalar types, which are
6007 -- directly convertible, and where neither scalar type has a base
6008 -- range that is in the range of the other scalar type.
6010 -- The only way this can happen is with a signed and unsigned type.
6011 -- So test for these two cases:
6014 -- Case of the source is unsigned and the target is signed
6016 if Is_Unsigned_Type
(Source_Base_Type
)
6017 and then not Is_Unsigned_Type
(Target_Base_Type
)
6019 -- If the source is unsigned and the target is signed, then we
6020 -- know that the source is not shorter than the target (otherwise
6021 -- the source base type would be in the target base type range).
6023 -- In other words, the unsigned type is either the same size as
6024 -- the target, or it is larger. It cannot be smaller.
6027 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
6029 -- We only need to check the low bound if the low bound of the
6030 -- target type is non-negative. If the low bound of the target
6031 -- type is negative, then we know that we will fit fine.
6033 -- If the high bound of the target type is negative, then we
6034 -- know we have a constraint error, since we can't possibly
6035 -- have a negative source.
6037 -- With these two checks out of the way, we can do the check
6038 -- using the source type safely
6040 -- This is definitely the most annoying case.
6042 -- [constraint_error
6043 -- when (Target_Type'First >= 0
6045 -- N < Source_Base_Type (Target_Type'First))
6046 -- or else Target_Type'Last < 0
6047 -- or else N > Source_Base_Type (Target_Type'Last)];
6049 -- We turn off all checks since we know that the conversions
6050 -- will work fine, given the guards for negative values.
6053 Make_Raise_Constraint_Error
(Loc
,
6059 Left_Opnd
=> Make_Op_Ge
(Loc
,
6061 Make_Attribute_Reference
(Loc
,
6063 New_Occurrence_Of
(Target_Type
, Loc
),
6064 Attribute_Name
=> Name_First
),
6065 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
6069 Left_Opnd
=> Duplicate_Subexpr
(N
),
6071 Convert_To
(Source_Base_Type
,
6072 Make_Attribute_Reference
(Loc
,
6074 New_Occurrence_Of
(Target_Type
, Loc
),
6075 Attribute_Name
=> Name_First
)))),
6080 Make_Attribute_Reference
(Loc
,
6081 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
6082 Attribute_Name
=> Name_Last
),
6083 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
6087 Left_Opnd
=> Duplicate_Subexpr
(N
),
6089 Convert_To
(Source_Base_Type
,
6090 Make_Attribute_Reference
(Loc
,
6091 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
6092 Attribute_Name
=> Name_Last
)))),
6095 Suppress
=> All_Checks
);
6097 -- Only remaining possibility is that the source is signed and
6098 -- the target is unsigned.
6101 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
6102 and then Is_Unsigned_Type
(Target_Base_Type
));
6104 -- If the source is signed and the target is unsigned, then we
6105 -- know that the target is not shorter than the source (otherwise
6106 -- the target base type would be in the source base type range).
6108 -- In other words, the unsigned type is either the same size as
6109 -- the target, or it is larger. It cannot be smaller.
6111 -- Clearly we have an error if the source value is negative since
6112 -- no unsigned type can have negative values. If the source type
6113 -- is non-negative, then the check can be done using the target
6116 -- Tnn : constant Target_Base_Type (N) := Target_Type;
6118 -- [constraint_error
6119 -- when N < 0 or else Tnn not in Target_Type];
6121 -- We turn off all checks for the conversion of N to the target
6122 -- base type, since we generate the explicit check to ensure that
6123 -- the value is non-negative
6126 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
6129 Insert_Actions
(N
, New_List
(
6130 Make_Object_Declaration
(Loc
,
6131 Defining_Identifier
=> Tnn
,
6132 Object_Definition
=>
6133 New_Occurrence_Of
(Target_Base_Type
, Loc
),
6134 Constant_Present
=> True,
6136 Make_Unchecked_Type_Conversion
(Loc
,
6138 New_Occurrence_Of
(Target_Base_Type
, Loc
),
6139 Expression
=> Duplicate_Subexpr
(N
))),
6141 Make_Raise_Constraint_Error
(Loc
,
6146 Left_Opnd
=> Duplicate_Subexpr
(N
),
6147 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
6151 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
6153 New_Occurrence_Of
(Target_Type
, Loc
))),
6156 Suppress
=> All_Checks
);
6158 -- Set the Etype explicitly, because Insert_Actions may have
6159 -- placed the declaration in the freeze list for an enclosing
6160 -- construct, and thus it is not analyzed yet.
6162 Set_Etype
(Tnn
, Target_Base_Type
);
6163 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
6167 end Generate_Range_Check
;
6173 function Get_Check_Id
(N
: Name_Id
) return Check_Id
is
6175 -- For standard check name, we can do a direct computation
6177 if N
in First_Check_Name
.. Last_Check_Name
then
6178 return Check_Id
(N
- (First_Check_Name
- 1));
6180 -- For non-standard names added by pragma Check_Name, search table
6183 for J
in All_Checks
+ 1 .. Check_Names
.Last
loop
6184 if Check_Names
.Table
(J
) = N
then
6190 -- No matching name found
6195 ---------------------
6196 -- Get_Discriminal --
6197 ---------------------
6199 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
6200 Loc
: constant Source_Ptr
:= Sloc
(E
);
6205 -- The bound can be a bona fide parameter of a protected operation,
6206 -- rather than a prival encoded as an in-parameter.
6208 if No
(Discriminal_Link
(Entity
(Bound
))) then
6212 -- Climb the scope stack looking for an enclosing protected type. If
6213 -- we run out of scopes, return the bound itself.
6216 while Present
(Sc
) loop
6217 if Sc
= Standard_Standard
then
6219 elsif Ekind
(Sc
) = E_Protected_Type
then
6226 D
:= First_Discriminant
(Sc
);
6227 while Present
(D
) loop
6228 if Chars
(D
) = Chars
(Bound
) then
6229 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
6232 Next_Discriminant
(D
);
6236 end Get_Discriminal
;
6238 ----------------------
6239 -- Get_Range_Checks --
6240 ----------------------
6242 function Get_Range_Checks
6244 Target_Typ
: Entity_Id
;
6245 Source_Typ
: Entity_Id
:= Empty
;
6246 Warn_Node
: Node_Id
:= Empty
) return Check_Result
6250 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Warn_Node
);
6251 end Get_Range_Checks
;
6257 function Guard_Access
6260 Ck_Node
: Node_Id
) return Node_Id
6263 if Nkind
(Cond
) = N_Or_Else
then
6264 Set_Paren_Count
(Cond
, 1);
6267 if Nkind
(Ck_Node
) = N_Allocator
then
6275 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
6276 Right_Opnd
=> Make_Null
(Loc
)),
6277 Right_Opnd
=> Cond
);
6281 -----------------------------
6282 -- Index_Checks_Suppressed --
6283 -----------------------------
6285 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6287 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6288 return Is_Check_Suppressed
(E
, Index_Check
);
6290 return Scope_Suppress
.Suppress
(Index_Check
);
6292 end Index_Checks_Suppressed
;
6298 procedure Initialize
is
6300 for J
in Determine_Range_Cache_N
'Range loop
6301 Determine_Range_Cache_N
(J
) := Empty
;
6306 for J
in Int
range 1 .. All_Checks
loop
6307 Check_Names
.Append
(Name_Id
(Int
(First_Check_Name
) + J
- 1));
6311 -------------------------
6312 -- Insert_Range_Checks --
6313 -------------------------
6315 procedure Insert_Range_Checks
6316 (Checks
: Check_Result
;
6318 Suppress_Typ
: Entity_Id
;
6319 Static_Sloc
: Source_Ptr
:= No_Location
;
6320 Flag_Node
: Node_Id
:= Empty
;
6321 Do_Before
: Boolean := False)
6323 Internal_Flag_Node
: Node_Id
:= Flag_Node
;
6324 Internal_Static_Sloc
: Source_Ptr
:= Static_Sloc
;
6326 Check_Node
: Node_Id
;
6327 Checks_On
: constant Boolean :=
6328 (not Index_Checks_Suppressed
(Suppress_Typ
))
6329 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
6332 -- For now we just return if Checks_On is false, however this should be
6333 -- enhanced to check for an always True value in the condition and to
6334 -- generate a compilation warning???
6336 if not Expander_Active
or not Checks_On
then
6340 if Static_Sloc
= No_Location
then
6341 Internal_Static_Sloc
:= Sloc
(Node
);
6344 if No
(Flag_Node
) then
6345 Internal_Flag_Node
:= Node
;
6348 for J
in 1 .. 2 loop
6349 exit when No
(Checks
(J
));
6351 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
6352 and then Present
(Condition
(Checks
(J
)))
6354 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
6355 Check_Node
:= Checks
(J
);
6356 Mark_Rewrite_Insertion
(Check_Node
);
6359 Insert_Before_And_Analyze
(Node
, Check_Node
);
6361 Insert_After_And_Analyze
(Node
, Check_Node
);
6364 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
6369 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
6370 Reason
=> CE_Range_Check_Failed
);
6371 Mark_Rewrite_Insertion
(Check_Node
);
6374 Insert_Before_And_Analyze
(Node
, Check_Node
);
6376 Insert_After_And_Analyze
(Node
, Check_Node
);
6380 end Insert_Range_Checks
;
6382 ------------------------
6383 -- Insert_Valid_Check --
6384 ------------------------
6386 procedure Insert_Valid_Check
(Expr
: Node_Id
) is
6387 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6388 Typ
: constant Entity_Id
:= Etype
(Expr
);
6392 -- Do not insert if checks off, or if not checking validity or
6393 -- if expression is known to be valid
6395 if not Validity_Checks_On
6396 or else Range_Or_Validity_Checks_Suppressed
(Expr
)
6397 or else Expr_Known_Valid
(Expr
)
6402 -- Do not insert checks within a predicate function. This will arise
6403 -- if the current unit and the predicate function are being compiled
6404 -- with validity checks enabled.
6406 if Present
(Predicate_Function
(Typ
))
6407 and then Current_Scope
= Predicate_Function
(Typ
)
6412 -- If we have a checked conversion, then validity check applies to
6413 -- the expression inside the conversion, not the result, since if
6414 -- the expression inside is valid, then so is the conversion result.
6417 while Nkind
(Exp
) = N_Type_Conversion
loop
6418 Exp
:= Expression
(Exp
);
6421 -- We are about to insert the validity check for Exp. We save and
6422 -- reset the Do_Range_Check flag over this validity check, and then
6423 -- put it back for the final original reference (Exp may be rewritten).
6426 DRC
: constant Boolean := Do_Range_Check
(Exp
);
6431 Set_Do_Range_Check
(Exp
, False);
6433 -- Force evaluation to avoid multiple reads for atomic/volatile
6435 if Is_Entity_Name
(Exp
)
6436 and then Is_Volatile
(Entity
(Exp
))
6438 Force_Evaluation
(Exp
, Name_Req
=> True);
6441 -- Build the prefix for the 'Valid call
6443 PV
:= Duplicate_Subexpr_No_Checks
(Exp
, Name_Req
=> True);
6445 -- A rather specialized kludge. If PV is an analyzed expression
6446 -- which is an indexed component of a packed array that has not
6447 -- been properly expanded, turn off its Analyzed flag to make sure
6448 -- it gets properly reexpanded.
6450 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
6451 -- an analyze with the old parent pointer. This may point e.g. to
6452 -- a subprogram call, which deactivates this expansion.
6455 and then Nkind
(PV
) = N_Indexed_Component
6456 and then Present
(Packed_Array_Type
(Etype
(Prefix
(PV
))))
6458 Set_Analyzed
(PV
, False);
6461 -- Build the raise CE node to check for validity
6464 Make_Raise_Constraint_Error
(Loc
,
6468 Make_Attribute_Reference
(Loc
,
6470 Attribute_Name
=> Name_Valid
)),
6471 Reason
=> CE_Invalid_Data
);
6473 -- Insert the validity check. Note that we do this with validity
6474 -- checks turned off, to avoid recursion, we do not want validity
6475 -- checks on the validity checking code itself.
6477 Insert_Action
(Expr
, CE
, Suppress
=> Validity_Check
);
6479 -- If the expression is a reference to an element of a bit-packed
6480 -- array, then it is rewritten as a renaming declaration. If the
6481 -- expression is an actual in a call, it has not been expanded,
6482 -- waiting for the proper point at which to do it. The same happens
6483 -- with renamings, so that we have to force the expansion now. This
6484 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
6487 if Is_Entity_Name
(Exp
)
6488 and then Nkind
(Parent
(Entity
(Exp
))) =
6489 N_Object_Renaming_Declaration
6492 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
6494 if Nkind
(Old_Exp
) = N_Indexed_Component
6495 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
6497 Expand_Packed_Element_Reference
(Old_Exp
);
6502 -- Put back the Do_Range_Check flag on the resulting (possibly
6503 -- rewritten) expression.
6505 -- Note: it might be thought that a validity check is not required
6506 -- when a range check is present, but that's not the case, because
6507 -- the back end is allowed to assume for the range check that the
6508 -- operand is within its declared range (an assumption that validity
6509 -- checking is all about NOT assuming).
6511 -- Note: no need to worry about Possible_Local_Raise here, it will
6512 -- already have been called if original node has Do_Range_Check set.
6514 Set_Do_Range_Check
(Exp
, DRC
);
6516 end Insert_Valid_Check
;
6518 -------------------------------------
6519 -- Is_Signed_Integer_Arithmetic_Op --
6520 -------------------------------------
6522 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean is
6525 when N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
6526 N_Op_Minus | N_Op_Mod | N_Op_Multiply | N_Op_Plus |
6527 N_Op_Rem | N_Op_Subtract
=>
6528 return Is_Signed_Integer_Type
(Etype
(N
));
6530 when N_If_Expression | N_Case_Expression
=>
6531 return Is_Signed_Integer_Type
(Etype
(N
));
6536 end Is_Signed_Integer_Arithmetic_Op
;
6538 ----------------------------------
6539 -- Install_Null_Excluding_Check --
6540 ----------------------------------
6542 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
6543 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
6544 Typ
: constant Entity_Id
:= Etype
(N
);
6546 function Safe_To_Capture_In_Parameter_Value
return Boolean;
6547 -- Determines if it is safe to capture Known_Non_Null status for an
6548 -- the entity referenced by node N. The caller ensures that N is indeed
6549 -- an entity name. It is safe to capture the non-null status for an IN
6550 -- parameter when the reference occurs within a declaration that is sure
6551 -- to be executed as part of the declarative region.
6553 procedure Mark_Non_Null
;
6554 -- After installation of check, if the node in question is an entity
6555 -- name, then mark this entity as non-null if possible.
6557 function Safe_To_Capture_In_Parameter_Value
return Boolean is
6558 E
: constant Entity_Id
:= Entity
(N
);
6559 S
: constant Entity_Id
:= Current_Scope
;
6563 if Ekind
(E
) /= E_In_Parameter
then
6567 -- Two initial context checks. We must be inside a subprogram body
6568 -- with declarations and reference must not appear in nested scopes.
6570 if (Ekind
(S
) /= E_Function
and then Ekind
(S
) /= E_Procedure
)
6571 or else Scope
(E
) /= S
6576 S_Par
:= Parent
(Parent
(S
));
6578 if Nkind
(S_Par
) /= N_Subprogram_Body
6579 or else No
(Declarations
(S_Par
))
6589 -- Retrieve the declaration node of N (if any). Note that N
6590 -- may be a part of a complex initialization expression.
6594 while Present
(P
) loop
6596 -- If we have a short circuit form, and we are within the right
6597 -- hand expression, we return false, since the right hand side
6598 -- is not guaranteed to be elaborated.
6600 if Nkind
(P
) in N_Short_Circuit
6601 and then N
= Right_Opnd
(P
)
6606 -- Similarly, if we are in an if expression and not part of the
6607 -- condition, then we return False, since neither the THEN or
6608 -- ELSE dependent expressions will always be elaborated.
6610 if Nkind
(P
) = N_If_Expression
6611 and then N
/= First
(Expressions
(P
))
6616 -- If within a case expression, and not part of the expression,
6617 -- then return False, since a particular dependent expression
6618 -- may not always be elaborated
6620 if Nkind
(P
) = N_Case_Expression
6621 and then N
/= Expression
(P
)
6626 -- While traversing the parent chain, if node N belongs to a
6627 -- statement, then it may never appear in a declarative region.
6629 if Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
6630 or else Nkind
(P
) = N_Procedure_Call_Statement
6635 -- If we are at a declaration, record it and exit
6637 if Nkind
(P
) in N_Declaration
6638 and then Nkind
(P
) not in N_Subprogram_Specification
6651 return List_Containing
(N_Decl
) = Declarations
(S_Par
);
6653 end Safe_To_Capture_In_Parameter_Value
;
6659 procedure Mark_Non_Null
is
6661 -- Only case of interest is if node N is an entity name
6663 if Is_Entity_Name
(N
) then
6665 -- For sure, we want to clear an indication that this is known to
6666 -- be null, since if we get past this check, it definitely is not.
6668 Set_Is_Known_Null
(Entity
(N
), False);
6670 -- We can mark the entity as known to be non-null if either it is
6671 -- safe to capture the value, or in the case of an IN parameter,
6672 -- which is a constant, if the check we just installed is in the
6673 -- declarative region of the subprogram body. In this latter case,
6674 -- a check is decisive for the rest of the body if the expression
6675 -- is sure to be elaborated, since we know we have to elaborate
6676 -- all declarations before executing the body.
6678 -- Couldn't this always be part of Safe_To_Capture_Value ???
6680 if Safe_To_Capture_Value
(N
, Entity
(N
))
6681 or else Safe_To_Capture_In_Parameter_Value
6683 Set_Is_Known_Non_Null
(Entity
(N
));
6688 -- Start of processing for Install_Null_Excluding_Check
6691 pragma Assert
(Is_Access_Type
(Typ
));
6693 -- No check inside a generic, check will be emitted in instance
6695 if Inside_A_Generic
then
6699 -- No check needed if known to be non-null
6701 if Known_Non_Null
(N
) then
6705 -- If known to be null, here is where we generate a compile time check
6707 if Known_Null
(N
) then
6709 -- Avoid generating warning message inside init procs. In SPARK mode
6710 -- we can go ahead and call Apply_Compile_Time_Constraint_Error
6711 -- since it will be turned into an error in any case.
6713 if (not Inside_Init_Proc
or else SPARK_Mode
= On
)
6715 -- Do not emit the warning within a conditional expression,
6716 -- where the expression might not be evaluated, and the warning
6717 -- appear as extraneous noise.
6719 and then not Within_Case_Or_If_Expression
(N
)
6721 Apply_Compile_Time_Constraint_Error
6722 (N
, "null value not allowed here??", CE_Access_Check_Failed
);
6724 -- Remaining cases, where we silently insert the raise
6728 Make_Raise_Constraint_Error
(Loc
,
6729 Reason
=> CE_Access_Check_Failed
));
6736 -- If entity is never assigned, for sure a warning is appropriate
6738 if Is_Entity_Name
(N
) then
6739 Check_Unset_Reference
(N
);
6742 -- No check needed if checks are suppressed on the range. Note that we
6743 -- don't set Is_Known_Non_Null in this case (we could legitimately do
6744 -- so, since the program is erroneous, but we don't like to casually
6745 -- propagate such conclusions from erroneosity).
6747 if Access_Checks_Suppressed
(Typ
) then
6751 -- No check needed for access to concurrent record types generated by
6752 -- the expander. This is not just an optimization (though it does indeed
6753 -- remove junk checks). It also avoids generation of junk warnings.
6755 if Nkind
(N
) in N_Has_Chars
6756 and then Chars
(N
) = Name_uObject
6757 and then Is_Concurrent_Record_Type
6758 (Directly_Designated_Type
(Etype
(N
)))
6763 -- No check needed in interface thunks since the runtime check is
6764 -- already performed at the caller side.
6766 if Is_Thunk
(Current_Scope
) then
6770 -- No check needed for the Get_Current_Excep.all.all idiom generated by
6771 -- the expander within exception handlers, since we know that the value
6772 -- can never be null.
6774 -- Is this really the right way to do this? Normally we generate such
6775 -- code in the expander with checks off, and that's how we suppress this
6776 -- kind of junk check ???
6778 if Nkind
(N
) = N_Function_Call
6779 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
6780 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
6781 and then Is_RTE
(Entity
(Prefix
(Name
(N
))), RE_Get_Current_Excep
)
6786 -- Otherwise install access check
6789 Make_Raise_Constraint_Error
(Loc
,
6792 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
6793 Right_Opnd
=> Make_Null
(Loc
)),
6794 Reason
=> CE_Access_Check_Failed
));
6797 end Install_Null_Excluding_Check
;
6799 --------------------------
6800 -- Install_Static_Check --
6801 --------------------------
6803 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
6804 Stat
: constant Boolean := Is_Static_Expression
(R_Cno
);
6805 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
6809 Make_Raise_Constraint_Error
(Loc
,
6810 Reason
=> CE_Range_Check_Failed
));
6811 Set_Analyzed
(R_Cno
);
6812 Set_Etype
(R_Cno
, Typ
);
6813 Set_Raises_Constraint_Error
(R_Cno
);
6814 Set_Is_Static_Expression
(R_Cno
, Stat
);
6816 -- Now deal with possible local raise handling
6818 Possible_Local_Raise
(R_Cno
, Standard_Constraint_Error
);
6819 end Install_Static_Check
;
6821 -------------------------
6822 -- Is_Check_Suppressed --
6823 -------------------------
6825 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
6826 Ptr
: Suppress_Stack_Entry_Ptr
;
6829 -- First search the local entity suppress stack. We search this from the
6830 -- top of the stack down so that we get the innermost entry that applies
6831 -- to this case if there are nested entries.
6833 Ptr
:= Local_Suppress_Stack_Top
;
6834 while Ptr
/= null loop
6835 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
6836 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
6838 return Ptr
.Suppress
;
6844 -- Now search the global entity suppress table for a matching entry.
6845 -- We also search this from the top down so that if there are multiple
6846 -- pragmas for the same entity, the last one applies (not clear what
6847 -- or whether the RM specifies this handling, but it seems reasonable).
6849 Ptr
:= Global_Suppress_Stack_Top
;
6850 while Ptr
/= null loop
6851 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
6852 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
6854 return Ptr
.Suppress
;
6860 -- If we did not find a matching entry, then use the normal scope
6861 -- suppress value after all (actually this will be the global setting
6862 -- since it clearly was not overridden at any point). For a predefined
6863 -- check, we test the specific flag. For a user defined check, we check
6864 -- the All_Checks flag. The Overflow flag requires special handling to
6865 -- deal with the General vs Assertion case
6867 if C
= Overflow_Check
then
6868 return Overflow_Checks_Suppressed
(Empty
);
6869 elsif C
in Predefined_Check_Id
then
6870 return Scope_Suppress
.Suppress
(C
);
6872 return Scope_Suppress
.Suppress
(All_Checks
);
6874 end Is_Check_Suppressed
;
6876 ---------------------
6877 -- Kill_All_Checks --
6878 ---------------------
6880 procedure Kill_All_Checks
is
6882 if Debug_Flag_CC
then
6883 w
("Kill_All_Checks");
6886 -- We reset the number of saved checks to zero, and also modify all
6887 -- stack entries for statement ranges to indicate that the number of
6888 -- checks at each level is now zero.
6890 Num_Saved_Checks
:= 0;
6892 -- Note: the Int'Min here avoids any possibility of J being out of
6893 -- range when called from e.g. Conditional_Statements_Begin.
6895 for J
in 1 .. Int
'Min (Saved_Checks_TOS
, Saved_Checks_Stack
'Last) loop
6896 Saved_Checks_Stack
(J
) := 0;
6898 end Kill_All_Checks
;
6904 procedure Kill_Checks
(V
: Entity_Id
) is
6906 if Debug_Flag_CC
then
6907 w
("Kill_Checks for entity", Int
(V
));
6910 for J
in 1 .. Num_Saved_Checks
loop
6911 if Saved_Checks
(J
).Entity
= V
then
6912 if Debug_Flag_CC
then
6913 w
(" Checks killed for saved check ", J
);
6916 Saved_Checks
(J
).Killed
:= True;
6921 ------------------------------
6922 -- Length_Checks_Suppressed --
6923 ------------------------------
6925 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6927 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6928 return Is_Check_Suppressed
(E
, Length_Check
);
6930 return Scope_Suppress
.Suppress
(Length_Check
);
6932 end Length_Checks_Suppressed
;
6934 -----------------------
6935 -- Make_Bignum_Block --
6936 -----------------------
6938 function Make_Bignum_Block
(Loc
: Source_Ptr
) return Node_Id
is
6939 M
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uM
);
6943 Make_Block_Statement
(Loc
,
6944 Declarations
=> New_List
(
6945 Make_Object_Declaration
(Loc
,
6946 Defining_Identifier
=> M
,
6947 Object_Definition
=>
6948 New_Occurrence_Of
(RTE
(RE_Mark_Id
), Loc
),
6950 Make_Function_Call
(Loc
,
6951 Name
=> New_Occurrence_Of
(RTE
(RE_SS_Mark
), Loc
)))),
6953 Handled_Statement_Sequence
=>
6954 Make_Handled_Sequence_Of_Statements
(Loc
,
6955 Statements
=> New_List
(
6956 Make_Procedure_Call_Statement
(Loc
,
6957 Name
=> New_Occurrence_Of
(RTE
(RE_SS_Release
), Loc
),
6958 Parameter_Associations
=> New_List
(
6959 New_Occurrence_Of
(M
, Loc
))))));
6960 end Make_Bignum_Block
;
6962 ----------------------------------
6963 -- Minimize_Eliminate_Overflows --
6964 ----------------------------------
6966 -- This is a recursive routine that is called at the top of an expression
6967 -- tree to properly process overflow checking for a whole subtree by making
6968 -- recursive calls to process operands. This processing may involve the use
6969 -- of bignum or long long integer arithmetic, which will change the types
6970 -- of operands and results. That's why we can't do this bottom up (since
6971 -- it would interfere with semantic analysis).
6973 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
6974 -- the operator expansion routines, as well as the expansion routines for
6975 -- if/case expression, do nothing (for the moment) except call the routine
6976 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
6977 -- routine does nothing for non top-level nodes, so at the point where the
6978 -- call is made for the top level node, the entire expression subtree has
6979 -- not been expanded, or processed for overflow. All that has to happen as
6980 -- a result of the top level call to this routine.
6982 -- As noted above, the overflow processing works by making recursive calls
6983 -- for the operands, and figuring out what to do, based on the processing
6984 -- of these operands (e.g. if a bignum operand appears, the parent op has
6985 -- to be done in bignum mode), and the determined ranges of the operands.
6987 -- After possible rewriting of a constituent subexpression node, a call is
6988 -- made to either reexpand the node (if nothing has changed) or reanalyze
6989 -- the node (if it has been modified by the overflow check processing). The
6990 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
6991 -- a recursive call into the whole overflow apparatus, an important rule
6992 -- for this call is that the overflow handling mode must be temporarily set
6995 procedure Minimize_Eliminate_Overflows
6999 Top_Level
: Boolean)
7001 Rtyp
: constant Entity_Id
:= Etype
(N
);
7002 pragma Assert
(Is_Signed_Integer_Type
(Rtyp
));
7003 -- Result type, must be a signed integer type
7005 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
7006 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
7008 Loc
: constant Source_Ptr
:= Sloc
(N
);
7011 -- Ranges of values for right operand (operator case)
7014 -- Ranges of values for left operand (operator case)
7016 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
7017 -- Operands and results are of this type when we convert
7019 LLLo
: constant Uint
:= Intval
(Type_Low_Bound
(LLIB
));
7020 LLHi
: constant Uint
:= Intval
(Type_High_Bound
(LLIB
));
7021 -- Bounds of Long_Long_Integer
7023 Binary
: constant Boolean := Nkind
(N
) in N_Binary_Op
;
7024 -- Indicates binary operator case
7027 -- Used in call to Determine_Range
7029 Bignum_Operands
: Boolean;
7030 -- Set True if one or more operands is already of type Bignum, meaning
7031 -- that for sure (regardless of Top_Level setting) we are committed to
7032 -- doing the operation in Bignum mode (or in the case of a case or if
7033 -- expression, converting all the dependent expressions to Bignum).
7035 Long_Long_Integer_Operands
: Boolean;
7036 -- Set True if one or more operands is already of type Long_Long_Integer
7037 -- which means that if the result is known to be in the result type
7038 -- range, then we must convert such operands back to the result type.
7040 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False);
7041 -- This is called when we have modified the node and we therefore need
7042 -- to reanalyze it. It is important that we reset the mode to STRICT for
7043 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
7044 -- we would reenter this routine recursively which would not be good.
7045 -- The argument Suppress is set True if we also want to suppress
7046 -- overflow checking for the reexpansion (this is set when we know
7047 -- overflow is not possible). Typ is the type for the reanalysis.
7049 procedure Reexpand
(Suppress
: Boolean := False);
7050 -- This is like Reanalyze, but does not do the Analyze step, it only
7051 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
7052 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
7053 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
7054 -- Note that skipping reanalysis is not just an optimization, testing
7055 -- has showed up several complex cases in which reanalyzing an already
7056 -- analyzed node causes incorrect behavior.
7058 function In_Result_Range
return Boolean;
7059 -- Returns True iff Lo .. Hi are within range of the result type
7061 procedure Max
(A
: in out Uint
; B
: Uint
);
7062 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
7064 procedure Min
(A
: in out Uint
; B
: Uint
);
7065 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
7067 ---------------------
7068 -- In_Result_Range --
7069 ---------------------
7071 function In_Result_Range
return Boolean is
7073 if Lo
= No_Uint
or else Hi
= No_Uint
then
7076 elsif Is_Static_Subtype
(Etype
(N
)) then
7077 return Lo
>= Expr_Value
(Type_Low_Bound
(Rtyp
))
7079 Hi
<= Expr_Value
(Type_High_Bound
(Rtyp
));
7082 return Lo
>= Expr_Value
(Type_Low_Bound
(Base_Type
(Rtyp
)))
7084 Hi
<= Expr_Value
(Type_High_Bound
(Base_Type
(Rtyp
)));
7086 end In_Result_Range
;
7092 procedure Max
(A
: in out Uint
; B
: Uint
) is
7094 if A
= No_Uint
or else B
> A
then
7103 procedure Min
(A
: in out Uint
; B
: Uint
) is
7105 if A
= No_Uint
or else B
< A
then
7114 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False) is
7115 Svg
: constant Overflow_Mode_Type
:=
7116 Scope_Suppress
.Overflow_Mode_General
;
7117 Sva
: constant Overflow_Mode_Type
:=
7118 Scope_Suppress
.Overflow_Mode_Assertions
;
7119 Svo
: constant Boolean :=
7120 Scope_Suppress
.Suppress
(Overflow_Check
);
7123 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7124 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7127 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
7130 Analyze_And_Resolve
(N
, Typ
);
7132 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
7133 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
7134 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
7141 procedure Reexpand
(Suppress
: Boolean := False) is
7142 Svg
: constant Overflow_Mode_Type
:=
7143 Scope_Suppress
.Overflow_Mode_General
;
7144 Sva
: constant Overflow_Mode_Type
:=
7145 Scope_Suppress
.Overflow_Mode_Assertions
;
7146 Svo
: constant Boolean :=
7147 Scope_Suppress
.Suppress
(Overflow_Check
);
7150 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7151 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7152 Set_Analyzed
(N
, False);
7155 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
7160 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
7161 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
7162 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
7165 -- Start of processing for Minimize_Eliminate_Overflows
7168 -- Case where we do not have a signed integer arithmetic operation
7170 if not Is_Signed_Integer_Arithmetic_Op
(N
) then
7172 -- Use the normal Determine_Range routine to get the range. We
7173 -- don't require operands to be valid, invalid values may result in
7174 -- rubbish results where the result has not been properly checked for
7175 -- overflow, that's fine.
7177 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> False);
7179 -- If Determine_Range did not work (can this in fact happen? Not
7180 -- clear but might as well protect), use type bounds.
7183 Lo
:= Intval
(Type_Low_Bound
(Base_Type
(Etype
(N
))));
7184 Hi
:= Intval
(Type_High_Bound
(Base_Type
(Etype
(N
))));
7187 -- If we don't have a binary operator, all we have to do is to set
7188 -- the Hi/Lo range, so we are done.
7192 -- Processing for if expression
7194 elsif Nkind
(N
) = N_If_Expression
then
7196 Then_DE
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
7197 Else_DE
: constant Node_Id
:= Next
(Then_DE
);
7200 Bignum_Operands
:= False;
7202 Minimize_Eliminate_Overflows
7203 (Then_DE
, Lo
, Hi
, Top_Level
=> False);
7205 if Lo
= No_Uint
then
7206 Bignum_Operands
:= True;
7209 Minimize_Eliminate_Overflows
7210 (Else_DE
, Rlo
, Rhi
, Top_Level
=> False);
7212 if Rlo
= No_Uint
then
7213 Bignum_Operands
:= True;
7215 Long_Long_Integer_Operands
:=
7216 Etype
(Then_DE
) = LLIB
or else Etype
(Else_DE
) = LLIB
;
7222 -- If at least one of our operands is now Bignum, we must rebuild
7223 -- the if expression to use Bignum operands. We will analyze the
7224 -- rebuilt if expression with overflow checks off, since once we
7225 -- are in bignum mode, we are all done with overflow checks.
7227 if Bignum_Operands
then
7229 Make_If_Expression
(Loc
,
7230 Expressions
=> New_List
(
7231 Remove_Head
(Expressions
(N
)),
7232 Convert_To_Bignum
(Then_DE
),
7233 Convert_To_Bignum
(Else_DE
)),
7234 Is_Elsif
=> Is_Elsif
(N
)));
7236 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
7238 -- If we have no Long_Long_Integer operands, then we are in result
7239 -- range, since it means that none of our operands felt the need
7240 -- to worry about overflow (otherwise it would have already been
7241 -- converted to long long integer or bignum). We reexpand to
7242 -- complete the expansion of the if expression (but we do not
7243 -- need to reanalyze).
7245 elsif not Long_Long_Integer_Operands
then
7246 Set_Do_Overflow_Check
(N
, False);
7249 -- Otherwise convert us to long long integer mode. Note that we
7250 -- don't need any further overflow checking at this level.
7253 Convert_To_And_Rewrite
(LLIB
, Then_DE
);
7254 Convert_To_And_Rewrite
(LLIB
, Else_DE
);
7255 Set_Etype
(N
, LLIB
);
7257 -- Now reanalyze with overflow checks off
7259 Set_Do_Overflow_Check
(N
, False);
7260 Reanalyze
(LLIB
, Suppress
=> True);
7266 -- Here for case expression
7268 elsif Nkind
(N
) = N_Case_Expression
then
7269 Bignum_Operands
:= False;
7270 Long_Long_Integer_Operands
:= False;
7276 -- Loop through expressions applying recursive call
7278 Alt
:= First
(Alternatives
(N
));
7279 while Present
(Alt
) loop
7281 Aexp
: constant Node_Id
:= Expression
(Alt
);
7284 Minimize_Eliminate_Overflows
7285 (Aexp
, Lo
, Hi
, Top_Level
=> False);
7287 if Lo
= No_Uint
then
7288 Bignum_Operands
:= True;
7289 elsif Etype
(Aexp
) = LLIB
then
7290 Long_Long_Integer_Operands
:= True;
7297 -- If we have no bignum or long long integer operands, it means
7298 -- that none of our dependent expressions could raise overflow.
7299 -- In this case, we simply return with no changes except for
7300 -- resetting the overflow flag, since we are done with overflow
7301 -- checks for this node. We will reexpand to get the needed
7302 -- expansion for the case expression, but we do not need to
7303 -- reanalyze, since nothing has changed.
7305 if not (Bignum_Operands
or Long_Long_Integer_Operands
) then
7306 Set_Do_Overflow_Check
(N
, False);
7307 Reexpand
(Suppress
=> True);
7309 -- Otherwise we are going to rebuild the case expression using
7310 -- either bignum or long long integer operands throughout.
7319 New_Alts
:= New_List
;
7320 Alt
:= First
(Alternatives
(N
));
7321 while Present
(Alt
) loop
7322 if Bignum_Operands
then
7323 New_Exp
:= Convert_To_Bignum
(Expression
(Alt
));
7324 Rtype
:= RTE
(RE_Bignum
);
7326 New_Exp
:= Convert_To
(LLIB
, Expression
(Alt
));
7330 Append_To
(New_Alts
,
7331 Make_Case_Expression_Alternative
(Sloc
(Alt
),
7333 Discrete_Choices
=> Discrete_Choices
(Alt
),
7334 Expression
=> New_Exp
));
7340 Make_Case_Expression
(Loc
,
7341 Expression
=> Expression
(N
),
7342 Alternatives
=> New_Alts
));
7344 Reanalyze
(Rtype
, Suppress
=> True);
7352 -- If we have an arithmetic operator we make recursive calls on the
7353 -- operands to get the ranges (and to properly process the subtree
7354 -- that lies below us).
7356 Minimize_Eliminate_Overflows
7357 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
7360 Minimize_Eliminate_Overflows
7361 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
7364 -- Record if we have Long_Long_Integer operands
7366 Long_Long_Integer_Operands
:=
7367 Etype
(Right_Opnd
(N
)) = LLIB
7368 or else (Binary
and then Etype
(Left_Opnd
(N
)) = LLIB
);
7370 -- If either operand is a bignum, then result will be a bignum and we
7371 -- don't need to do any range analysis. As previously discussed we could
7372 -- do range analysis in such cases, but it could mean working with giant
7373 -- numbers at compile time for very little gain (the number of cases
7374 -- in which we could slip back from bignum mode is small).
7376 if Rlo
= No_Uint
or else (Binary
and then Llo
= No_Uint
) then
7379 Bignum_Operands
:= True;
7381 -- Otherwise compute result range
7384 Bignum_Operands
:= False;
7392 Hi
:= UI_Max
(abs Rlo
, abs Rhi
);
7404 -- If the right operand can only be zero, set 0..0
7406 if Rlo
= 0 and then Rhi
= 0 then
7410 -- Possible bounds of division must come from dividing end
7411 -- values of the input ranges (four possibilities), provided
7412 -- zero is not included in the possible values of the right
7415 -- Otherwise, we just consider two intervals of values for
7416 -- the right operand: the interval of negative values (up to
7417 -- -1) and the interval of positive values (starting at 1).
7418 -- Since division by 1 is the identity, and division by -1
7419 -- is negation, we get all possible bounds of division in that
7420 -- case by considering:
7421 -- - all values from the division of end values of input
7423 -- - the end values of the left operand;
7424 -- - the negation of the end values of the left operand.
7428 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
7429 -- Mark so we can release the RR and Ev values
7437 -- Discard extreme values of zero for the divisor, since
7438 -- they will simply result in an exception in any case.
7446 -- Compute possible bounds coming from dividing end
7447 -- values of the input ranges.
7454 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
7455 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
7457 -- If the right operand can be both negative or positive,
7458 -- include the end values of the left operand in the
7459 -- extreme values, as well as their negation.
7461 if Rlo
< 0 and then Rhi
> 0 then
7468 UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
)));
7470 UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
)));
7473 -- Release the RR and Ev values
7475 Release_And_Save
(Mrk
, Lo
, Hi
);
7483 -- Discard negative values for the exponent, since they will
7484 -- simply result in an exception in any case.
7492 -- Estimate number of bits in result before we go computing
7493 -- giant useless bounds. Basically the number of bits in the
7494 -- result is the number of bits in the base multiplied by the
7495 -- value of the exponent. If this is big enough that the result
7496 -- definitely won't fit in Long_Long_Integer, switch to bignum
7497 -- mode immediately, and avoid computing giant bounds.
7499 -- The comparison here is approximate, but conservative, it
7500 -- only clicks on cases that are sure to exceed the bounds.
7502 if Num_Bits
(UI_Max
(abs Llo
, abs Lhi
)) * Rhi
+ 1 > 100 then
7506 -- If right operand is zero then result is 1
7513 -- High bound comes either from exponentiation of largest
7514 -- positive value to largest exponent value, or from
7515 -- the exponentiation of most negative value to an
7529 if Rhi
mod 2 = 0 then
7532 Hi2
:= Llo
** (Rhi
- 1);
7538 Hi
:= UI_Max
(Hi1
, Hi2
);
7541 -- Result can only be negative if base can be negative
7544 if Rhi
mod 2 = 0 then
7545 Lo
:= Llo
** (Rhi
- 1);
7550 -- Otherwise low bound is minimum ** minimum
7567 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
7568 -- This is the maximum absolute value of the result
7574 -- The result depends only on the sign and magnitude of
7575 -- the right operand, it does not depend on the sign or
7576 -- magnitude of the left operand.
7589 when N_Op_Multiply
=>
7591 -- Possible bounds of multiplication must come from multiplying
7592 -- end values of the input ranges (four possibilities).
7595 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
7596 -- Mark so we can release the Ev values
7598 Ev1
: constant Uint
:= Llo
* Rlo
;
7599 Ev2
: constant Uint
:= Llo
* Rhi
;
7600 Ev3
: constant Uint
:= Lhi
* Rlo
;
7601 Ev4
: constant Uint
:= Lhi
* Rhi
;
7604 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
7605 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
7607 -- Release the Ev values
7609 Release_And_Save
(Mrk
, Lo
, Hi
);
7612 -- Plus operator (affirmation)
7622 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
7623 -- This is the maximum absolute value of the result. Note
7624 -- that the result range does not depend on the sign of the
7631 -- Case of left operand negative, which results in a range
7632 -- of -Maxabs .. 0 for those negative values. If there are
7633 -- no negative values then Lo value of result is always 0.
7639 -- Case of left operand positive
7648 when N_Op_Subtract
=>
7652 -- Nothing else should be possible
7655 raise Program_Error
;
7659 -- Here for the case where we have not rewritten anything (no bignum
7660 -- operands or long long integer operands), and we know the result.
7661 -- If we know we are in the result range, and we do not have Bignum
7662 -- operands or Long_Long_Integer operands, we can just reexpand with
7663 -- overflow checks turned off (since we know we cannot have overflow).
7664 -- As always the reexpansion is required to complete expansion of the
7665 -- operator, but we do not need to reanalyze, and we prevent recursion
7666 -- by suppressing the check.
7668 if not (Bignum_Operands
or Long_Long_Integer_Operands
)
7669 and then In_Result_Range
7671 Set_Do_Overflow_Check
(N
, False);
7672 Reexpand
(Suppress
=> True);
7675 -- Here we know that we are not in the result range, and in the general
7676 -- case we will move into either the Bignum or Long_Long_Integer domain
7677 -- to compute the result. However, there is one exception. If we are
7678 -- at the top level, and we do not have Bignum or Long_Long_Integer
7679 -- operands, we will have to immediately convert the result back to
7680 -- the result type, so there is no point in Bignum/Long_Long_Integer
7684 and then not (Bignum_Operands
or Long_Long_Integer_Operands
)
7686 -- One further refinement. If we are at the top level, but our parent
7687 -- is a type conversion, then go into bignum or long long integer node
7688 -- since the result will be converted to that type directly without
7689 -- going through the result type, and we may avoid an overflow. This
7690 -- is the case for example of Long_Long_Integer (A ** 4), where A is
7691 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
7692 -- but does not fit in Integer.
7694 and then Nkind
(Parent
(N
)) /= N_Type_Conversion
7696 -- Here keep original types, but we need to complete analysis
7698 -- One subtlety. We can't just go ahead and do an analyze operation
7699 -- here because it will cause recursion into the whole MINIMIZED/
7700 -- ELIMINATED overflow processing which is not what we want. Here
7701 -- we are at the top level, and we need a check against the result
7702 -- mode (i.e. we want to use STRICT mode). So do exactly that.
7703 -- Also, we have not modified the node, so this is a case where
7704 -- we need to reexpand, but not reanalyze.
7709 -- Cases where we do the operation in Bignum mode. This happens either
7710 -- because one of our operands is in Bignum mode already, or because
7711 -- the computed bounds are outside the bounds of Long_Long_Integer,
7712 -- which in some cases can be indicated by Hi and Lo being No_Uint.
7714 -- Note: we could do better here and in some cases switch back from
7715 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
7716 -- 0 .. 1, but the cases are rare and it is not worth the effort.
7717 -- Failing to do this switching back is only an efficiency issue.
7719 elsif Lo
= No_Uint
or else Lo
< LLLo
or else Hi
> LLHi
then
7721 -- OK, we are definitely outside the range of Long_Long_Integer. The
7722 -- question is whether to move to Bignum mode, or stay in the domain
7723 -- of Long_Long_Integer, signalling that an overflow check is needed.
7725 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
7726 -- the Bignum business. In ELIMINATED mode, we will normally move
7727 -- into Bignum mode, but there is an exception if neither of our
7728 -- operands is Bignum now, and we are at the top level (Top_Level
7729 -- set True). In this case, there is no point in moving into Bignum
7730 -- mode to prevent overflow if the caller will immediately convert
7731 -- the Bignum value back to LLI with an overflow check. It's more
7732 -- efficient to stay in LLI mode with an overflow check (if needed)
7734 if Check_Mode
= Minimized
7735 or else (Top_Level
and not Bignum_Operands
)
7737 if Do_Overflow_Check
(N
) then
7738 Enable_Overflow_Check
(N
);
7741 -- The result now has to be in Long_Long_Integer mode, so adjust
7742 -- the possible range to reflect this. Note these calls also
7743 -- change No_Uint values from the top level case to LLI bounds.
7748 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
7751 pragma Assert
(Check_Mode
= Eliminated
);
7760 Fent
:= RTE
(RE_Big_Abs
);
7763 Fent
:= RTE
(RE_Big_Add
);
7766 Fent
:= RTE
(RE_Big_Div
);
7769 Fent
:= RTE
(RE_Big_Exp
);
7772 Fent
:= RTE
(RE_Big_Neg
);
7775 Fent
:= RTE
(RE_Big_Mod
);
7777 when N_Op_Multiply
=>
7778 Fent
:= RTE
(RE_Big_Mul
);
7781 Fent
:= RTE
(RE_Big_Rem
);
7783 when N_Op_Subtract
=>
7784 Fent
:= RTE
(RE_Big_Sub
);
7786 -- Anything else is an internal error, this includes the
7787 -- N_Op_Plus case, since how can plus cause the result
7788 -- to be out of range if the operand is in range?
7791 raise Program_Error
;
7794 -- Construct argument list for Bignum call, converting our
7795 -- operands to Bignum form if they are not already there.
7800 Append_To
(Args
, Convert_To_Bignum
(Left_Opnd
(N
)));
7803 Append_To
(Args
, Convert_To_Bignum
(Right_Opnd
(N
)));
7805 -- Now rewrite the arithmetic operator with a call to the
7806 -- corresponding bignum function.
7809 Make_Function_Call
(Loc
,
7810 Name
=> New_Occurrence_Of
(Fent
, Loc
),
7811 Parameter_Associations
=> Args
));
7812 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
7814 -- Indicate result is Bignum mode
7822 -- Otherwise we are in range of Long_Long_Integer, so no overflow
7823 -- check is required, at least not yet.
7826 Set_Do_Overflow_Check
(N
, False);
7829 -- Here we are not in Bignum territory, but we may have long long
7830 -- integer operands that need special handling. First a special check:
7831 -- If an exponentiation operator exponent is of type Long_Long_Integer,
7832 -- it means we converted it to prevent overflow, but exponentiation
7833 -- requires a Natural right operand, so convert it back to Natural.
7834 -- This conversion may raise an exception which is fine.
7836 if Nkind
(N
) = N_Op_Expon
and then Etype
(Right_Opnd
(N
)) = LLIB
then
7837 Convert_To_And_Rewrite
(Standard_Natural
, Right_Opnd
(N
));
7840 -- Here we will do the operation in Long_Long_Integer. We do this even
7841 -- if we know an overflow check is required, better to do this in long
7842 -- long integer mode, since we are less likely to overflow.
7844 -- Convert right or only operand to Long_Long_Integer, except that
7845 -- we do not touch the exponentiation right operand.
7847 if Nkind
(N
) /= N_Op_Expon
then
7848 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
7851 -- Convert left operand to Long_Long_Integer for binary case
7854 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
7857 -- Reset node to unanalyzed
7859 Set_Analyzed
(N
, False);
7860 Set_Etype
(N
, Empty
);
7861 Set_Entity
(N
, Empty
);
7863 -- Now analyze this new node. This reanalysis will complete processing
7864 -- for the node. In particular we will complete the expansion of an
7865 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
7866 -- we will complete any division checks (since we have not changed the
7867 -- setting of the Do_Division_Check flag).
7869 -- We do this reanalysis in STRICT mode to avoid recursion into the
7870 -- MINIMIZED/ELIMINATED handling, since we are now done with that.
7873 SG
: constant Overflow_Mode_Type
:=
7874 Scope_Suppress
.Overflow_Mode_General
;
7875 SA
: constant Overflow_Mode_Type
:=
7876 Scope_Suppress
.Overflow_Mode_Assertions
;
7879 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7880 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7882 if not Do_Overflow_Check
(N
) then
7883 Reanalyze
(LLIB
, Suppress
=> True);
7888 Scope_Suppress
.Overflow_Mode_General
:= SG
;
7889 Scope_Suppress
.Overflow_Mode_Assertions
:= SA
;
7891 end Minimize_Eliminate_Overflows
;
7893 -------------------------
7894 -- Overflow_Check_Mode --
7895 -------------------------
7897 function Overflow_Check_Mode
return Overflow_Mode_Type
is
7899 if In_Assertion_Expr
= 0 then
7900 return Scope_Suppress
.Overflow_Mode_General
;
7902 return Scope_Suppress
.Overflow_Mode_Assertions
;
7904 end Overflow_Check_Mode
;
7906 --------------------------------
7907 -- Overflow_Checks_Suppressed --
7908 --------------------------------
7910 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7912 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7913 return Is_Check_Suppressed
(E
, Overflow_Check
);
7915 return Scope_Suppress
.Suppress
(Overflow_Check
);
7917 end Overflow_Checks_Suppressed
;
7919 ---------------------------------
7920 -- Predicate_Checks_Suppressed --
7921 ---------------------------------
7923 function Predicate_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7925 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7926 return Is_Check_Suppressed
(E
, Predicate_Check
);
7928 return Scope_Suppress
.Suppress
(Predicate_Check
);
7930 end Predicate_Checks_Suppressed
;
7932 -----------------------------
7933 -- Range_Checks_Suppressed --
7934 -----------------------------
7936 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7940 -- Note: for now we always suppress range checks on Vax float types,
7941 -- since Gigi does not know how to generate these checks.
7943 if Vax_Float
(E
) then
7945 elsif Kill_Range_Checks
(E
) then
7947 elsif Checks_May_Be_Suppressed
(E
) then
7948 return Is_Check_Suppressed
(E
, Range_Check
);
7952 return Scope_Suppress
.Suppress
(Range_Check
);
7953 end Range_Checks_Suppressed
;
7955 -----------------------------------------
7956 -- Range_Or_Validity_Checks_Suppressed --
7957 -----------------------------------------
7959 -- Note: the coding would be simpler here if we simply made appropriate
7960 -- calls to Range/Validity_Checks_Suppressed, but that would result in
7961 -- duplicated checks which we prefer to avoid.
7963 function Range_Or_Validity_Checks_Suppressed
7964 (Expr
: Node_Id
) return Boolean
7967 -- Immediate return if scope checks suppressed for either check
7969 if Scope_Suppress
.Suppress
(Range_Check
)
7971 Scope_Suppress
.Suppress
(Validity_Check
)
7976 -- If no expression, that's odd, decide that checks are suppressed,
7977 -- since we don't want anyone trying to do checks in this case, which
7978 -- is most likely the result of some other error.
7984 -- Expression is present, so perform suppress checks on type
7987 Typ
: constant Entity_Id
:= Etype
(Expr
);
7989 if Vax_Float
(Typ
) then
7991 elsif Checks_May_Be_Suppressed
(Typ
)
7992 and then (Is_Check_Suppressed
(Typ
, Range_Check
)
7994 Is_Check_Suppressed
(Typ
, Validity_Check
))
8000 -- If expression is an entity name, perform checks on this entity
8002 if Is_Entity_Name
(Expr
) then
8004 Ent
: constant Entity_Id
:= Entity
(Expr
);
8006 if Checks_May_Be_Suppressed
(Ent
) then
8007 return Is_Check_Suppressed
(Ent
, Range_Check
)
8008 or else Is_Check_Suppressed
(Ent
, Validity_Check
);
8013 -- If we fall through, no checks suppressed
8016 end Range_Or_Validity_Checks_Suppressed
;
8022 procedure Remove_Checks
(Expr
: Node_Id
) is
8023 function Process
(N
: Node_Id
) return Traverse_Result
;
8024 -- Process a single node during the traversal
8026 procedure Traverse
is new Traverse_Proc
(Process
);
8027 -- The traversal procedure itself
8033 function Process
(N
: Node_Id
) return Traverse_Result
is
8035 if Nkind
(N
) not in N_Subexpr
then
8039 Set_Do_Range_Check
(N
, False);
8043 Traverse
(Left_Opnd
(N
));
8046 when N_Attribute_Reference
=>
8047 Set_Do_Overflow_Check
(N
, False);
8049 when N_Function_Call
=>
8050 Set_Do_Tag_Check
(N
, False);
8053 Set_Do_Overflow_Check
(N
, False);
8057 Set_Do_Division_Check
(N
, False);
8060 Set_Do_Length_Check
(N
, False);
8063 Set_Do_Division_Check
(N
, False);
8066 Set_Do_Length_Check
(N
, False);
8069 Set_Do_Division_Check
(N
, False);
8072 Set_Do_Length_Check
(N
, False);
8079 Traverse
(Left_Opnd
(N
));
8082 when N_Selected_Component
=>
8083 Set_Do_Discriminant_Check
(N
, False);
8085 when N_Type_Conversion
=>
8086 Set_Do_Length_Check
(N
, False);
8087 Set_Do_Tag_Check
(N
, False);
8088 Set_Do_Overflow_Check
(N
, False);
8097 -- Start of processing for Remove_Checks
8103 ----------------------------
8104 -- Selected_Length_Checks --
8105 ----------------------------
8107 function Selected_Length_Checks
8109 Target_Typ
: Entity_Id
;
8110 Source_Typ
: Entity_Id
;
8111 Warn_Node
: Node_Id
) return Check_Result
8113 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
8116 Expr_Actual
: Node_Id
;
8118 Cond
: Node_Id
:= Empty
;
8119 Do_Access
: Boolean := False;
8120 Wnode
: Node_Id
:= Warn_Node
;
8121 Ret_Result
: Check_Result
:= (Empty
, Empty
);
8122 Num_Checks
: Natural := 0;
8124 procedure Add_Check
(N
: Node_Id
);
8125 -- Adds the action given to Ret_Result if N is non-Empty
8127 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
8128 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8129 -- Comments required ???
8131 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
8132 -- True for equal literals and for nodes that denote the same constant
8133 -- entity, even if its value is not a static constant. This includes the
8134 -- case of a discriminal reference within an init proc. Removes some
8135 -- obviously superfluous checks.
8137 function Length_E_Cond
8138 (Exptyp
: Entity_Id
;
8140 Indx
: Nat
) return Node_Id
;
8141 -- Returns expression to compute:
8142 -- Typ'Length /= Exptyp'Length
8144 function Length_N_Cond
8147 Indx
: Nat
) return Node_Id
;
8148 -- Returns expression to compute:
8149 -- Typ'Length /= Expr'Length
8155 procedure Add_Check
(N
: Node_Id
) is
8159 -- For now, ignore attempt to place more than two checks ???
8160 -- This is really worrisome, are we really discarding checks ???
8162 if Num_Checks
= 2 then
8166 pragma Assert
(Num_Checks
<= 1);
8167 Num_Checks
:= Num_Checks
+ 1;
8168 Ret_Result
(Num_Checks
) := N
;
8176 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
8177 SE
: constant Entity_Id
:= Scope
(E
);
8179 E1
: Entity_Id
:= E
;
8182 if Ekind
(Scope
(E
)) = E_Record_Type
8183 and then Has_Discriminants
(Scope
(E
))
8185 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
8188 Insert_Action
(Ck_Node
, N
);
8189 E1
:= Defining_Identifier
(N
);
8193 if Ekind
(E1
) = E_String_Literal_Subtype
then
8195 Make_Integer_Literal
(Loc
,
8196 Intval
=> String_Literal_Length
(E1
));
8198 elsif SE
/= Standard_Standard
8199 and then Ekind
(Scope
(SE
)) = E_Protected_Type
8200 and then Has_Discriminants
(Scope
(SE
))
8201 and then Has_Completion
(Scope
(SE
))
8202 and then not Inside_Init_Proc
8204 -- If the type whose length is needed is a private component
8205 -- constrained by a discriminant, we must expand the 'Length
8206 -- attribute into an explicit computation, using the discriminal
8207 -- of the current protected operation. This is because the actual
8208 -- type of the prival is constructed after the protected opera-
8209 -- tion has been fully expanded.
8212 Indx_Type
: Node_Id
;
8215 Do_Expand
: Boolean := False;
8218 Indx_Type
:= First_Index
(E
);
8220 for J
in 1 .. Indx
- 1 loop
8221 Next_Index
(Indx_Type
);
8224 Get_Index_Bounds
(Indx_Type
, Lo
, Hi
);
8226 if Nkind
(Lo
) = N_Identifier
8227 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
8229 Lo
:= Get_Discriminal
(E
, Lo
);
8233 if Nkind
(Hi
) = N_Identifier
8234 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
8236 Hi
:= Get_Discriminal
(E
, Hi
);
8241 if not Is_Entity_Name
(Lo
) then
8242 Lo
:= Duplicate_Subexpr_No_Checks
(Lo
);
8245 if not Is_Entity_Name
(Hi
) then
8246 Lo
:= Duplicate_Subexpr_No_Checks
(Hi
);
8252 Make_Op_Subtract
(Loc
,
8256 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
8261 Make_Attribute_Reference
(Loc
,
8262 Attribute_Name
=> Name_Length
,
8264 New_Occurrence_Of
(E1
, Loc
));
8267 Set_Expressions
(N
, New_List
(
8268 Make_Integer_Literal
(Loc
, Indx
)));
8277 Make_Attribute_Reference
(Loc
,
8278 Attribute_Name
=> Name_Length
,
8280 New_Occurrence_Of
(E1
, Loc
));
8283 Set_Expressions
(N
, New_List
(
8284 Make_Integer_Literal
(Loc
, Indx
)));
8295 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8298 Make_Attribute_Reference
(Loc
,
8299 Attribute_Name
=> Name_Length
,
8301 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8302 Expressions
=> New_List
(
8303 Make_Integer_Literal
(Loc
, Indx
)));
8310 function Length_E_Cond
8311 (Exptyp
: Entity_Id
;
8313 Indx
: Nat
) return Node_Id
8318 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8319 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
8326 function Length_N_Cond
8329 Indx
: Nat
) return Node_Id
8334 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8335 Right_Opnd
=> Get_N_Length
(Expr
, Indx
));
8342 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
8345 (Nkind
(L
) = N_Integer_Literal
8346 and then Nkind
(R
) = N_Integer_Literal
8347 and then Intval
(L
) = Intval
(R
))
8351 and then Ekind
(Entity
(L
)) = E_Constant
8352 and then ((Is_Entity_Name
(R
)
8353 and then Entity
(L
) = Entity
(R
))
8355 (Nkind
(R
) = N_Type_Conversion
8356 and then Is_Entity_Name
(Expression
(R
))
8357 and then Entity
(L
) = Entity
(Expression
(R
)))))
8361 and then Ekind
(Entity
(R
)) = E_Constant
8362 and then Nkind
(L
) = N_Type_Conversion
8363 and then Is_Entity_Name
(Expression
(L
))
8364 and then Entity
(R
) = Entity
(Expression
(L
)))
8368 and then Is_Entity_Name
(R
)
8369 and then Entity
(L
) = Entity
(R
)
8370 and then Ekind
(Entity
(L
)) = E_In_Parameter
8371 and then Inside_Init_Proc
);
8374 -- Start of processing for Selected_Length_Checks
8377 if not Expander_Active
then
8381 if Target_Typ
= Any_Type
8382 or else Target_Typ
= Any_Composite
8383 or else Raises_Constraint_Error
(Ck_Node
)
8392 T_Typ
:= Target_Typ
;
8394 if No
(Source_Typ
) then
8395 S_Typ
:= Etype
(Ck_Node
);
8397 S_Typ
:= Source_Typ
;
8400 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
8404 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
8405 S_Typ
:= Designated_Type
(S_Typ
);
8406 T_Typ
:= Designated_Type
(T_Typ
);
8409 -- A simple optimization for the null case
8411 if Known_Null
(Ck_Node
) then
8416 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
8417 if Is_Constrained
(T_Typ
) then
8419 -- The checking code to be generated will freeze the corresponding
8420 -- array type. However, we must freeze the type now, so that the
8421 -- freeze node does not appear within the generated if expression,
8424 Freeze_Before
(Ck_Node
, T_Typ
);
8426 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
8427 Exptyp
:= Get_Actual_Subtype
(Ck_Node
);
8429 if Is_Access_Type
(Exptyp
) then
8430 Exptyp
:= Designated_Type
(Exptyp
);
8433 -- String_Literal case. This needs to be handled specially be-
8434 -- cause no index types are available for string literals. The
8435 -- condition is simply:
8437 -- T_Typ'Length = string-literal-length
8439 if Nkind
(Expr_Actual
) = N_String_Literal
8440 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
8444 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
8446 Make_Integer_Literal
(Loc
,
8448 String_Literal_Length
(Etype
(Expr_Actual
))));
8450 -- General array case. Here we have a usable actual subtype for
8451 -- the expression, and the condition is built from the two types
8454 -- T_Typ'Length /= Exptyp'Length or else
8455 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
8456 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
8459 elsif Is_Constrained
(Exptyp
) then
8461 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
8474 -- At the library level, we need to ensure that the type of
8475 -- the object is elaborated before the check itself is
8476 -- emitted. This is only done if the object is in the
8477 -- current compilation unit, otherwise the type is frozen
8478 -- and elaborated in its unit.
8480 if Is_Itype
(Exptyp
)
8482 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
8484 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
8485 and then In_Open_Scopes
(Scope
(Exptyp
))
8487 Ref_Node
:= Make_Itype_Reference
(Sloc
(Ck_Node
));
8488 Set_Itype
(Ref_Node
, Exptyp
);
8489 Insert_Action
(Ck_Node
, Ref_Node
);
8492 L_Index
:= First_Index
(T_Typ
);
8493 R_Index
:= First_Index
(Exptyp
);
8495 for Indx
in 1 .. Ndims
loop
8496 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
8498 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
8500 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
8501 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
8503 -- Deal with compile time length check. Note that we
8504 -- skip this in the access case, because the access
8505 -- value may be null, so we cannot know statically.
8508 and then Compile_Time_Known_Value
(L_Low
)
8509 and then Compile_Time_Known_Value
(L_High
)
8510 and then Compile_Time_Known_Value
(R_Low
)
8511 and then Compile_Time_Known_Value
(R_High
)
8513 if Expr_Value
(L_High
) >= Expr_Value
(L_Low
) then
8514 L_Length
:= Expr_Value
(L_High
) -
8515 Expr_Value
(L_Low
) + 1;
8517 L_Length
:= UI_From_Int
(0);
8520 if Expr_Value
(R_High
) >= Expr_Value
(R_Low
) then
8521 R_Length
:= Expr_Value
(R_High
) -
8522 Expr_Value
(R_Low
) + 1;
8524 R_Length
:= UI_From_Int
(0);
8527 if L_Length
> R_Length
then
8529 (Compile_Time_Constraint_Error
8530 (Wnode
, "too few elements for}??", T_Typ
));
8532 elsif L_Length
< R_Length
then
8534 (Compile_Time_Constraint_Error
8535 (Wnode
, "too many elements for}??", T_Typ
));
8538 -- The comparison for an individual index subtype
8539 -- is omitted if the corresponding index subtypes
8540 -- statically match, since the result is known to
8541 -- be true. Note that this test is worth while even
8542 -- though we do static evaluation, because non-static
8543 -- subtypes can statically match.
8546 Subtypes_Statically_Match
8547 (Etype
(L_Index
), Etype
(R_Index
))
8550 (Same_Bounds
(L_Low
, R_Low
)
8551 and then Same_Bounds
(L_High
, R_High
))
8554 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
8563 -- Handle cases where we do not get a usable actual subtype that
8564 -- is constrained. This happens for example in the function call
8565 -- and explicit dereference cases. In these cases, we have to get
8566 -- the length or range from the expression itself, making sure we
8567 -- do not evaluate it more than once.
8569 -- Here Ck_Node is the original expression, or more properly the
8570 -- result of applying Duplicate_Expr to the original tree, forcing
8571 -- the result to be a name.
8575 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
8578 -- Build the condition for the explicit dereference case
8580 for Indx
in 1 .. Ndims
loop
8582 (Cond
, Length_N_Cond
(Ck_Node
, T_Typ
, Indx
));
8589 -- Construct the test and insert into the tree
8591 if Present
(Cond
) then
8593 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
8597 (Make_Raise_Constraint_Error
(Loc
,
8599 Reason
=> CE_Length_Check_Failed
));
8603 end Selected_Length_Checks
;
8605 ---------------------------
8606 -- Selected_Range_Checks --
8607 ---------------------------
8609 function Selected_Range_Checks
8611 Target_Typ
: Entity_Id
;
8612 Source_Typ
: Entity_Id
;
8613 Warn_Node
: Node_Id
) return Check_Result
8615 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
8618 Expr_Actual
: Node_Id
;
8620 Cond
: Node_Id
:= Empty
;
8621 Do_Access
: Boolean := False;
8622 Wnode
: Node_Id
:= Warn_Node
;
8623 Ret_Result
: Check_Result
:= (Empty
, Empty
);
8624 Num_Checks
: Integer := 0;
8626 procedure Add_Check
(N
: Node_Id
);
8627 -- Adds the action given to Ret_Result if N is non-Empty
8629 function Discrete_Range_Cond
8631 Typ
: Entity_Id
) return Node_Id
;
8632 -- Returns expression to compute:
8633 -- Low_Bound (Expr) < Typ'First
8635 -- High_Bound (Expr) > Typ'Last
8637 function Discrete_Expr_Cond
8639 Typ
: Entity_Id
) return Node_Id
;
8640 -- Returns expression to compute:
8645 function Get_E_First_Or_Last
8649 Nam
: Name_Id
) return Node_Id
;
8650 -- Returns an attribute reference
8651 -- E'First or E'Last
8652 -- with a source location of Loc.
8654 -- Nam is Name_First or Name_Last, according to which attribute is
8655 -- desired. If Indx is non-zero, it is passed as a literal in the
8656 -- Expressions of the attribute reference (identifying the desired
8657 -- array dimension).
8659 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8660 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8661 -- Returns expression to compute:
8662 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
8664 function Range_E_Cond
8665 (Exptyp
: Entity_Id
;
8669 -- Returns expression to compute:
8670 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
8672 function Range_Equal_E_Cond
8673 (Exptyp
: Entity_Id
;
8675 Indx
: Nat
) return Node_Id
;
8676 -- Returns expression to compute:
8677 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
8679 function Range_N_Cond
8682 Indx
: Nat
) return Node_Id
;
8683 -- Return expression to compute:
8684 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
8690 procedure Add_Check
(N
: Node_Id
) is
8694 -- For now, ignore attempt to place more than 2 checks ???
8696 if Num_Checks
= 2 then
8700 pragma Assert
(Num_Checks
<= 1);
8701 Num_Checks
:= Num_Checks
+ 1;
8702 Ret_Result
(Num_Checks
) := N
;
8706 -------------------------
8707 -- Discrete_Expr_Cond --
8708 -------------------------
8710 function Discrete_Expr_Cond
8712 Typ
: Entity_Id
) return Node_Id
8720 Convert_To
(Base_Type
(Typ
),
8721 Duplicate_Subexpr_No_Checks
(Expr
)),
8723 Convert_To
(Base_Type
(Typ
),
8724 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
))),
8729 Convert_To
(Base_Type
(Typ
),
8730 Duplicate_Subexpr_No_Checks
(Expr
)),
8734 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
))));
8735 end Discrete_Expr_Cond
;
8737 -------------------------
8738 -- Discrete_Range_Cond --
8739 -------------------------
8741 function Discrete_Range_Cond
8743 Typ
: Entity_Id
) return Node_Id
8745 LB
: Node_Id
:= Low_Bound
(Expr
);
8746 HB
: Node_Id
:= High_Bound
(Expr
);
8748 Left_Opnd
: Node_Id
;
8749 Right_Opnd
: Node_Id
;
8752 if Nkind
(LB
) = N_Identifier
8753 and then Ekind
(Entity
(LB
)) = E_Discriminant
8755 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
8762 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
8767 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
)));
8769 if Nkind
(HB
) = N_Identifier
8770 and then Ekind
(Entity
(HB
)) = E_Discriminant
8772 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
8779 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
8784 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
)));
8786 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
8787 end Discrete_Range_Cond
;
8789 -------------------------
8790 -- Get_E_First_Or_Last --
8791 -------------------------
8793 function Get_E_First_Or_Last
8797 Nam
: Name_Id
) return Node_Id
8802 Exprs
:= New_List
(Make_Integer_Literal
(Loc
, UI_From_Int
(Indx
)));
8807 return Make_Attribute_Reference
(Loc
,
8808 Prefix
=> New_Occurrence_Of
(E
, Loc
),
8809 Attribute_Name
=> Nam
,
8810 Expressions
=> Exprs
);
8811 end Get_E_First_Or_Last
;
8817 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8820 Make_Attribute_Reference
(Loc
,
8821 Attribute_Name
=> Name_First
,
8823 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8824 Expressions
=> New_List
(
8825 Make_Integer_Literal
(Loc
, Indx
)));
8832 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8835 Make_Attribute_Reference
(Loc
,
8836 Attribute_Name
=> Name_Last
,
8838 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8839 Expressions
=> New_List
(
8840 Make_Integer_Literal
(Loc
, Indx
)));
8847 function Range_E_Cond
8848 (Exptyp
: Entity_Id
;
8850 Indx
: Nat
) return Node_Id
8858 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
8860 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8865 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
8867 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8870 ------------------------
8871 -- Range_Equal_E_Cond --
8872 ------------------------
8874 function Range_Equal_E_Cond
8875 (Exptyp
: Entity_Id
;
8877 Indx
: Nat
) return Node_Id
8885 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
8887 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8892 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
8894 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8895 end Range_Equal_E_Cond
;
8901 function Range_N_Cond
8904 Indx
: Nat
) return Node_Id
8912 Get_N_First
(Expr
, Indx
),
8914 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8919 Get_N_Last
(Expr
, Indx
),
8921 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8924 -- Start of processing for Selected_Range_Checks
8927 if not Expander_Active
then
8931 if Target_Typ
= Any_Type
8932 or else Target_Typ
= Any_Composite
8933 or else Raises_Constraint_Error
(Ck_Node
)
8942 T_Typ
:= Target_Typ
;
8944 if No
(Source_Typ
) then
8945 S_Typ
:= Etype
(Ck_Node
);
8947 S_Typ
:= Source_Typ
;
8950 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
8954 -- The order of evaluating T_Typ before S_Typ seems to be critical
8955 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
8956 -- in, and since Node can be an N_Range node, it might be invalid.
8957 -- Should there be an assert check somewhere for taking the Etype of
8958 -- an N_Range node ???
8960 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
8961 S_Typ
:= Designated_Type
(S_Typ
);
8962 T_Typ
:= Designated_Type
(T_Typ
);
8965 -- A simple optimization for the null case
8967 if Known_Null
(Ck_Node
) then
8972 -- For an N_Range Node, check for a null range and then if not
8973 -- null generate a range check action.
8975 if Nkind
(Ck_Node
) = N_Range
then
8977 -- There's no point in checking a range against itself
8979 if Ck_Node
= Scalar_Range
(T_Typ
) then
8984 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
8985 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
8986 Known_T_LB
: constant Boolean := Compile_Time_Known_Value
(T_LB
);
8987 Known_T_HB
: constant Boolean := Compile_Time_Known_Value
(T_HB
);
8989 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
8990 HB
: Node_Id
:= High_Bound
(Ck_Node
);
8994 Null_Range
: Boolean;
8995 Out_Of_Range_L
: Boolean;
8996 Out_Of_Range_H
: Boolean;
8999 -- Compute what is known at compile time
9001 if Known_T_LB
and Known_T_HB
then
9002 if Compile_Time_Known_Value
(LB
) then
9005 -- There's no point in checking that a bound is within its
9006 -- own range so pretend that it is known in this case. First
9007 -- deal with low bound.
9009 elsif Ekind
(Etype
(LB
)) = E_Signed_Integer_Subtype
9010 and then Scalar_Range
(Etype
(LB
)) = Scalar_Range
(T_Typ
)
9019 -- Likewise for the high bound
9021 if Compile_Time_Known_Value
(HB
) then
9024 elsif Ekind
(Etype
(HB
)) = E_Signed_Integer_Subtype
9025 and then Scalar_Range
(Etype
(HB
)) = Scalar_Range
(T_Typ
)
9034 -- Check for case where everything is static and we can do the
9035 -- check at compile time. This is skipped if we have an access
9036 -- type, since the access value may be null.
9038 -- ??? This code can be improved since you only need to know that
9039 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
9040 -- compile time to emit pertinent messages.
9042 if Known_T_LB
and Known_T_HB
and Known_LB
and Known_HB
9045 -- Floating-point case
9047 if Is_Floating_Point_Type
(S_Typ
) then
9048 Null_Range
:= Expr_Value_R
(HB
) < Expr_Value_R
(LB
);
9050 (Expr_Value_R
(LB
) < Expr_Value_R
(T_LB
))
9052 (Expr_Value_R
(LB
) > Expr_Value_R
(T_HB
));
9055 (Expr_Value_R
(HB
) > Expr_Value_R
(T_HB
))
9057 (Expr_Value_R
(HB
) < Expr_Value_R
(T_LB
));
9059 -- Fixed or discrete type case
9062 Null_Range
:= Expr_Value
(HB
) < Expr_Value
(LB
);
9064 (Expr_Value
(LB
) < Expr_Value
(T_LB
))
9066 (Expr_Value
(LB
) > Expr_Value
(T_HB
));
9069 (Expr_Value
(HB
) > Expr_Value
(T_HB
))
9071 (Expr_Value
(HB
) < Expr_Value
(T_LB
));
9074 if not Null_Range
then
9075 if Out_Of_Range_L
then
9076 if No
(Warn_Node
) then
9078 (Compile_Time_Constraint_Error
9079 (Low_Bound
(Ck_Node
),
9080 "static value out of range of}??", T_Typ
));
9084 (Compile_Time_Constraint_Error
9086 "static range out of bounds of}??", T_Typ
));
9090 if Out_Of_Range_H
then
9091 if No
(Warn_Node
) then
9093 (Compile_Time_Constraint_Error
9094 (High_Bound
(Ck_Node
),
9095 "static value out of range of}??", T_Typ
));
9099 (Compile_Time_Constraint_Error
9101 "static range out of bounds of}??", T_Typ
));
9108 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
9109 HB
: Node_Id
:= High_Bound
(Ck_Node
);
9112 -- If either bound is a discriminant and we are within the
9113 -- record declaration, it is a use of the discriminant in a
9114 -- constraint of a component, and nothing can be checked
9115 -- here. The check will be emitted within the init proc.
9116 -- Before then, the discriminal has no real meaning.
9117 -- Similarly, if the entity is a discriminal, there is no
9118 -- check to perform yet.
9120 -- The same holds within a discriminated synchronized type,
9121 -- where the discriminant may constrain a component or an
9124 if Nkind
(LB
) = N_Identifier
9125 and then Denotes_Discriminant
(LB
, True)
9127 if Current_Scope
= Scope
(Entity
(LB
))
9128 or else Is_Concurrent_Type
(Current_Scope
)
9129 or else Ekind
(Entity
(LB
)) /= E_Discriminant
9134 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
9138 if Nkind
(HB
) = N_Identifier
9139 and then Denotes_Discriminant
(HB
, True)
9141 if Current_Scope
= Scope
(Entity
(HB
))
9142 or else Is_Concurrent_Type
(Current_Scope
)
9143 or else Ekind
(Entity
(HB
)) /= E_Discriminant
9148 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
9152 Cond
:= Discrete_Range_Cond
(Ck_Node
, T_Typ
);
9153 Set_Paren_Count
(Cond
, 1);
9160 Convert_To
(Base_Type
(Etype
(HB
)),
9161 Duplicate_Subexpr_No_Checks
(HB
)),
9163 Convert_To
(Base_Type
(Etype
(LB
)),
9164 Duplicate_Subexpr_No_Checks
(LB
))),
9165 Right_Opnd
=> Cond
);
9170 elsif Is_Scalar_Type
(S_Typ
) then
9172 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
9173 -- except the above simply sets a flag in the node and lets
9174 -- gigi generate the check base on the Etype of the expression.
9175 -- Sometimes, however we want to do a dynamic check against an
9176 -- arbitrary target type, so we do that here.
9178 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
9179 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9181 -- For literals, we can tell if the constraint error will be
9182 -- raised at compile time, so we never need a dynamic check, but
9183 -- if the exception will be raised, then post the usual warning,
9184 -- and replace the literal with a raise constraint error
9185 -- expression. As usual, skip this for access types
9187 elsif Compile_Time_Known_Value
(Ck_Node
) and then not Do_Access
then
9189 LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
9190 UB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
9192 Out_Of_Range
: Boolean;
9193 Static_Bounds
: constant Boolean :=
9194 Compile_Time_Known_Value
(LB
)
9195 and Compile_Time_Known_Value
(UB
);
9198 -- Following range tests should use Sem_Eval routine ???
9200 if Static_Bounds
then
9201 if Is_Floating_Point_Type
(S_Typ
) then
9203 (Expr_Value_R
(Ck_Node
) < Expr_Value_R
(LB
))
9205 (Expr_Value_R
(Ck_Node
) > Expr_Value_R
(UB
));
9207 -- Fixed or discrete type
9211 Expr_Value
(Ck_Node
) < Expr_Value
(LB
)
9213 Expr_Value
(Ck_Node
) > Expr_Value
(UB
);
9216 -- Bounds of the type are static and the literal is out of
9217 -- range so output a warning message.
9219 if Out_Of_Range
then
9220 if No
(Warn_Node
) then
9222 (Compile_Time_Constraint_Error
9224 "static value out of range of}??", T_Typ
));
9228 (Compile_Time_Constraint_Error
9230 "static value out of range of}??", T_Typ
));
9235 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9239 -- Here for the case of a non-static expression, we need a runtime
9240 -- check unless the source type range is guaranteed to be in the
9241 -- range of the target type.
9244 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
9245 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9250 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
9251 if Is_Constrained
(T_Typ
) then
9253 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
9254 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
9256 if Is_Access_Type
(Exptyp
) then
9257 Exptyp
:= Designated_Type
(Exptyp
);
9260 -- String_Literal case. This needs to be handled specially be-
9261 -- cause no index types are available for string literals. The
9262 -- condition is simply:
9264 -- T_Typ'Length = string-literal-length
9266 if Nkind
(Expr_Actual
) = N_String_Literal
then
9269 -- General array case. Here we have a usable actual subtype for
9270 -- the expression, and the condition is built from the two types
9272 -- T_Typ'First < Exptyp'First or else
9273 -- T_Typ'Last > Exptyp'Last or else
9274 -- T_Typ'First(1) < Exptyp'First(1) or else
9275 -- T_Typ'Last(1) > Exptyp'Last(1) or else
9278 elsif Is_Constrained
(Exptyp
) then
9280 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9286 L_Index
:= First_Index
(T_Typ
);
9287 R_Index
:= First_Index
(Exptyp
);
9289 for Indx
in 1 .. Ndims
loop
9290 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
9292 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
9294 -- Deal with compile time length check. Note that we
9295 -- skip this in the access case, because the access
9296 -- value may be null, so we cannot know statically.
9299 Subtypes_Statically_Match
9300 (Etype
(L_Index
), Etype
(R_Index
))
9302 -- If the target type is constrained then we
9303 -- have to check for exact equality of bounds
9304 -- (required for qualified expressions).
9306 if Is_Constrained
(T_Typ
) then
9309 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
9312 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
9322 -- Handle cases where we do not get a usable actual subtype that
9323 -- is constrained. This happens for example in the function call
9324 -- and explicit dereference cases. In these cases, we have to get
9325 -- the length or range from the expression itself, making sure we
9326 -- do not evaluate it more than once.
9328 -- Here Ck_Node is the original expression, or more properly the
9329 -- result of applying Duplicate_Expr to the original tree,
9330 -- forcing the result to be a name.
9334 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9337 -- Build the condition for the explicit dereference case
9339 for Indx
in 1 .. Ndims
loop
9341 (Cond
, Range_N_Cond
(Ck_Node
, T_Typ
, Indx
));
9347 -- For a conversion to an unconstrained array type, generate an
9348 -- Action to check that the bounds of the source value are within
9349 -- the constraints imposed by the target type (RM 4.6(38)). No
9350 -- check is needed for a conversion to an access to unconstrained
9351 -- array type, as 4.6(24.15/2) requires the designated subtypes
9352 -- of the two access types to statically match.
9354 if Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
9355 and then not Do_Access
9358 Opnd_Index
: Node_Id
;
9359 Targ_Index
: Node_Id
;
9360 Opnd_Range
: Node_Id
;
9363 Opnd_Index
:= First_Index
(Get_Actual_Subtype
(Ck_Node
));
9364 Targ_Index
:= First_Index
(T_Typ
);
9365 while Present
(Opnd_Index
) loop
9367 -- If the index is a range, use its bounds. If it is an
9368 -- entity (as will be the case if it is a named subtype
9369 -- or an itype created for a slice) retrieve its range.
9371 if Is_Entity_Name
(Opnd_Index
)
9372 and then Is_Type
(Entity
(Opnd_Index
))
9374 Opnd_Range
:= Scalar_Range
(Entity
(Opnd_Index
));
9376 Opnd_Range
:= Opnd_Index
;
9379 if Nkind
(Opnd_Range
) = N_Range
then
9381 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9382 Assume_Valid
=> True)
9385 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9386 Assume_Valid
=> True)
9390 -- If null range, no check needed
9393 Compile_Time_Known_Value
(High_Bound
(Opnd_Range
))
9395 Compile_Time_Known_Value
(Low_Bound
(Opnd_Range
))
9397 Expr_Value
(High_Bound
(Opnd_Range
)) <
9398 Expr_Value
(Low_Bound
(Opnd_Range
))
9402 elsif Is_Out_Of_Range
9403 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9404 Assume_Valid
=> True)
9407 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9408 Assume_Valid
=> True)
9411 (Compile_Time_Constraint_Error
9412 (Wnode
, "value out of range of}??", T_Typ
));
9418 (Opnd_Range
, Etype
(Targ_Index
)));
9422 Next_Index
(Opnd_Index
);
9423 Next_Index
(Targ_Index
);
9430 -- Construct the test and insert into the tree
9432 if Present
(Cond
) then
9434 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
9438 (Make_Raise_Constraint_Error
(Loc
,
9440 Reason
=> CE_Range_Check_Failed
));
9444 end Selected_Range_Checks
;
9446 -------------------------------
9447 -- Storage_Checks_Suppressed --
9448 -------------------------------
9450 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9452 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9453 return Is_Check_Suppressed
(E
, Storage_Check
);
9455 return Scope_Suppress
.Suppress
(Storage_Check
);
9457 end Storage_Checks_Suppressed
;
9459 ---------------------------
9460 -- Tag_Checks_Suppressed --
9461 ---------------------------
9463 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9466 and then Checks_May_Be_Suppressed
(E
)
9468 return Is_Check_Suppressed
(E
, Tag_Check
);
9470 return Scope_Suppress
.Suppress
(Tag_Check
);
9472 end Tag_Checks_Suppressed
;
9474 --------------------------
9475 -- Validity_Check_Range --
9476 --------------------------
9478 procedure Validity_Check_Range
(N
: Node_Id
) is
9480 if Validity_Checks_On
and Validity_Check_Operands
then
9481 if Nkind
(N
) = N_Range
then
9482 Ensure_Valid
(Low_Bound
(N
));
9483 Ensure_Valid
(High_Bound
(N
));
9486 end Validity_Check_Range
;
9488 --------------------------------
9489 -- Validity_Checks_Suppressed --
9490 --------------------------------
9492 function Validity_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9494 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9495 return Is_Check_Suppressed
(E
, Validity_Check
);
9497 return Scope_Suppress
.Suppress
(Validity_Check
);
9499 end Validity_Checks_Suppressed
;