1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Casing
; use Casing
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Errout
; use Errout
;
31 with Exp_Ch2
; use Exp_Ch2
;
32 with Exp_Ch4
; use Exp_Ch4
;
33 with Exp_Ch11
; use Exp_Ch11
;
34 with Exp_Pakd
; use Exp_Pakd
;
35 with Exp_Tss
; use Exp_Tss
;
36 with Exp_Util
; use Exp_Util
;
37 with Elists
; use Elists
;
38 with Expander
; use Expander
;
39 with Eval_Fat
; use Eval_Fat
;
40 with Freeze
; use Freeze
;
42 with Nlists
; use Nlists
;
43 with Nmake
; use Nmake
;
45 with Output
; use Output
;
46 with Restrict
; use Restrict
;
47 with Rident
; use Rident
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Aux
; use Sem_Aux
;
51 with Sem_Eval
; use Sem_Eval
;
52 with Sem_Ch3
; use Sem_Ch3
;
53 with Sem_Ch8
; use Sem_Ch8
;
54 with Sem_Res
; use Sem_Res
;
55 with Sem_Util
; use Sem_Util
;
56 with Sem_Warn
; use Sem_Warn
;
57 with Sinfo
; use Sinfo
;
58 with Sinput
; use Sinput
;
59 with Snames
; use Snames
;
60 with Sprint
; use Sprint
;
61 with Stand
; use Stand
;
62 with Stringt
; use Stringt
;
63 with Targparm
; use Targparm
;
64 with Tbuild
; use Tbuild
;
65 with Ttypes
; use Ttypes
;
66 with Urealp
; use Urealp
;
67 with Validsw
; use Validsw
;
69 package body Checks
is
71 -- General note: many of these routines are concerned with generating
72 -- checking code to make sure that constraint error is raised at runtime.
73 -- Clearly this code is only needed if the expander is active, since
74 -- otherwise we will not be generating code or going into the runtime
77 -- We therefore disconnect most of these checks if the expander is
78 -- inactive. This has the additional benefit that we do not need to
79 -- worry about the tree being messed up by previous errors (since errors
80 -- turn off expansion anyway).
82 -- There are a few exceptions to the above rule. For instance routines
83 -- such as Apply_Scalar_Range_Check that do not insert any code can be
84 -- safely called even when the Expander is inactive (but Errors_Detected
85 -- is 0). The benefit of executing this code when expansion is off, is
86 -- the ability to emit constraint error warning for static expressions
87 -- even when we are not generating code.
89 -------------------------------------
90 -- Suppression of Redundant Checks --
91 -------------------------------------
93 -- This unit implements a limited circuit for removal of redundant
94 -- checks. The processing is based on a tracing of simple sequential
95 -- flow. For any sequence of statements, we save expressions that are
96 -- marked to be checked, and then if the same expression appears later
97 -- with the same check, then under certain circumstances, the second
98 -- check can be suppressed.
100 -- Basically, we can suppress the check if we know for certain that
101 -- the previous expression has been elaborated (together with its
102 -- check), and we know that the exception frame is the same, and that
103 -- nothing has happened to change the result of the exception.
105 -- Let us examine each of these three conditions in turn to describe
106 -- how we ensure that this condition is met.
108 -- First, we need to know for certain that the previous expression has
109 -- been executed. This is done principally by the mechanism of calling
110 -- Conditional_Statements_Begin at the start of any statement sequence
111 -- and Conditional_Statements_End at the end. The End call causes all
112 -- checks remembered since the Begin call to be discarded. This does
113 -- miss a few cases, notably the case of a nested BEGIN-END block with
114 -- no exception handlers. But the important thing is to be conservative.
115 -- The other protection is that all checks are discarded if a label
116 -- is encountered, since then the assumption of sequential execution
117 -- is violated, and we don't know enough about the flow.
119 -- Second, we need to know that the exception frame is the same. We
120 -- do this by killing all remembered checks when we enter a new frame.
121 -- Again, that's over-conservative, but generally the cases we can help
122 -- with are pretty local anyway (like the body of a loop for example).
124 -- Third, we must be sure to forget any checks which are no longer valid.
125 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
126 -- used to note any changes to local variables. We only attempt to deal
127 -- with checks involving local variables, so we do not need to worry
128 -- about global variables. Second, a call to any non-global procedure
129 -- causes us to abandon all stored checks, since such a all may affect
130 -- the values of any local variables.
132 -- The following define the data structures used to deal with remembering
133 -- checks so that redundant checks can be eliminated as described above.
135 -- Right now, the only expressions that we deal with are of the form of
136 -- simple local objects (either declared locally, or IN parameters) or
137 -- such objects plus/minus a compile time known constant. We can do
138 -- more later on if it seems worthwhile, but this catches many simple
139 -- cases in practice.
141 -- The following record type reflects a single saved check. An entry
142 -- is made in the stack of saved checks if and only if the expression
143 -- has been elaborated with the indicated checks.
145 type Saved_Check
is record
147 -- Set True if entry is killed by Kill_Checks
150 -- The entity involved in the expression that is checked
153 -- A compile time value indicating the result of adding or
154 -- subtracting a compile time value. This value is to be
155 -- added to the value of the Entity. A value of zero is
156 -- used for the case of a simple entity reference.
158 Check_Type
: Character;
159 -- This is set to 'R' for a range check (in which case Target_Type
160 -- is set to the target type for the range check) or to 'O' for an
161 -- overflow check (in which case Target_Type is set to Empty).
163 Target_Type
: Entity_Id
;
164 -- Used only if Do_Range_Check is set. Records the target type for
165 -- the check. We need this, because a check is a duplicate only if
166 -- it has the same target type (or more accurately one with a
167 -- range that is smaller or equal to the stored target type of a
171 -- The following table keeps track of saved checks. Rather than use an
172 -- extensible table. We just use a table of fixed size, and we discard
173 -- any saved checks that do not fit. That's very unlikely to happen and
174 -- this is only an optimization in any case.
176 Saved_Checks
: array (Int
range 1 .. 200) of Saved_Check
;
177 -- Array of saved checks
179 Num_Saved_Checks
: Nat
:= 0;
180 -- Number of saved checks
182 -- The following stack keeps track of statement ranges. It is treated
183 -- as a stack. When Conditional_Statements_Begin is called, an entry
184 -- is pushed onto this stack containing the value of Num_Saved_Checks
185 -- at the time of the call. Then when Conditional_Statements_End is
186 -- called, this value is popped off and used to reset Num_Saved_Checks.
188 -- Note: again, this is a fixed length stack with a size that should
189 -- always be fine. If the value of the stack pointer goes above the
190 -- limit, then we just forget all saved checks.
192 Saved_Checks_Stack
: array (Int
range 1 .. 100) of Nat
;
193 Saved_Checks_TOS
: Nat
:= 0;
195 -----------------------
196 -- Local Subprograms --
197 -----------------------
199 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
);
200 -- Used to apply arithmetic overflow checks for all cases except operators
201 -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we
202 -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a
203 -- signed integer arithmetic operator (but not an if or case expression).
204 -- It is also called for types other than signed integers.
206 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
);
207 -- Used to apply arithmetic overflow checks for the case where the overflow
208 -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer
209 -- arithmetic op (which includes the case of if and case expressions). Note
210 -- that Do_Overflow_Check may or may not be set for node Op. In these modes
211 -- we have work to do even if overflow checking is suppressed.
213 procedure Apply_Division_Check
218 -- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies
219 -- division checks as required if the Do_Division_Check flag is set.
220 -- Rlo and Rhi give the possible range of the right operand, these values
221 -- can be referenced and trusted only if ROK is set True.
223 procedure Apply_Float_Conversion_Check
225 Target_Typ
: Entity_Id
);
226 -- The checks on a conversion from a floating-point type to an integer
227 -- type are delicate. They have to be performed before conversion, they
228 -- have to raise an exception when the operand is a NaN, and rounding must
229 -- be taken into account to determine the safe bounds of the operand.
231 procedure Apply_Selected_Length_Checks
233 Target_Typ
: Entity_Id
;
234 Source_Typ
: Entity_Id
;
235 Do_Static
: Boolean);
236 -- This is the subprogram that does all the work for Apply_Length_Check
237 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
238 -- described for the above routines. The Do_Static flag indicates that
239 -- only a static check is to be done.
241 procedure Apply_Selected_Range_Checks
243 Target_Typ
: Entity_Id
;
244 Source_Typ
: Entity_Id
;
245 Do_Static
: Boolean);
246 -- This is the subprogram that does all the work for Apply_Range_Check.
247 -- Expr, Target_Typ and Source_Typ are as described for the above
248 -- routine. The Do_Static flag indicates that only a static check is
251 type Check_Type
is new Check_Id
range Access_Check
.. Division_Check
;
252 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean;
253 -- This function is used to see if an access or division by zero check is
254 -- needed. The check is to be applied to a single variable appearing in the
255 -- source, and N is the node for the reference. If N is not of this form,
256 -- True is returned with no further processing. If N is of the right form,
257 -- then further processing determines if the given Check is needed.
259 -- The particular circuit is to see if we have the case of a check that is
260 -- not needed because it appears in the right operand of a short circuited
261 -- conditional where the left operand guards the check. For example:
263 -- if Var = 0 or else Q / Var > 12 then
267 -- In this example, the division check is not required. At the same time
268 -- we can issue warnings for suspicious use of non-short-circuited forms,
271 -- if Var = 0 or Q / Var > 12 then
277 Check_Type
: Character;
278 Target_Type
: Entity_Id
;
279 Entry_OK
: out Boolean;
283 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
284 -- to see if a check is of the form for optimization, and if so, to see
285 -- if it has already been performed. Expr is the expression to check,
286 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
287 -- Target_Type is the target type for a range check, and Empty for an
288 -- overflow check. If the entry is not of the form for optimization,
289 -- then Entry_OK is set to False, and the remaining out parameters
290 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
291 -- entity and offset from the expression. Check_Num is the number of
292 -- a matching saved entry in Saved_Checks, or zero if no such entry
295 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
;
296 -- If a discriminal is used in constraining a prival, Return reference
297 -- to the discriminal of the protected body (which renames the parameter
298 -- of the enclosing protected operation). This clumsy transformation is
299 -- needed because privals are created too late and their actual subtypes
300 -- are not available when analysing the bodies of the protected operations.
301 -- This function is called whenever the bound is an entity and the scope
302 -- indicates a protected operation. If the bound is an in-parameter of
303 -- a protected operation that is not a prival, the function returns the
305 -- To be cleaned up???
307 function Guard_Access
310 Ck_Node
: Node_Id
) return Node_Id
;
311 -- In the access type case, guard the test with a test to ensure
312 -- that the access value is non-null, since the checks do not
313 -- not apply to null access values.
315 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
);
316 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
317 -- Constraint_Error node.
319 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean;
320 -- Returns True if node N is for an arithmetic operation with signed
321 -- integer operands. This includes unary and binary operators, and also
322 -- if and case expression nodes where the dependent expressions are of
323 -- a signed integer type. These are the kinds of nodes for which special
324 -- handling applies in MINIMIZED or ELIMINATED overflow checking mode.
326 function Range_Or_Validity_Checks_Suppressed
327 (Expr
: Node_Id
) return Boolean;
328 -- Returns True if either range or validity checks or both are suppressed
329 -- for the type of the given expression, or, if the expression is the name
330 -- of an entity, if these checks are suppressed for the entity.
332 function Selected_Length_Checks
334 Target_Typ
: Entity_Id
;
335 Source_Typ
: Entity_Id
;
336 Warn_Node
: Node_Id
) return Check_Result
;
337 -- Like Apply_Selected_Length_Checks, except it doesn't modify
338 -- anything, just returns a list of nodes as described in the spec of
339 -- this package for the Range_Check function.
341 function Selected_Range_Checks
343 Target_Typ
: Entity_Id
;
344 Source_Typ
: Entity_Id
;
345 Warn_Node
: Node_Id
) return Check_Result
;
346 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
347 -- just returns a list of nodes as described in the spec of this package
348 -- for the Range_Check function.
350 ------------------------------
351 -- Access_Checks_Suppressed --
352 ------------------------------
354 function Access_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
356 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
357 return Is_Check_Suppressed
(E
, Access_Check
);
359 return Scope_Suppress
.Suppress
(Access_Check
);
361 end Access_Checks_Suppressed
;
363 -------------------------------------
364 -- Accessibility_Checks_Suppressed --
365 -------------------------------------
367 function Accessibility_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
369 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
370 return Is_Check_Suppressed
(E
, Accessibility_Check
);
372 return Scope_Suppress
.Suppress
(Accessibility_Check
);
374 end Accessibility_Checks_Suppressed
;
376 -----------------------------
377 -- Activate_Division_Check --
378 -----------------------------
380 procedure Activate_Division_Check
(N
: Node_Id
) is
382 Set_Do_Division_Check
(N
, True);
383 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
384 end Activate_Division_Check
;
386 -----------------------------
387 -- Activate_Overflow_Check --
388 -----------------------------
390 procedure Activate_Overflow_Check
(N
: Node_Id
) is
392 if not Nkind_In
(N
, N_Op_Rem
, N_Op_Mod
, N_Op_Plus
) then
393 Set_Do_Overflow_Check
(N
, True);
394 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
396 end Activate_Overflow_Check
;
398 --------------------------
399 -- Activate_Range_Check --
400 --------------------------
402 procedure Activate_Range_Check
(N
: Node_Id
) is
404 Set_Do_Range_Check
(N
, True);
405 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
406 end Activate_Range_Check
;
408 ---------------------------------
409 -- Alignment_Checks_Suppressed --
410 ---------------------------------
412 function Alignment_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
414 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
415 return Is_Check_Suppressed
(E
, Alignment_Check
);
417 return Scope_Suppress
.Suppress
(Alignment_Check
);
419 end Alignment_Checks_Suppressed
;
421 -------------------------
422 -- Append_Range_Checks --
423 -------------------------
425 procedure Append_Range_Checks
426 (Checks
: Check_Result
;
428 Suppress_Typ
: Entity_Id
;
429 Static_Sloc
: Source_Ptr
;
432 Internal_Flag_Node
: constant Node_Id
:= Flag_Node
;
433 Internal_Static_Sloc
: constant Source_Ptr
:= Static_Sloc
;
435 Checks_On
: constant Boolean :=
436 (not Index_Checks_Suppressed
(Suppress_Typ
))
437 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
440 -- For now we just return if Checks_On is false, however this should
441 -- be enhanced to check for an always True value in the condition
442 -- and to generate a compilation warning???
444 if not Checks_On
then
449 exit when No
(Checks
(J
));
451 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
452 and then Present
(Condition
(Checks
(J
)))
454 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
455 Append_To
(Stmts
, Checks
(J
));
456 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
462 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
463 Reason
=> CE_Range_Check_Failed
));
466 end Append_Range_Checks
;
468 ------------------------
469 -- Apply_Access_Check --
470 ------------------------
472 procedure Apply_Access_Check
(N
: Node_Id
) is
473 P
: constant Node_Id
:= Prefix
(N
);
476 -- We do not need checks if we are not generating code (i.e. the
477 -- expander is not active). This is not just an optimization, there
478 -- are cases (e.g. with pragma Debug) where generating the checks
479 -- can cause real trouble).
481 if not Full_Expander_Active
then
485 -- No check if short circuiting makes check unnecessary
487 if not Check_Needed
(P
, Access_Check
) then
491 -- No check if accessing the Offset_To_Top component of a dispatch
492 -- table. They are safe by construction.
494 if Tagged_Type_Expansion
495 and then Present
(Etype
(P
))
496 and then RTU_Loaded
(Ada_Tags
)
497 and then RTE_Available
(RE_Offset_To_Top_Ptr
)
498 and then Etype
(P
) = RTE
(RE_Offset_To_Top_Ptr
)
503 -- Otherwise go ahead and install the check
505 Install_Null_Excluding_Check
(P
);
506 end Apply_Access_Check
;
508 -------------------------------
509 -- Apply_Accessibility_Check --
510 -------------------------------
512 procedure Apply_Accessibility_Check
515 Insert_Node
: Node_Id
)
517 Loc
: constant Source_Ptr
:= Sloc
(N
);
518 Param_Ent
: Entity_Id
:= Param_Entity
(N
);
519 Param_Level
: Node_Id
;
520 Type_Level
: Node_Id
;
523 if Ada_Version
>= Ada_2012
524 and then not Present
(Param_Ent
)
525 and then Is_Entity_Name
(N
)
526 and then Ekind_In
(Entity
(N
), E_Constant
, E_Variable
)
527 and then Present
(Effective_Extra_Accessibility
(Entity
(N
)))
529 Param_Ent
:= Entity
(N
);
530 while Present
(Renamed_Object
(Param_Ent
)) loop
532 -- Renamed_Object must return an Entity_Name here
533 -- because of preceding "Present (E_E_A (...))" test.
535 Param_Ent
:= Entity
(Renamed_Object
(Param_Ent
));
539 if Inside_A_Generic
then
542 -- Only apply the run-time check if the access parameter has an
543 -- associated extra access level parameter and when the level of the
544 -- type is less deep than the level of the access parameter, and
545 -- accessibility checks are not suppressed.
547 elsif Present
(Param_Ent
)
548 and then Present
(Extra_Accessibility
(Param_Ent
))
549 and then UI_Gt
(Object_Access_Level
(N
),
550 Deepest_Type_Access_Level
(Typ
))
551 and then not Accessibility_Checks_Suppressed
(Param_Ent
)
552 and then not Accessibility_Checks_Suppressed
(Typ
)
555 New_Occurrence_Of
(Extra_Accessibility
(Param_Ent
), Loc
);
558 Make_Integer_Literal
(Loc
, Deepest_Type_Access_Level
(Typ
));
560 -- Raise Program_Error if the accessibility level of the access
561 -- parameter is deeper than the level of the target access type.
563 Insert_Action
(Insert_Node
,
564 Make_Raise_Program_Error
(Loc
,
567 Left_Opnd
=> Param_Level
,
568 Right_Opnd
=> Type_Level
),
569 Reason
=> PE_Accessibility_Check_Failed
));
571 Analyze_And_Resolve
(N
);
573 end Apply_Accessibility_Check
;
575 --------------------------------
576 -- Apply_Address_Clause_Check --
577 --------------------------------
579 procedure Apply_Address_Clause_Check
(E
: Entity_Id
; N
: Node_Id
) is
580 pragma Assert
(Nkind
(N
) = N_Freeze_Entity
);
582 AC
: constant Node_Id
:= Address_Clause
(E
);
583 Loc
: constant Source_Ptr
:= Sloc
(AC
);
584 Typ
: constant Entity_Id
:= Etype
(E
);
585 Aexp
: constant Node_Id
:= Expression
(AC
);
588 -- Address expression (not necessarily the same as Aexp, for example
589 -- when Aexp is a reference to a constant, in which case Expr gets
590 -- reset to reference the value expression of the constant.
592 procedure Compile_Time_Bad_Alignment
;
593 -- Post error warnings when alignment is known to be incompatible. Note
594 -- that we do not go as far as inserting a raise of Program_Error since
595 -- this is an erroneous case, and it may happen that we are lucky and an
596 -- underaligned address turns out to be OK after all.
598 --------------------------------
599 -- Compile_Time_Bad_Alignment --
600 --------------------------------
602 procedure Compile_Time_Bad_Alignment
is
604 if Address_Clause_Overlay_Warnings
then
606 ("?o?specified address for& may be inconsistent with alignment",
609 ("\?o?program execution may be erroneous (RM 13.3(27))",
611 Set_Address_Warning_Posted
(AC
);
613 end Compile_Time_Bad_Alignment
;
615 -- Start of processing for Apply_Address_Clause_Check
618 -- See if alignment check needed. Note that we never need a check if the
619 -- maximum alignment is one, since the check will always succeed.
621 -- Note: we do not check for checks suppressed here, since that check
622 -- was done in Sem_Ch13 when the address clause was processed. We are
623 -- only called if checks were not suppressed. The reason for this is
624 -- that we have to delay the call to Apply_Alignment_Check till freeze
625 -- time (so that all types etc are elaborated), but we have to check
626 -- the status of check suppressing at the point of the address clause.
629 or else not Check_Address_Alignment
(AC
)
630 or else Maximum_Alignment
= 1
635 -- Obtain expression from address clause
637 Expr
:= Expression
(AC
);
639 -- The following loop digs for the real expression to use in the check
642 -- For constant, get constant expression
644 if Is_Entity_Name
(Expr
)
645 and then Ekind
(Entity
(Expr
)) = E_Constant
647 Expr
:= Constant_Value
(Entity
(Expr
));
649 -- For unchecked conversion, get result to convert
651 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
652 Expr
:= Expression
(Expr
);
654 -- For (common case) of To_Address call, get argument
656 elsif Nkind
(Expr
) = N_Function_Call
657 and then Is_Entity_Name
(Name
(Expr
))
658 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
660 Expr
:= First
(Parameter_Associations
(Expr
));
662 if Nkind
(Expr
) = N_Parameter_Association
then
663 Expr
:= Explicit_Actual_Parameter
(Expr
);
666 -- We finally have the real expression
673 -- See if we know that Expr has a bad alignment at compile time
675 if Compile_Time_Known_Value
(Expr
)
676 and then (Known_Alignment
(E
) or else Known_Alignment
(Typ
))
679 AL
: Uint
:= Alignment
(Typ
);
682 -- The object alignment might be more restrictive than the
685 if Known_Alignment
(E
) then
689 if Expr_Value
(Expr
) mod AL
/= 0 then
690 Compile_Time_Bad_Alignment
;
696 -- If the expression has the form X'Address, then we can find out if
697 -- the object X has an alignment that is compatible with the object E.
698 -- If it hasn't or we don't know, we defer issuing the warning until
699 -- the end of the compilation to take into account back end annotations.
701 elsif Nkind
(Expr
) = N_Attribute_Reference
702 and then Attribute_Name
(Expr
) = Name_Address
703 and then Has_Compatible_Alignment
(E
, Prefix
(Expr
)) = Known_Compatible
708 -- Here we do not know if the value is acceptable. Strictly we don't
709 -- have to do anything, since if the alignment is bad, we have an
710 -- erroneous program. However we are allowed to check for erroneous
711 -- conditions and we decide to do this by default if the check is not
714 -- However, don't do the check if elaboration code is unwanted
716 if Restriction_Active
(No_Elaboration_Code
) then
719 -- Generate a check to raise PE if alignment may be inappropriate
722 -- If the original expression is a non-static constant, use the
723 -- name of the constant itself rather than duplicating its
724 -- defining expression, which was extracted above.
726 -- Note: Expr is empty if the address-clause is applied to in-mode
727 -- actuals (allowed by 13.1(22)).
729 if not Present
(Expr
)
731 (Is_Entity_Name
(Expression
(AC
))
732 and then Ekind
(Entity
(Expression
(AC
))) = E_Constant
733 and then Nkind
(Parent
(Entity
(Expression
(AC
))))
734 = N_Object_Declaration
)
736 Expr
:= New_Copy_Tree
(Expression
(AC
));
738 Remove_Side_Effects
(Expr
);
741 if No
(Actions
(N
)) then
742 Set_Actions
(N
, New_List
);
745 Prepend_To
(Actions
(N
),
746 Make_Raise_Program_Error
(Loc
,
753 (RTE
(RE_Integer_Address
), Expr
),
755 Make_Attribute_Reference
(Loc
,
756 Prefix
=> New_Occurrence_Of
(E
, Loc
),
757 Attribute_Name
=> Name_Alignment
)),
758 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
759 Reason
=> PE_Misaligned_Address_Value
));
760 Analyze
(First
(Actions
(N
)), Suppress
=> All_Checks
);
765 -- If we have some missing run time component in configurable run time
766 -- mode then just skip the check (it is not required in any case).
768 when RE_Not_Available
=>
770 end Apply_Address_Clause_Check
;
772 -------------------------------------
773 -- Apply_Arithmetic_Overflow_Check --
774 -------------------------------------
776 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
778 -- Use old routine in almost all cases (the only case we are treating
779 -- specially is the case of a signed integer arithmetic op with the
780 -- overflow checking mode set to MINIMIZED or ELIMINATED).
782 if Overflow_Check_Mode
= Strict
783 or else not Is_Signed_Integer_Arithmetic_Op
(N
)
785 Apply_Arithmetic_Overflow_Strict
(N
);
787 -- Otherwise use the new routine for the case of a signed integer
788 -- arithmetic op, with Do_Overflow_Check set to True, and the checking
789 -- mode is MINIMIZED or ELIMINATED.
792 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
794 end Apply_Arithmetic_Overflow_Check
;
796 --------------------------------------
797 -- Apply_Arithmetic_Overflow_Strict --
798 --------------------------------------
800 -- This routine is called only if the type is an integer type, and a
801 -- software arithmetic overflow check may be needed for op (add, subtract,
802 -- or multiply). This check is performed only if Software_Overflow_Checking
803 -- is enabled and Do_Overflow_Check is set. In this case we expand the
804 -- operation into a more complex sequence of tests that ensures that
805 -- overflow is properly caught.
807 -- This is used in CHECKED modes. It is identical to the code for this
808 -- cases before the big overflow earthquake, thus ensuring that in this
809 -- modes we have compatible behavior (and reliability) to what was there
810 -- before. It is also called for types other than signed integers, and if
811 -- the Do_Overflow_Check flag is off.
813 -- Note: we also call this routine if we decide in the MINIMIZED case
814 -- to give up and just generate an overflow check without any fuss.
816 procedure Apply_Arithmetic_Overflow_Strict
(N
: Node_Id
) is
817 Loc
: constant Source_Ptr
:= Sloc
(N
);
818 Typ
: constant Entity_Id
:= Etype
(N
);
819 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
822 -- Nothing to do if Do_Overflow_Check not set or overflow checks
825 if not Do_Overflow_Check
(N
) then
829 -- An interesting special case. If the arithmetic operation appears as
830 -- the operand of a type conversion:
834 -- and all the following conditions apply:
836 -- arithmetic operation is for a signed integer type
837 -- target type type1 is a static integer subtype
838 -- range of x and y are both included in the range of type1
839 -- range of x op y is included in the range of type1
840 -- size of type1 is at least twice the result size of op
842 -- then we don't do an overflow check in any case, instead we transform
843 -- the operation so that we end up with:
845 -- type1 (type1 (x) op type1 (y))
847 -- This avoids intermediate overflow before the conversion. It is
848 -- explicitly permitted by RM 3.5.4(24):
850 -- For the execution of a predefined operation of a signed integer
851 -- type, the implementation need not raise Constraint_Error if the
852 -- result is outside the base range of the type, so long as the
853 -- correct result is produced.
855 -- It's hard to imagine that any programmer counts on the exception
856 -- being raised in this case, and in any case it's wrong coding to
857 -- have this expectation, given the RM permission. Furthermore, other
858 -- Ada compilers do allow such out of range results.
860 -- Note that we do this transformation even if overflow checking is
861 -- off, since this is precisely about giving the "right" result and
862 -- avoiding the need for an overflow check.
864 -- Note: this circuit is partially redundant with respect to the similar
865 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
866 -- with cases that do not come through here. We still need the following
867 -- processing even with the Exp_Ch4 code in place, since we want to be
868 -- sure not to generate the arithmetic overflow check in these cases
869 -- (Exp_Ch4 would have a hard time removing them once generated).
871 if Is_Signed_Integer_Type
(Typ
)
872 and then Nkind
(Parent
(N
)) = N_Type_Conversion
874 Conversion_Optimization
: declare
875 Target_Type
: constant Entity_Id
:=
876 Base_Type
(Entity
(Subtype_Mark
(Parent
(N
))));
890 if Is_Integer_Type
(Target_Type
)
891 and then RM_Size
(Root_Type
(Target_Type
)) >= 2 * RM_Size
(Rtyp
)
893 Tlo
:= Expr_Value
(Type_Low_Bound
(Target_Type
));
894 Thi
:= Expr_Value
(Type_High_Bound
(Target_Type
));
897 (Left_Opnd
(N
), LOK
, Llo
, Lhi
, Assume_Valid
=> True);
899 (Right_Opnd
(N
), ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
902 and then Tlo
<= Llo
and then Lhi
<= Thi
903 and then Tlo
<= Rlo
and then Rhi
<= Thi
905 Determine_Range
(N
, VOK
, Vlo
, Vhi
, Assume_Valid
=> True);
907 if VOK
and then Tlo
<= Vlo
and then Vhi
<= Thi
then
908 Rewrite
(Left_Opnd
(N
),
909 Make_Type_Conversion
(Loc
,
910 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
911 Expression
=> Relocate_Node
(Left_Opnd
(N
))));
913 Rewrite
(Right_Opnd
(N
),
914 Make_Type_Conversion
(Loc
,
915 Subtype_Mark
=> New_Occurrence_Of
(Target_Type
, Loc
),
916 Expression
=> Relocate_Node
(Right_Opnd
(N
))));
918 -- Rewrite the conversion operand so that the original
919 -- node is retained, in order to avoid the warning for
920 -- redundant conversions in Resolve_Type_Conversion.
922 Rewrite
(N
, Relocate_Node
(N
));
924 Set_Etype
(N
, Target_Type
);
926 Analyze_And_Resolve
(Left_Opnd
(N
), Target_Type
);
927 Analyze_And_Resolve
(Right_Opnd
(N
), Target_Type
);
929 -- Given that the target type is twice the size of the
930 -- source type, overflow is now impossible, so we can
931 -- safely kill the overflow check and return.
933 Set_Do_Overflow_Check
(N
, False);
938 end Conversion_Optimization
;
941 -- Now see if an overflow check is required
944 Siz
: constant Int
:= UI_To_Int
(Esize
(Rtyp
));
945 Dsiz
: constant Int
:= Siz
* 2;
952 -- Skip check if back end does overflow checks, or the overflow flag
953 -- is not set anyway, or we are not doing code expansion, or the
954 -- parent node is a type conversion whose operand is an arithmetic
955 -- operation on signed integers on which the expander can promote
956 -- later the operands to type Integer (see Expand_N_Type_Conversion).
958 -- Special case CLI target, where arithmetic overflow checks can be
959 -- performed for integer and long_integer
961 if Backend_Overflow_Checks_On_Target
962 or else not Do_Overflow_Check
(N
)
963 or else not Full_Expander_Active
964 or else (Present
(Parent
(N
))
965 and then Nkind
(Parent
(N
)) = N_Type_Conversion
966 and then Integer_Promotion_Possible
(Parent
(N
)))
968 (VM_Target
= CLI_Target
and then Siz
>= Standard_Integer_Size
)
973 -- Otherwise, generate the full general code for front end overflow
974 -- detection, which works by doing arithmetic in a larger type:
980 -- Typ (Checktyp (x) op Checktyp (y));
982 -- where Typ is the type of the original expression, and Checktyp is
983 -- an integer type of sufficient length to hold the largest possible
986 -- If the size of check type exceeds the size of Long_Long_Integer,
987 -- we use a different approach, expanding to:
989 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
991 -- where xxx is Add, Multiply or Subtract as appropriate
993 -- Find check type if one exists
995 if Dsiz
<= Standard_Integer_Size
then
996 Ctyp
:= Standard_Integer
;
998 elsif Dsiz
<= Standard_Long_Long_Integer_Size
then
999 Ctyp
:= Standard_Long_Long_Integer
;
1001 -- No check type exists, use runtime call
1004 if Nkind
(N
) = N_Op_Add
then
1005 Cent
:= RE_Add_With_Ovflo_Check
;
1007 elsif Nkind
(N
) = N_Op_Multiply
then
1008 Cent
:= RE_Multiply_With_Ovflo_Check
;
1011 pragma Assert
(Nkind
(N
) = N_Op_Subtract
);
1012 Cent
:= RE_Subtract_With_Ovflo_Check
;
1017 Make_Function_Call
(Loc
,
1018 Name
=> New_Reference_To
(RTE
(Cent
), Loc
),
1019 Parameter_Associations
=> New_List
(
1020 OK_Convert_To
(RTE
(RE_Integer_64
), Left_Opnd
(N
)),
1021 OK_Convert_To
(RTE
(RE_Integer_64
), Right_Opnd
(N
))))));
1023 Analyze_And_Resolve
(N
, Typ
);
1027 -- If we fall through, we have the case where we do the arithmetic
1028 -- in the next higher type and get the check by conversion. In these
1029 -- cases Ctyp is set to the type to be used as the check type.
1031 Opnod
:= Relocate_Node
(N
);
1033 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
1036 Set_Etype
(Opnd
, Ctyp
);
1037 Set_Analyzed
(Opnd
, True);
1038 Set_Left_Opnd
(Opnod
, Opnd
);
1040 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
1043 Set_Etype
(Opnd
, Ctyp
);
1044 Set_Analyzed
(Opnd
, True);
1045 Set_Right_Opnd
(Opnod
, Opnd
);
1047 -- The type of the operation changes to the base type of the check
1048 -- type, and we reset the overflow check indication, since clearly no
1049 -- overflow is possible now that we are using a double length type.
1050 -- We also set the Analyzed flag to avoid a recursive attempt to
1053 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
1054 Set_Do_Overflow_Check
(Opnod
, False);
1055 Set_Analyzed
(Opnod
, True);
1057 -- Now build the outer conversion
1059 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
1061 Set_Etype
(Opnd
, Typ
);
1063 -- In the discrete type case, we directly generate the range check
1064 -- for the outer operand. This range check will implement the
1065 -- required overflow check.
1067 if Is_Discrete_Type
(Typ
) then
1069 Generate_Range_Check
1070 (Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
1072 -- For other types, we enable overflow checking on the conversion,
1073 -- after setting the node as analyzed to prevent recursive attempts
1074 -- to expand the conversion node.
1077 Set_Analyzed
(Opnd
, True);
1078 Enable_Overflow_Check
(Opnd
);
1083 when RE_Not_Available
=>
1086 end Apply_Arithmetic_Overflow_Strict
;
1088 ----------------------------------------------------
1089 -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
1090 ----------------------------------------------------
1092 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated
(Op
: Node_Id
) is
1093 pragma Assert
(Is_Signed_Integer_Arithmetic_Op
(Op
));
1095 Loc
: constant Source_Ptr
:= Sloc
(Op
);
1096 P
: constant Node_Id
:= Parent
(Op
);
1098 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
1099 -- Operands and results are of this type when we convert
1101 Result_Type
: constant Entity_Id
:= Etype
(Op
);
1102 -- Original result type
1104 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1105 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
1108 -- Ranges of values for result
1111 -- Nothing to do if our parent is one of the following:
1113 -- Another signed integer arithmetic op
1114 -- A membership operation
1115 -- A comparison operation
1117 -- In all these cases, we will process at the higher level (and then
1118 -- this node will be processed during the downwards recursion that
1119 -- is part of the processing in Minimize_Eliminate_Overflows).
1121 if Is_Signed_Integer_Arithmetic_Op
(P
)
1122 or else Nkind
(P
) in N_Membership_Test
1123 or else Nkind
(P
) in N_Op_Compare
1125 -- This is also true for an alternative in a case expression
1127 or else Nkind
(P
) = N_Case_Expression_Alternative
1129 -- This is also true for a range operand in a membership test
1131 or else (Nkind
(P
) = N_Range
1132 and then Nkind
(Parent
(P
)) in N_Membership_Test
)
1137 -- Otherwise, we have a top level arithmetic operation node, and this
1138 -- is where we commence the special processing for MINIMIZED/ELIMINATED
1139 -- modes. This is the case where we tell the machinery not to move into
1140 -- Bignum mode at this top level (of course the top level operation
1141 -- will still be in Bignum mode if either of its operands are of type
1144 Minimize_Eliminate_Overflows
(Op
, Lo
, Hi
, Top_Level
=> True);
1146 -- That call may but does not necessarily change the result type of Op.
1147 -- It is the job of this routine to undo such changes, so that at the
1148 -- top level, we have the proper type. This "undoing" is a point at
1149 -- which a final overflow check may be applied.
1151 -- If the result type was not fiddled we are all set. We go to base
1152 -- types here because things may have been rewritten to generate the
1153 -- base type of the operand types.
1155 if Base_Type
(Etype
(Op
)) = Base_Type
(Result_Type
) then
1160 elsif Is_RTE
(Etype
(Op
), RE_Bignum
) then
1162 -- We need a sequence that looks like:
1164 -- Rnn : Result_Type;
1167 -- M : Mark_Id := SS_Mark;
1169 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
1173 -- This block is inserted (using Insert_Actions), and then the node
1174 -- is replaced with a reference to Rnn.
1176 -- A special case arises if our parent is a conversion node. In this
1177 -- case no point in generating a conversion to Result_Type, we will
1178 -- let the parent handle this. Note that this special case is not
1179 -- just about optimization. Consider
1183 -- X := Long_Long_Integer'Base (A * (B ** C));
1185 -- Now the product may fit in Long_Long_Integer but not in Integer.
1186 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
1187 -- overflow exception for this intermediate value.
1190 Blk
: constant Node_Id
:= Make_Bignum_Block
(Loc
);
1191 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R', Op
);
1197 RHS
:= Convert_From_Bignum
(Op
);
1199 if Nkind
(P
) /= N_Type_Conversion
then
1200 Convert_To_And_Rewrite
(Result_Type
, RHS
);
1201 Rtype
:= Result_Type
;
1203 -- Interesting question, do we need a check on that conversion
1204 -- operation. Answer, not if we know the result is in range.
1205 -- At the moment we are not taking advantage of this. To be
1206 -- looked at later ???
1213 (First
(Statements
(Handled_Statement_Sequence
(Blk
))),
1214 Make_Assignment_Statement
(Loc
,
1215 Name
=> New_Occurrence_Of
(Rnn
, Loc
),
1216 Expression
=> RHS
));
1218 Insert_Actions
(Op
, New_List
(
1219 Make_Object_Declaration
(Loc
,
1220 Defining_Identifier
=> Rnn
,
1221 Object_Definition
=> New_Occurrence_Of
(Rtype
, Loc
)),
1224 Rewrite
(Op
, New_Occurrence_Of
(Rnn
, Loc
));
1225 Analyze_And_Resolve
(Op
);
1228 -- Here we know the result is Long_Long_Integer'Base, of that it has
1229 -- been rewritten because the parent operation is a conversion. See
1230 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
1234 (Etype
(Op
) = LLIB
or else Nkind
(Parent
(Op
)) = N_Type_Conversion
);
1236 -- All we need to do here is to convert the result to the proper
1237 -- result type. As explained above for the Bignum case, we can
1238 -- omit this if our parent is a type conversion.
1240 if Nkind
(P
) /= N_Type_Conversion
then
1241 Convert_To_And_Rewrite
(Result_Type
, Op
);
1244 Analyze_And_Resolve
(Op
);
1246 end Apply_Arithmetic_Overflow_Minimized_Eliminated
;
1248 ----------------------------
1249 -- Apply_Constraint_Check --
1250 ----------------------------
1252 procedure Apply_Constraint_Check
1255 No_Sliding
: Boolean := False)
1257 Desig_Typ
: Entity_Id
;
1260 -- No checks inside a generic (check the instantiations)
1262 if Inside_A_Generic
then
1266 -- Apply required constraint checks
1268 if Is_Scalar_Type
(Typ
) then
1269 Apply_Scalar_Range_Check
(N
, Typ
);
1271 elsif Is_Array_Type
(Typ
) then
1273 -- A useful optimization: an aggregate with only an others clause
1274 -- always has the right bounds.
1276 if Nkind
(N
) = N_Aggregate
1277 and then No
(Expressions
(N
))
1279 (First
(Choices
(First
(Component_Associations
(N
)))))
1285 if Is_Constrained
(Typ
) then
1286 Apply_Length_Check
(N
, Typ
);
1289 Apply_Range_Check
(N
, Typ
);
1292 Apply_Range_Check
(N
, Typ
);
1295 elsif (Is_Record_Type
(Typ
) or else Is_Private_Type
(Typ
))
1296 and then Has_Discriminants
(Base_Type
(Typ
))
1297 and then Is_Constrained
(Typ
)
1299 Apply_Discriminant_Check
(N
, Typ
);
1301 elsif Is_Access_Type
(Typ
) then
1303 Desig_Typ
:= Designated_Type
(Typ
);
1305 -- No checks necessary if expression statically null
1307 if Known_Null
(N
) then
1308 if Can_Never_Be_Null
(Typ
) then
1309 Install_Null_Excluding_Check
(N
);
1312 -- No sliding possible on access to arrays
1314 elsif Is_Array_Type
(Desig_Typ
) then
1315 if Is_Constrained
(Desig_Typ
) then
1316 Apply_Length_Check
(N
, Typ
);
1319 Apply_Range_Check
(N
, Typ
);
1321 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
1322 and then Is_Constrained
(Desig_Typ
)
1324 Apply_Discriminant_Check
(N
, Typ
);
1327 -- Apply the 2005 Null_Excluding check. Note that we do not apply
1328 -- this check if the constraint node is illegal, as shown by having
1329 -- an error posted. This additional guard prevents cascaded errors
1330 -- and compiler aborts on illegal programs involving Ada 2005 checks.
1332 if Can_Never_Be_Null
(Typ
)
1333 and then not Can_Never_Be_Null
(Etype
(N
))
1334 and then not Error_Posted
(N
)
1336 Install_Null_Excluding_Check
(N
);
1339 end Apply_Constraint_Check
;
1341 ------------------------------
1342 -- Apply_Discriminant_Check --
1343 ------------------------------
1345 procedure Apply_Discriminant_Check
1348 Lhs
: Node_Id
:= Empty
)
1350 Loc
: constant Source_Ptr
:= Sloc
(N
);
1351 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1352 S_Typ
: Entity_Id
:= Etype
(N
);
1356 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean;
1357 -- A heap object with an indefinite subtype is constrained by its
1358 -- initial value, and assigning to it requires a constraint_check.
1359 -- The target may be an explicit dereference, or a renaming of one.
1361 function Is_Aliased_Unconstrained_Component
return Boolean;
1362 -- It is possible for an aliased component to have a nominal
1363 -- unconstrained subtype (through instantiation). If this is a
1364 -- discriminated component assigned in the expansion of an aggregate
1365 -- in an initialization, the check must be suppressed. This unusual
1366 -- situation requires a predicate of its own.
1368 ----------------------------------
1369 -- Denotes_Explicit_Dereference --
1370 ----------------------------------
1372 function Denotes_Explicit_Dereference
(Obj
: Node_Id
) return Boolean is
1375 Nkind
(Obj
) = N_Explicit_Dereference
1377 (Is_Entity_Name
(Obj
)
1378 and then Present
(Renamed_Object
(Entity
(Obj
)))
1379 and then Nkind
(Renamed_Object
(Entity
(Obj
))) =
1380 N_Explicit_Dereference
);
1381 end Denotes_Explicit_Dereference
;
1383 ----------------------------------------
1384 -- Is_Aliased_Unconstrained_Component --
1385 ----------------------------------------
1387 function Is_Aliased_Unconstrained_Component
return Boolean is
1392 if Nkind
(Lhs
) /= N_Selected_Component
then
1395 Comp
:= Entity
(Selector_Name
(Lhs
));
1396 Pref
:= Prefix
(Lhs
);
1399 if Ekind
(Comp
) /= E_Component
1400 or else not Is_Aliased
(Comp
)
1405 return not Comes_From_Source
(Pref
)
1406 and then In_Instance
1407 and then not Is_Constrained
(Etype
(Comp
));
1408 end Is_Aliased_Unconstrained_Component
;
1410 -- Start of processing for Apply_Discriminant_Check
1414 T_Typ
:= Designated_Type
(Typ
);
1419 -- Nothing to do if discriminant checks are suppressed or else no code
1420 -- is to be generated
1422 if not Full_Expander_Active
1423 or else Discriminant_Checks_Suppressed
(T_Typ
)
1428 -- No discriminant checks necessary for an access when expression is
1429 -- statically Null. This is not only an optimization, it is fundamental
1430 -- because otherwise discriminant checks may be generated in init procs
1431 -- for types containing an access to a not-yet-frozen record, causing a
1432 -- deadly forward reference.
1434 -- Also, if the expression is of an access type whose designated type is
1435 -- incomplete, then the access value must be null and we suppress the
1438 if Known_Null
(N
) then
1441 elsif Is_Access_Type
(S_Typ
) then
1442 S_Typ
:= Designated_Type
(S_Typ
);
1444 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1449 -- If an assignment target is present, then we need to generate the
1450 -- actual subtype if the target is a parameter or aliased object with
1451 -- an unconstrained nominal subtype.
1453 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
1454 -- subtype to the parameter and dereference cases, since other aliased
1455 -- objects are unconstrained (unless the nominal subtype is explicitly
1459 and then (Present
(Param_Entity
(Lhs
))
1460 or else (Ada_Version
< Ada_2005
1461 and then not Is_Constrained
(T_Typ
)
1462 and then Is_Aliased_View
(Lhs
)
1463 and then not Is_Aliased_Unconstrained_Component
)
1464 or else (Ada_Version
>= Ada_2005
1465 and then not Is_Constrained
(T_Typ
)
1466 and then Denotes_Explicit_Dereference
(Lhs
)
1467 and then Nkind
(Original_Node
(Lhs
)) /=
1470 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1473 -- Nothing to do if the type is unconstrained (this is the case where
1474 -- the actual subtype in the RM sense of N is unconstrained and no check
1477 if not Is_Constrained
(T_Typ
) then
1480 -- Ada 2005: nothing to do if the type is one for which there is a
1481 -- partial view that is constrained.
1483 elsif Ada_Version
>= Ada_2005
1484 and then Object_Type_Has_Constrained_Partial_View
1485 (Typ
=> Base_Type
(T_Typ
),
1486 Scop
=> Current_Scope
)
1491 -- Nothing to do if the type is an Unchecked_Union
1493 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
1497 -- Suppress checks if the subtypes are the same. the check must be
1498 -- preserved in an assignment to a formal, because the constraint is
1499 -- given by the actual.
1501 if Nkind
(Original_Node
(N
)) /= N_Allocator
1503 or else not Is_Entity_Name
(Lhs
)
1504 or else No
(Param_Entity
(Lhs
)))
1507 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1508 and then not Is_Aliased_View
(Lhs
)
1513 -- We can also eliminate checks on allocators with a subtype mark that
1514 -- coincides with the context type. The context type may be a subtype
1515 -- without a constraint (common case, a generic actual).
1517 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1518 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1521 Alloc_Typ
: constant Entity_Id
:=
1522 Entity
(Expression
(Original_Node
(N
)));
1525 if Alloc_Typ
= T_Typ
1526 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1527 and then Is_Entity_Name
(
1528 Subtype_Indication
(Parent
(T_Typ
)))
1529 and then Alloc_Typ
= Base_Type
(T_Typ
))
1537 -- See if we have a case where the types are both constrained, and all
1538 -- the constraints are constants. In this case, we can do the check
1539 -- successfully at compile time.
1541 -- We skip this check for the case where the node is rewritten`as
1542 -- an allocator, because it already carries the context subtype,
1543 -- and extracting the discriminants from the aggregate is messy.
1545 if Is_Constrained
(S_Typ
)
1546 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1556 -- S_Typ may not have discriminants in the case where it is a
1557 -- private type completed by a default discriminated type. In that
1558 -- case, we need to get the constraints from the underlying_type.
1559 -- If the underlying type is unconstrained (i.e. has no default
1560 -- discriminants) no check is needed.
1562 if Has_Discriminants
(S_Typ
) then
1563 Discr
:= First_Discriminant
(S_Typ
);
1564 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1567 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1570 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1576 -- A further optimization: if T_Typ is derived from S_Typ
1577 -- without imposing a constraint, no check is needed.
1579 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1580 N_Full_Type_Declaration
1583 Type_Def
: constant Node_Id
:=
1584 Type_Definition
(Original_Node
(Parent
(T_Typ
)));
1586 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1587 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1588 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1596 -- Constraint may appear in full view of type
1598 if Ekind
(T_Typ
) = E_Private_Subtype
1599 and then Present
(Full_View
(T_Typ
))
1602 First_Elmt
(Discriminant_Constraint
(Full_View
(T_Typ
)));
1605 First_Elmt
(Discriminant_Constraint
(T_Typ
));
1608 while Present
(Discr
) loop
1609 ItemS
:= Node
(DconS
);
1610 ItemT
:= Node
(DconT
);
1612 -- For a discriminated component type constrained by the
1613 -- current instance of an enclosing type, there is no
1614 -- applicable discriminant check.
1616 if Nkind
(ItemT
) = N_Attribute_Reference
1617 and then Is_Access_Type
(Etype
(ItemT
))
1618 and then Is_Entity_Name
(Prefix
(ItemT
))
1619 and then Is_Type
(Entity
(Prefix
(ItemT
)))
1624 -- If the expressions for the discriminants are identical
1625 -- and it is side-effect free (for now just an entity),
1626 -- this may be a shared constraint, e.g. from a subtype
1627 -- without a constraint introduced as a generic actual.
1628 -- Examine other discriminants if any.
1631 and then Is_Entity_Name
(ItemS
)
1635 elsif not Is_OK_Static_Expression
(ItemS
)
1636 or else not Is_OK_Static_Expression
(ItemT
)
1640 elsif Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1641 if Do_Access
then -- needs run-time check.
1644 Apply_Compile_Time_Constraint_Error
1645 (N
, "incorrect value for discriminant&??",
1646 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1653 Next_Discriminant
(Discr
);
1662 -- Here we need a discriminant check. First build the expression
1663 -- for the comparisons of the discriminants:
1665 -- (n.disc1 /= typ.disc1) or else
1666 -- (n.disc2 /= typ.disc2) or else
1668 -- (n.discn /= typ.discn)
1670 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1672 -- If Lhs is set and is a parameter, then the condition is guarded by:
1673 -- lhs'constrained and then (condition built above)
1675 if Present
(Param_Entity
(Lhs
)) then
1679 Make_Attribute_Reference
(Loc
,
1680 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1681 Attribute_Name
=> Name_Constrained
),
1682 Right_Opnd
=> Cond
);
1686 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1690 Make_Raise_Constraint_Error
(Loc
,
1692 Reason
=> CE_Discriminant_Check_Failed
));
1693 end Apply_Discriminant_Check
;
1695 -------------------------
1696 -- Apply_Divide_Checks --
1697 -------------------------
1699 procedure Apply_Divide_Checks
(N
: Node_Id
) is
1700 Loc
: constant Source_Ptr
:= Sloc
(N
);
1701 Typ
: constant Entity_Id
:= Etype
(N
);
1702 Left
: constant Node_Id
:= Left_Opnd
(N
);
1703 Right
: constant Node_Id
:= Right_Opnd
(N
);
1705 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
1706 -- Current overflow checking mode
1716 pragma Warnings
(Off
, Lhi
);
1717 -- Don't actually use this value
1720 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
1721 -- operating on signed integer types, then the only thing this routine
1722 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
1723 -- procedure will (possibly later on during recursive downward calls),
1724 -- ensure that any needed overflow/division checks are properly applied.
1726 if Mode
in Minimized_Or_Eliminated
1727 and then Is_Signed_Integer_Type
(Typ
)
1729 Apply_Arithmetic_Overflow_Minimized_Eliminated
(N
);
1733 -- Proceed here in SUPPRESSED or CHECKED modes
1735 if Full_Expander_Active
1736 and then not Backend_Divide_Checks_On_Target
1737 and then Check_Needed
(Right
, Division_Check
)
1739 Determine_Range
(Right
, ROK
, Rlo
, Rhi
, Assume_Valid
=> True);
1741 -- Deal with division check
1743 if Do_Division_Check
(N
)
1744 and then not Division_Checks_Suppressed
(Typ
)
1746 Apply_Division_Check
(N
, Rlo
, Rhi
, ROK
);
1749 -- Deal with overflow check
1751 if Do_Overflow_Check
(N
)
1752 and then not Overflow_Checks_Suppressed
(Etype
(N
))
1755 -- Test for extremely annoying case of xxx'First divided by -1
1756 -- for division of signed integer types (only overflow case).
1758 if Nkind
(N
) = N_Op_Divide
1759 and then Is_Signed_Integer_Type
(Typ
)
1761 Determine_Range
(Left
, LOK
, Llo
, Lhi
, Assume_Valid
=> True);
1762 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1764 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1766 ((not LOK
) or else (Llo
= LLB
))
1769 Make_Raise_Constraint_Error
(Loc
,
1775 Duplicate_Subexpr_Move_Checks
(Left
),
1776 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1780 Left_Opnd
=> Duplicate_Subexpr
(Right
),
1781 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1))),
1783 Reason
=> CE_Overflow_Check_Failed
));
1788 end Apply_Divide_Checks
;
1790 --------------------------
1791 -- Apply_Division_Check --
1792 --------------------------
1794 procedure Apply_Division_Check
1800 pragma Assert
(Do_Division_Check
(N
));
1802 Loc
: constant Source_Ptr
:= Sloc
(N
);
1803 Right
: constant Node_Id
:= Right_Opnd
(N
);
1806 if Full_Expander_Active
1807 and then not Backend_Divide_Checks_On_Target
1808 and then Check_Needed
(Right
, Division_Check
)
1810 -- See if division by zero possible, and if so generate test. This
1811 -- part of the test is not controlled by the -gnato switch, since
1812 -- it is a Division_Check and not an Overflow_Check.
1814 if Do_Division_Check
(N
) then
1815 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1817 Make_Raise_Constraint_Error
(Loc
,
1820 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1821 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1822 Reason
=> CE_Divide_By_Zero
));
1826 end Apply_Division_Check
;
1828 ----------------------------------
1829 -- Apply_Float_Conversion_Check --
1830 ----------------------------------
1832 -- Let F and I be the source and target types of the conversion. The RM
1833 -- specifies that a floating-point value X is rounded to the nearest
1834 -- integer, with halfway cases being rounded away from zero. The rounded
1835 -- value of X is checked against I'Range.
1837 -- The catch in the above paragraph is that there is no good way to know
1838 -- whether the round-to-integer operation resulted in overflow. A remedy is
1839 -- to perform a range check in the floating-point domain instead, however:
1841 -- (1) The bounds may not be known at compile time
1842 -- (2) The check must take into account rounding or truncation.
1843 -- (3) The range of type I may not be exactly representable in F.
1844 -- (4) For the rounding case, The end-points I'First - 0.5 and
1845 -- I'Last + 0.5 may or may not be in range, depending on the
1846 -- sign of I'First and I'Last.
1847 -- (5) X may be a NaN, which will fail any comparison
1849 -- The following steps correctly convert X with rounding:
1851 -- (1) If either I'First or I'Last is not known at compile time, use
1852 -- I'Base instead of I in the next three steps and perform a
1853 -- regular range check against I'Range after conversion.
1854 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1855 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1856 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
1857 -- In other words, take one of the closest floating-point numbers
1858 -- (which is an integer value) to I'First, and see if it is in
1860 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1861 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1862 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
1863 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1864 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1866 -- For the truncating case, replace steps (2) and (3) as follows:
1867 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
1868 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
1870 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
1871 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
1874 procedure Apply_Float_Conversion_Check
1876 Target_Typ
: Entity_Id
)
1878 LB
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1879 HB
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1880 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1881 Expr_Type
: constant Entity_Id
:= Base_Type
(Etype
(Ck_Node
));
1882 Target_Base
: constant Entity_Id
:=
1883 Implementation_Base_Type
(Target_Typ
);
1885 Par
: constant Node_Id
:= Parent
(Ck_Node
);
1886 pragma Assert
(Nkind
(Par
) = N_Type_Conversion
);
1887 -- Parent of check node, must be a type conversion
1889 Truncate
: constant Boolean := Float_Truncate
(Par
);
1890 Max_Bound
: constant Uint
:=
1892 (Machine_Radix_Value
(Expr_Type
),
1893 Machine_Mantissa_Value
(Expr_Type
) - 1) - 1;
1895 -- Largest bound, so bound plus or minus half is a machine number of F
1897 Ifirst
, Ilast
: Uint
;
1898 -- Bounds of integer type
1901 -- Bounds to check in floating-point domain
1903 Lo_OK
, Hi_OK
: Boolean;
1904 -- True iff Lo resp. Hi belongs to I'Range
1906 Lo_Chk
, Hi_Chk
: Node_Id
;
1907 -- Expressions that are False iff check fails
1909 Reason
: RT_Exception_Code
;
1912 -- We do not need checks if we are not generating code (i.e. the full
1913 -- expander is not active). In SPARK mode, we specifically don't want
1914 -- the frontend to expand these checks, which are dealt with directly
1915 -- in the formal verification backend.
1917 if not Full_Expander_Active
then
1921 if not Compile_Time_Known_Value
(LB
)
1922 or not Compile_Time_Known_Value
(HB
)
1925 -- First check that the value falls in the range of the base type,
1926 -- to prevent overflow during conversion and then perform a
1927 -- regular range check against the (dynamic) bounds.
1929 pragma Assert
(Target_Base
/= Target_Typ
);
1931 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Par
);
1934 Apply_Float_Conversion_Check
(Ck_Node
, Target_Base
);
1935 Set_Etype
(Temp
, Target_Base
);
1937 Insert_Action
(Parent
(Par
),
1938 Make_Object_Declaration
(Loc
,
1939 Defining_Identifier
=> Temp
,
1940 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
),
1941 Expression
=> New_Copy_Tree
(Par
)),
1942 Suppress
=> All_Checks
);
1945 Make_Raise_Constraint_Error
(Loc
,
1948 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
1949 Right_Opnd
=> New_Occurrence_Of
(Target_Typ
, Loc
)),
1950 Reason
=> CE_Range_Check_Failed
));
1951 Rewrite
(Par
, New_Occurrence_Of
(Temp
, Loc
));
1957 -- Get the (static) bounds of the target type
1959 Ifirst
:= Expr_Value
(LB
);
1960 Ilast
:= Expr_Value
(HB
);
1962 -- A simple optimization: if the expression is a universal literal,
1963 -- we can do the comparison with the bounds and the conversion to
1964 -- an integer type statically. The range checks are unchanged.
1966 if Nkind
(Ck_Node
) = N_Real_Literal
1967 and then Etype
(Ck_Node
) = Universal_Real
1968 and then Is_Integer_Type
(Target_Typ
)
1969 and then Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
1972 Int_Val
: constant Uint
:= UR_To_Uint
(Realval
(Ck_Node
));
1975 if Int_Val
<= Ilast
and then Int_Val
>= Ifirst
then
1977 -- Conversion is safe
1979 Rewrite
(Parent
(Ck_Node
),
1980 Make_Integer_Literal
(Loc
, UI_To_Int
(Int_Val
)));
1981 Analyze_And_Resolve
(Parent
(Ck_Node
), Target_Typ
);
1987 -- Check against lower bound
1989 if Truncate
and then Ifirst
> 0 then
1990 Lo
:= Pred
(Expr_Type
, UR_From_Uint
(Ifirst
));
1994 Lo
:= Succ
(Expr_Type
, UR_From_Uint
(Ifirst
- 1));
1997 elsif abs (Ifirst
) < Max_Bound
then
1998 Lo
:= UR_From_Uint
(Ifirst
) - Ureal_Half
;
1999 Lo_OK
:= (Ifirst
> 0);
2002 Lo
:= Machine
(Expr_Type
, UR_From_Uint
(Ifirst
), Round_Even
, Ck_Node
);
2003 Lo_OK
:= (Lo
>= UR_From_Uint
(Ifirst
));
2008 -- Lo_Chk := (X >= Lo)
2010 Lo_Chk
:= Make_Op_Ge
(Loc
,
2011 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2012 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2015 -- Lo_Chk := (X > Lo)
2017 Lo_Chk
:= Make_Op_Gt
(Loc
,
2018 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2019 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
2022 -- Check against higher bound
2024 if Truncate
and then Ilast
< 0 then
2025 Hi
:= Succ
(Expr_Type
, UR_From_Uint
(Ilast
));
2029 Hi
:= Pred
(Expr_Type
, UR_From_Uint
(Ilast
+ 1));
2032 elsif abs (Ilast
) < Max_Bound
then
2033 Hi
:= UR_From_Uint
(Ilast
) + Ureal_Half
;
2034 Hi_OK
:= (Ilast
< 0);
2036 Hi
:= Machine
(Expr_Type
, UR_From_Uint
(Ilast
), Round_Even
, Ck_Node
);
2037 Hi_OK
:= (Hi
<= UR_From_Uint
(Ilast
));
2042 -- Hi_Chk := (X <= Hi)
2044 Hi_Chk
:= Make_Op_Le
(Loc
,
2045 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2046 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2049 -- Hi_Chk := (X < Hi)
2051 Hi_Chk
:= Make_Op_Lt
(Loc
,
2052 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
2053 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
2056 -- If the bounds of the target type are the same as those of the base
2057 -- type, the check is an overflow check as a range check is not
2058 -- performed in these cases.
2060 if Expr_Value
(Type_Low_Bound
(Target_Base
)) = Ifirst
2061 and then Expr_Value
(Type_High_Bound
(Target_Base
)) = Ilast
2063 Reason
:= CE_Overflow_Check_Failed
;
2065 Reason
:= CE_Range_Check_Failed
;
2068 -- Raise CE if either conditions does not hold
2070 Insert_Action
(Ck_Node
,
2071 Make_Raise_Constraint_Error
(Loc
,
2072 Condition
=> Make_Op_Not
(Loc
, Make_And_Then
(Loc
, Lo_Chk
, Hi_Chk
)),
2074 end Apply_Float_Conversion_Check
;
2076 ------------------------
2077 -- Apply_Length_Check --
2078 ------------------------
2080 procedure Apply_Length_Check
2082 Target_Typ
: Entity_Id
;
2083 Source_Typ
: Entity_Id
:= Empty
)
2086 Apply_Selected_Length_Checks
2087 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2088 end Apply_Length_Check
;
2090 -------------------------------------
2091 -- Apply_Parameter_Aliasing_Checks --
2092 -------------------------------------
2094 procedure Apply_Parameter_Aliasing_Checks
2098 Loc
: constant Source_Ptr
:= Sloc
(Call
);
2100 function May_Cause_Aliasing
2101 (Formal_1
: Entity_Id
;
2102 Formal_2
: Entity_Id
) return Boolean;
2103 -- Determine whether two formal parameters can alias each other
2104 -- depending on their modes.
2106 function Original_Actual
(N
: Node_Id
) return Node_Id
;
2107 -- The expander may replace an actual with a temporary for the sake of
2108 -- side effect removal. The temporary may hide a potential aliasing as
2109 -- it does not share the address of the actual. This routine attempts
2110 -- to retrieve the original actual.
2112 procedure Overlap_Check
2113 (Actual_1
: Node_Id
;
2115 Formal_1
: Entity_Id
;
2116 Formal_2
: Entity_Id
;
2117 Check
: in out Node_Id
);
2118 -- Create a check to determine whether Actual_1 overlaps with Actual_2.
2119 -- If detailed exception messages are enabled, the check is augmented to
2120 -- provide information about the names of the corresponding formals. See
2121 -- the body for details. Actual_1 and Actual_2 denote the two actuals to
2122 -- be tested. Formal_1 and Formal_2 denote the corresponding formals.
2123 -- Check contains all and-ed simple tests generated so far or remains
2124 -- unchanged in the case of detailed exception messaged.
2126 ------------------------
2127 -- May_Cause_Aliasing --
2128 ------------------------
2130 function May_Cause_Aliasing
2131 (Formal_1
: Entity_Id
;
2132 Formal_2
: Entity_Id
) return Boolean
2135 -- The following combination cannot lead to aliasing
2137 -- Formal 1 Formal 2
2140 if Ekind
(Formal_1
) = E_In_Parameter
2142 Ekind
(Formal_2
) = E_In_Parameter
2146 -- The following combinations may lead to aliasing
2148 -- Formal 1 Formal 2
2158 end May_Cause_Aliasing
;
2160 ---------------------
2161 -- Original_Actual --
2162 ---------------------
2164 function Original_Actual
(N
: Node_Id
) return Node_Id
is
2166 if Nkind
(N
) = N_Type_Conversion
then
2167 return Expression
(N
);
2169 -- The expander created a temporary to capture the result of a type
2170 -- conversion where the expression is the real actual.
2172 elsif Nkind
(N
) = N_Identifier
2173 and then Present
(Original_Node
(N
))
2174 and then Nkind
(Original_Node
(N
)) = N_Type_Conversion
2176 return Expression
(Original_Node
(N
));
2180 end Original_Actual
;
2186 procedure Overlap_Check
2187 (Actual_1
: Node_Id
;
2189 Formal_1
: Entity_Id
;
2190 Formal_2
: Entity_Id
;
2191 Check
: in out Node_Id
)
2194 ID_Casing
: constant Casing_Type
:=
2195 Identifier_Casing
(Source_Index
(Current_Sem_Unit
));
2199 -- Actual_1'Overlaps_Storage (Actual_2)
2202 Make_Attribute_Reference
(Loc
,
2203 Prefix
=> New_Copy_Tree
(Original_Actual
(Actual_1
)),
2204 Attribute_Name
=> Name_Overlaps_Storage
,
2206 New_List
(New_Copy_Tree
(Original_Actual
(Actual_2
))));
2208 -- Generate the following check when detailed exception messages are
2211 -- if Actual_1'Overlaps_Storage (Actual_2) then
2212 -- raise Program_Error with <detailed message>;
2215 if Exception_Extra_Info
then
2218 -- Do not generate location information for internal calls
2220 if Comes_From_Source
(Call
) then
2221 Store_String_Chars
(Build_Location_String
(Loc
));
2222 Store_String_Char
(' ');
2225 Store_String_Chars
("aliased parameters, actuals for """);
2227 Get_Name_String
(Chars
(Formal_1
));
2228 Set_Casing
(ID_Casing
);
2229 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2231 Store_String_Chars
(""" and """);
2233 Get_Name_String
(Chars
(Formal_2
));
2234 Set_Casing
(ID_Casing
);
2235 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2237 Store_String_Chars
(""" overlap");
2239 Insert_Action
(Call
,
2240 Make_If_Statement
(Loc
,
2242 Then_Statements
=> New_List
(
2243 Make_Raise_Statement
(Loc
,
2245 New_Reference_To
(Standard_Program_Error
, Loc
),
2246 Expression
=> Make_String_Literal
(Loc
, End_String
)))));
2248 -- Create a sequence of overlapping checks by and-ing them all
2258 Right_Opnd
=> Cond
);
2268 Formal_1
: Entity_Id
;
2269 Formal_2
: Entity_Id
;
2271 -- Start of processing for Apply_Parameter_Aliasing_Checks
2276 Actual_1
:= First_Actual
(Call
);
2277 Formal_1
:= First_Formal
(Subp
);
2278 while Present
(Actual_1
) and then Present
(Formal_1
) loop
2280 -- Ensure that the actual is an object that is not passed by value.
2281 -- Elementary types are always passed by value, therefore actuals of
2282 -- such types cannot lead to aliasing.
2284 if Is_Object_Reference
(Original_Actual
(Actual_1
))
2285 and then not Is_Elementary_Type
(Etype
(Original_Actual
(Actual_1
)))
2287 Actual_2
:= Next_Actual
(Actual_1
);
2288 Formal_2
:= Next_Formal
(Formal_1
);
2289 while Present
(Actual_2
) and then Present
(Formal_2
) loop
2291 -- The other actual we are testing against must also denote
2292 -- a non pass-by-value object. Generate the check only when
2293 -- the mode of the two formals may lead to aliasing.
2295 if Is_Object_Reference
(Original_Actual
(Actual_2
))
2297 Is_Elementary_Type
(Etype
(Original_Actual
(Actual_2
)))
2298 and then May_Cause_Aliasing
(Formal_1
, Formal_2
)
2301 (Actual_1
=> Actual_1
,
2302 Actual_2
=> Actual_2
,
2303 Formal_1
=> Formal_1
,
2304 Formal_2
=> Formal_2
,
2308 Next_Actual
(Actual_2
);
2309 Next_Formal
(Formal_2
);
2313 Next_Actual
(Actual_1
);
2314 Next_Formal
(Formal_1
);
2317 -- Place a simple check right before the call
2319 if Present
(Check
) and then not Exception_Extra_Info
then
2320 Insert_Action
(Call
,
2321 Make_Raise_Program_Error
(Loc
,
2323 Reason
=> PE_Aliased_Parameters
));
2325 end Apply_Parameter_Aliasing_Checks
;
2327 -------------------------------------
2328 -- Apply_Parameter_Validity_Checks --
2329 -------------------------------------
2331 procedure Apply_Parameter_Validity_Checks
(Subp
: Entity_Id
) is
2332 Subp_Decl
: Node_Id
;
2334 procedure Add_Validity_Check
2335 (Context
: Entity_Id
;
2337 For_Result
: Boolean := False);
2338 -- Add a single 'Valid[_Scalar] check which verifies the initialization
2339 -- of Context. PPC_Nam denotes the pre or post condition pragma name.
2340 -- Set flag For_Result when to verify the result of a function.
2342 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
);
2343 -- Create a pre or post condition pragma with name PPC_Nam which
2344 -- tests expression Check.
2346 ------------------------
2347 -- Add_Validity_Check --
2348 ------------------------
2350 procedure Add_Validity_Check
2351 (Context
: Entity_Id
;
2353 For_Result
: Boolean := False)
2355 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2356 Typ
: constant Entity_Id
:= Etype
(Context
);
2361 -- Pick the proper version of 'Valid depending on the type of the
2362 -- context. If the context is not eligible for such a check, return.
2364 if Is_Scalar_Type
(Typ
) then
2366 elsif not No_Scalar_Parts
(Typ
) then
2367 Nam
:= Name_Valid_Scalars
;
2372 -- Step 1: Create the expression to verify the validity of the
2375 Check
:= New_Reference_To
(Context
, Loc
);
2377 -- When processing a function result, use 'Result. Generate
2382 Make_Attribute_Reference
(Loc
,
2384 Attribute_Name
=> Name_Result
);
2388 -- Context['Result]'Valid[_Scalars]
2391 Make_Attribute_Reference
(Loc
,
2393 Attribute_Name
=> Nam
);
2395 -- Step 2: Create a pre or post condition pragma
2397 Build_PPC_Pragma
(PPC_Nam
, Check
);
2398 end Add_Validity_Check
;
2400 ----------------------
2401 -- Build_PPC_Pragma --
2402 ----------------------
2404 procedure Build_PPC_Pragma
(PPC_Nam
: Name_Id
; Check
: Node_Id
) is
2405 Loc
: constant Source_Ptr
:= Sloc
(Subp
);
2412 Pragma_Identifier
=> Make_Identifier
(Loc
, PPC_Nam
),
2413 Pragma_Argument_Associations
=> New_List
(
2414 Make_Pragma_Argument_Association
(Loc
,
2415 Chars
=> Name_Check
,
2416 Expression
=> Check
)));
2418 -- Add a message unless exception messages are suppressed
2420 if not Exception_Locations_Suppressed
then
2421 Append_To
(Pragma_Argument_Associations
(Prag
),
2422 Make_Pragma_Argument_Association
(Loc
,
2423 Chars
=> Name_Message
,
2425 Make_String_Literal
(Loc
,
2426 Strval
=> "failed " & Get_Name_String
(PPC_Nam
) &
2427 " from " & Build_Location_String
(Loc
))));
2430 -- Insert the pragma in the tree
2432 if Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
then
2433 Add_Global_Declaration
(Prag
);
2436 -- PPC pragmas associated with subprogram bodies must be inserted in
2437 -- the declarative part of the body.
2439 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
then
2440 Decls
:= Declarations
(Subp_Decl
);
2444 Set_Declarations
(Subp_Decl
, Decls
);
2447 Prepend_To
(Decls
, Prag
);
2449 -- Ensure the proper visibility of the subprogram body and its
2456 -- For subprogram declarations insert the PPC pragma right after the
2457 -- declarative node.
2460 Insert_After_And_Analyze
(Subp_Decl
, Prag
);
2462 end Build_PPC_Pragma
;
2467 Subp_Spec
: Node_Id
;
2469 -- Start of processing for Apply_Parameter_Validity_Checks
2472 -- Extract the subprogram specification and declaration nodes
2474 Subp_Spec
:= Parent
(Subp
);
2476 if Nkind
(Subp_Spec
) = N_Defining_Program_Unit_Name
then
2477 Subp_Spec
:= Parent
(Subp_Spec
);
2480 Subp_Decl
:= Parent
(Subp_Spec
);
2482 if not Comes_From_Source
(Subp
)
2484 -- Do not process formal subprograms because the corresponding actual
2485 -- will receive the proper checks when the instance is analyzed.
2487 or else Is_Formal_Subprogram
(Subp
)
2489 -- Do not process imported subprograms since pre and post conditions
2490 -- are never verified on routines coming from a different language.
2492 or else Is_Imported
(Subp
)
2493 or else Is_Intrinsic_Subprogram
(Subp
)
2495 -- The PPC pragmas generated by this routine do not correspond to
2496 -- source aspects, therefore they cannot be applied to abstract
2499 or else Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
2501 -- Do not consider subprogram renaminds because the renamed entity
2502 -- already has the proper PPC pragmas.
2504 or else Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
2506 -- Do not process null procedures because there is no benefit of
2507 -- adding the checks to a no action routine.
2509 or else (Nkind
(Subp_Spec
) = N_Procedure_Specification
2510 and then Null_Present
(Subp_Spec
))
2515 -- Inspect all the formals applying aliasing and scalar initialization
2516 -- checks where applicable.
2518 Formal
:= First_Formal
(Subp
);
2519 while Present
(Formal
) loop
2521 -- Generate the following scalar initialization checks for each
2522 -- formal parameter:
2524 -- mode IN - Pre => Formal'Valid[_Scalars]
2525 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
2526 -- mode OUT - Post => Formal'Valid[_Scalars]
2528 if Check_Validity_Of_Parameters
then
2529 if Ekind_In
(Formal
, E_In_Parameter
, E_In_Out_Parameter
) then
2530 Add_Validity_Check
(Formal
, Name_Precondition
, False);
2533 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
2534 Add_Validity_Check
(Formal
, Name_Postcondition
, False);
2538 Next_Formal
(Formal
);
2541 -- Generate following scalar initialization check for function result:
2543 -- Post => Subp'Result'Valid[_Scalars]
2545 if Check_Validity_Of_Parameters
and then Ekind
(Subp
) = E_Function
then
2546 Add_Validity_Check
(Subp
, Name_Postcondition
, True);
2548 end Apply_Parameter_Validity_Checks
;
2550 ---------------------------
2551 -- Apply_Predicate_Check --
2552 ---------------------------
2554 procedure Apply_Predicate_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
2558 if Present
(Predicate_Function
(Typ
)) then
2560 -- A predicate check does not apply within internally generated
2561 -- subprograms, such as TSS functions.
2564 while Present
(S
) and then not Is_Subprogram
(S
) loop
2568 if Present
(S
) and then Get_TSS_Name
(S
) /= TSS_Null
then
2571 -- If the check appears within the predicate function itself, it
2572 -- means that the user specified a check whose formal is the
2573 -- predicated subtype itself, rather than some covering type. This
2574 -- is likely to be a common error, and thus deserves a warning.
2576 elsif S
= Predicate_Function
(Typ
) then
2578 ("predicate check includes a function call that "
2579 & "requires a predicate check??", Parent
(N
));
2581 ("\this will result in infinite recursion??", Parent
(N
));
2583 Make_Raise_Storage_Error
(Sloc
(N
),
2584 Reason
=> SE_Infinite_Recursion
));
2586 -- Here for normal case of predicate active
2589 -- If the type has a static predicate and the expression is known
2590 -- at compile time, see if the expression satisfies the predicate.
2592 Check_Expression_Against_Static_Predicate
(N
, Typ
);
2595 Make_Predicate_Check
(Typ
, Duplicate_Subexpr
(N
)));
2598 end Apply_Predicate_Check
;
2600 -----------------------
2601 -- Apply_Range_Check --
2602 -----------------------
2604 procedure Apply_Range_Check
2606 Target_Typ
: Entity_Id
;
2607 Source_Typ
: Entity_Id
:= Empty
)
2610 Apply_Selected_Range_Checks
2611 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
2612 end Apply_Range_Check
;
2614 ------------------------------
2615 -- Apply_Scalar_Range_Check --
2616 ------------------------------
2618 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
2619 -- off if it is already set on.
2621 procedure Apply_Scalar_Range_Check
2623 Target_Typ
: Entity_Id
;
2624 Source_Typ
: Entity_Id
:= Empty
;
2625 Fixed_Int
: Boolean := False)
2627 Parnt
: constant Node_Id
:= Parent
(Expr
);
2629 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
2630 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
2633 Is_Subscr_Ref
: Boolean;
2634 -- Set true if Expr is a subscript
2636 Is_Unconstrained_Subscr_Ref
: Boolean;
2637 -- Set true if Expr is a subscript of an unconstrained array. In this
2638 -- case we do not attempt to do an analysis of the value against the
2639 -- range of the subscript, since we don't know the actual subtype.
2642 -- Set to True if Expr should be regarded as a real value even though
2643 -- the type of Expr might be discrete.
2645 procedure Bad_Value
;
2646 -- Procedure called if value is determined to be out of range
2652 procedure Bad_Value
is
2654 Apply_Compile_Time_Constraint_Error
2655 (Expr
, "value not in range of}??", CE_Range_Check_Failed
,
2660 -- Start of processing for Apply_Scalar_Range_Check
2663 -- Return if check obviously not needed
2666 -- Not needed inside generic
2670 -- Not needed if previous error
2672 or else Target_Typ
= Any_Type
2673 or else Nkind
(Expr
) = N_Error
2675 -- Not needed for non-scalar type
2677 or else not Is_Scalar_Type
(Target_Typ
)
2679 -- Not needed if we know node raises CE already
2681 or else Raises_Constraint_Error
(Expr
)
2686 -- Now, see if checks are suppressed
2689 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
2691 if Is_Subscr_Ref
then
2692 Arr
:= Prefix
(Parnt
);
2693 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
2695 if Is_Access_Type
(Arr_Typ
) then
2696 Arr_Typ
:= Designated_Type
(Arr_Typ
);
2700 if not Do_Range_Check
(Expr
) then
2702 -- Subscript reference. Check for Index_Checks suppressed
2704 if Is_Subscr_Ref
then
2706 -- Check array type and its base type
2708 if Index_Checks_Suppressed
(Arr_Typ
)
2709 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
2713 -- Check array itself if it is an entity name
2715 elsif Is_Entity_Name
(Arr
)
2716 and then Index_Checks_Suppressed
(Entity
(Arr
))
2720 -- Check expression itself if it is an entity name
2722 elsif Is_Entity_Name
(Expr
)
2723 and then Index_Checks_Suppressed
(Entity
(Expr
))
2728 -- All other cases, check for Range_Checks suppressed
2731 -- Check target type and its base type
2733 if Range_Checks_Suppressed
(Target_Typ
)
2734 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
2738 -- Check expression itself if it is an entity name
2740 elsif Is_Entity_Name
(Expr
)
2741 and then Range_Checks_Suppressed
(Entity
(Expr
))
2745 -- If Expr is part of an assignment statement, then check left
2746 -- side of assignment if it is an entity name.
2748 elsif Nkind
(Parnt
) = N_Assignment_Statement
2749 and then Is_Entity_Name
(Name
(Parnt
))
2750 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
2757 -- Do not set range checks if they are killed
2759 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
2760 and then Kill_Range_Check
(Expr
)
2765 -- Do not set range checks for any values from System.Scalar_Values
2766 -- since the whole idea of such values is to avoid checking them!
2768 if Is_Entity_Name
(Expr
)
2769 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
2774 -- Now see if we need a check
2776 if No
(Source_Typ
) then
2777 S_Typ
:= Etype
(Expr
);
2779 S_Typ
:= Source_Typ
;
2782 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
2786 Is_Unconstrained_Subscr_Ref
:=
2787 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
2789 -- Special checks for floating-point type
2791 if Is_Floating_Point_Type
(S_Typ
) then
2793 -- Always do a range check if the source type includes infinities and
2794 -- the target type does not include infinities. We do not do this if
2795 -- range checks are killed.
2797 if Has_Infinities
(S_Typ
)
2798 and then not Has_Infinities
(Target_Typ
)
2800 Enable_Range_Check
(Expr
);
2802 -- Always do a range check for operators if option set
2804 elsif Check_Float_Overflow
and then Nkind
(Expr
) in N_Op
then
2805 Enable_Range_Check
(Expr
);
2809 -- Return if we know expression is definitely in the range of the target
2810 -- type as determined by Determine_Range. Right now we only do this for
2811 -- discrete types, and not fixed-point or floating-point types.
2813 -- The additional less-precise tests below catch these cases
2815 -- Note: skip this if we are given a source_typ, since the point of
2816 -- supplying a Source_Typ is to stop us looking at the expression.
2817 -- We could sharpen this test to be out parameters only ???
2819 if Is_Discrete_Type
(Target_Typ
)
2820 and then Is_Discrete_Type
(Etype
(Expr
))
2821 and then not Is_Unconstrained_Subscr_Ref
2822 and then No
(Source_Typ
)
2825 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
2826 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
2831 if Compile_Time_Known_Value
(Tlo
)
2832 and then Compile_Time_Known_Value
(Thi
)
2835 Lov
: constant Uint
:= Expr_Value
(Tlo
);
2836 Hiv
: constant Uint
:= Expr_Value
(Thi
);
2839 -- If range is null, we for sure have a constraint error
2840 -- (we don't even need to look at the value involved,
2841 -- since all possible values will raise CE).
2848 -- Otherwise determine range of value
2850 Determine_Range
(Expr
, OK
, Lo
, Hi
, Assume_Valid
=> True);
2854 -- If definitely in range, all OK
2856 if Lo
>= Lov
and then Hi
<= Hiv
then
2859 -- If definitely not in range, warn
2861 elsif Lov
> Hi
or else Hiv
< Lo
then
2865 -- Otherwise we don't know
2877 Is_Floating_Point_Type
(S_Typ
)
2878 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
2880 -- Check if we can determine at compile time whether Expr is in the
2881 -- range of the target type. Note that if S_Typ is within the bounds
2882 -- of Target_Typ then this must be the case. This check is meaningful
2883 -- only if this is not a conversion between integer and real types.
2885 if not Is_Unconstrained_Subscr_Ref
2886 and then Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
2888 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
2890 Is_In_Range
(Expr
, Target_Typ
,
2891 Assume_Valid
=> True,
2892 Fixed_Int
=> Fixed_Int
,
2893 Int_Real
=> Int_Real
))
2897 elsif Is_Out_Of_Range
(Expr
, Target_Typ
,
2898 Assume_Valid
=> True,
2899 Fixed_Int
=> Fixed_Int
,
2900 Int_Real
=> Int_Real
)
2905 -- Floating-point case
2906 -- In the floating-point case, we only do range checks if the type is
2907 -- constrained. We definitely do NOT want range checks for unconstrained
2908 -- types, since we want to have infinities
2910 elsif Is_Floating_Point_Type
(S_Typ
) then
2912 -- Normally, we only do range checks if the type is constrained. We do
2913 -- NOT want range checks for unconstrained types, since we want to have
2914 -- infinities. Override this decision in Check_Float_Overflow mode.
2916 if Is_Constrained
(S_Typ
) or else Check_Float_Overflow
then
2917 Enable_Range_Check
(Expr
);
2920 -- For all other cases we enable a range check unconditionally
2923 Enable_Range_Check
(Expr
);
2926 end Apply_Scalar_Range_Check
;
2928 ----------------------------------
2929 -- Apply_Selected_Length_Checks --
2930 ----------------------------------
2932 procedure Apply_Selected_Length_Checks
2934 Target_Typ
: Entity_Id
;
2935 Source_Typ
: Entity_Id
;
2936 Do_Static
: Boolean)
2939 R_Result
: Check_Result
;
2942 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
2943 Checks_On
: constant Boolean :=
2944 (not Index_Checks_Suppressed
(Target_Typ
))
2945 or else (not Length_Checks_Suppressed
(Target_Typ
));
2948 if not Full_Expander_Active
then
2953 Selected_Length_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
2955 for J
in 1 .. 2 loop
2956 R_Cno
:= R_Result
(J
);
2957 exit when No
(R_Cno
);
2959 -- A length check may mention an Itype which is attached to a
2960 -- subsequent node. At the top level in a package this can cause
2961 -- an order-of-elaboration problem, so we make sure that the itype
2962 -- is referenced now.
2964 if Ekind
(Current_Scope
) = E_Package
2965 and then Is_Compilation_Unit
(Current_Scope
)
2967 Ensure_Defined
(Target_Typ
, Ck_Node
);
2969 if Present
(Source_Typ
) then
2970 Ensure_Defined
(Source_Typ
, Ck_Node
);
2972 elsif Is_Itype
(Etype
(Ck_Node
)) then
2973 Ensure_Defined
(Etype
(Ck_Node
), Ck_Node
);
2977 -- If the item is a conditional raise of constraint error, then have
2978 -- a look at what check is being performed and ???
2980 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
2981 and then Present
(Condition
(R_Cno
))
2983 Cond
:= Condition
(R_Cno
);
2985 -- Case where node does not now have a dynamic check
2987 if not Has_Dynamic_Length_Check
(Ck_Node
) then
2989 -- If checks are on, just insert the check
2992 Insert_Action
(Ck_Node
, R_Cno
);
2994 if not Do_Static
then
2995 Set_Has_Dynamic_Length_Check
(Ck_Node
);
2998 -- If checks are off, then analyze the length check after
2999 -- temporarily attaching it to the tree in case the relevant
3000 -- condition can be evaluated at compile time. We still want a
3001 -- compile time warning in this case.
3004 Set_Parent
(R_Cno
, Ck_Node
);
3009 -- Output a warning if the condition is known to be True
3011 if Is_Entity_Name
(Cond
)
3012 and then Entity
(Cond
) = Standard_True
3014 Apply_Compile_Time_Constraint_Error
3015 (Ck_Node
, "wrong length for array of}??",
3016 CE_Length_Check_Failed
,
3020 -- If we were only doing a static check, or if checks are not
3021 -- on, then we want to delete the check, since it is not needed.
3022 -- We do this by replacing the if statement by a null statement
3024 elsif Do_Static
or else not Checks_On
then
3025 Remove_Warning_Messages
(R_Cno
);
3026 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3030 Install_Static_Check
(R_Cno
, Loc
);
3033 end Apply_Selected_Length_Checks
;
3035 ---------------------------------
3036 -- Apply_Selected_Range_Checks --
3037 ---------------------------------
3039 procedure Apply_Selected_Range_Checks
3041 Target_Typ
: Entity_Id
;
3042 Source_Typ
: Entity_Id
;
3043 Do_Static
: Boolean)
3046 R_Result
: Check_Result
;
3049 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
3050 Checks_On
: constant Boolean :=
3051 (not Index_Checks_Suppressed
(Target_Typ
))
3052 or else (not Range_Checks_Suppressed
(Target_Typ
));
3055 if not Full_Expander_Active
or else not Checks_On
then
3060 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
3062 for J
in 1 .. 2 loop
3064 R_Cno
:= R_Result
(J
);
3065 exit when No
(R_Cno
);
3067 -- If the item is a conditional raise of constraint error, then have
3068 -- a look at what check is being performed and ???
3070 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
3071 and then Present
(Condition
(R_Cno
))
3073 Cond
:= Condition
(R_Cno
);
3075 if not Has_Dynamic_Range_Check
(Ck_Node
) then
3076 Insert_Action
(Ck_Node
, R_Cno
);
3078 if not Do_Static
then
3079 Set_Has_Dynamic_Range_Check
(Ck_Node
);
3083 -- Output a warning if the condition is known to be True
3085 if Is_Entity_Name
(Cond
)
3086 and then Entity
(Cond
) = Standard_True
3088 -- Since an N_Range is technically not an expression, we have
3089 -- to set one of the bounds to C_E and then just flag the
3090 -- N_Range. The warning message will point to the lower bound
3091 -- and complain about a range, which seems OK.
3093 if Nkind
(Ck_Node
) = N_Range
then
3094 Apply_Compile_Time_Constraint_Error
3095 (Low_Bound
(Ck_Node
), "static range out of bounds of}??",
3096 CE_Range_Check_Failed
,
3100 Set_Raises_Constraint_Error
(Ck_Node
);
3103 Apply_Compile_Time_Constraint_Error
3104 (Ck_Node
, "static value out of range of}?",
3105 CE_Range_Check_Failed
,
3110 -- If we were only doing a static check, or if checks are not
3111 -- on, then we want to delete the check, since it is not needed.
3112 -- We do this by replacing the if statement by a null statement
3114 elsif Do_Static
or else not Checks_On
then
3115 Remove_Warning_Messages
(R_Cno
);
3116 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
3120 Install_Static_Check
(R_Cno
, Loc
);
3123 end Apply_Selected_Range_Checks
;
3125 -------------------------------
3126 -- Apply_Static_Length_Check --
3127 -------------------------------
3129 procedure Apply_Static_Length_Check
3131 Target_Typ
: Entity_Id
;
3132 Source_Typ
: Entity_Id
:= Empty
)
3135 Apply_Selected_Length_Checks
3136 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
3137 end Apply_Static_Length_Check
;
3139 -------------------------------------
3140 -- Apply_Subscript_Validity_Checks --
3141 -------------------------------------
3143 procedure Apply_Subscript_Validity_Checks
(Expr
: Node_Id
) is
3147 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
3149 -- Loop through subscripts
3151 Sub
:= First
(Expressions
(Expr
));
3152 while Present
(Sub
) loop
3154 -- Check one subscript. Note that we do not worry about enumeration
3155 -- type with holes, since we will convert the value to a Pos value
3156 -- for the subscript, and that convert will do the necessary validity
3159 Ensure_Valid
(Sub
, Holes_OK
=> True);
3161 -- Move to next subscript
3165 end Apply_Subscript_Validity_Checks
;
3167 ----------------------------------
3168 -- Apply_Type_Conversion_Checks --
3169 ----------------------------------
3171 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
3172 Target_Type
: constant Entity_Id
:= Etype
(N
);
3173 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
3174 Expr
: constant Node_Id
:= Expression
(N
);
3176 Expr_Type
: constant Entity_Id
:= Underlying_Type
(Etype
(Expr
));
3177 -- Note: if Etype (Expr) is a private type without discriminants, its
3178 -- full view might have discriminants with defaults, so we need the
3179 -- full view here to retrieve the constraints.
3182 if Inside_A_Generic
then
3185 -- Skip these checks if serious errors detected, there are some nasty
3186 -- situations of incomplete trees that blow things up.
3188 elsif Serious_Errors_Detected
> 0 then
3191 -- Scalar type conversions of the form Target_Type (Expr) require a
3192 -- range check if we cannot be sure that Expr is in the base type of
3193 -- Target_Typ and also that Expr is in the range of Target_Typ. These
3194 -- are not quite the same condition from an implementation point of
3195 -- view, but clearly the second includes the first.
3197 elsif Is_Scalar_Type
(Target_Type
) then
3199 Conv_OK
: constant Boolean := Conversion_OK
(N
);
3200 -- If the Conversion_OK flag on the type conversion is set and no
3201 -- floating point type is involved in the type conversion then
3202 -- fixed point values must be read as integral values.
3204 Float_To_Int
: constant Boolean :=
3205 Is_Floating_Point_Type
(Expr_Type
)
3206 and then Is_Integer_Type
(Target_Type
);
3209 if not Overflow_Checks_Suppressed
(Target_Base
)
3210 and then not Overflow_Checks_Suppressed
(Target_Type
)
3212 In_Subrange_Of
(Expr_Type
, Target_Base
, Fixed_Int
=> Conv_OK
)
3213 and then not Float_To_Int
3215 Activate_Overflow_Check
(N
);
3218 if not Range_Checks_Suppressed
(Target_Type
)
3219 and then not Range_Checks_Suppressed
(Expr_Type
)
3221 if Float_To_Int
then
3222 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
3224 Apply_Scalar_Range_Check
3225 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
3227 -- If the target type has predicates, we need to indicate
3228 -- the need for a check, even if Determine_Range finds
3229 -- that the value is within bounds. This may be the case
3230 -- e.g for a division with a constant denominator.
3232 if Has_Predicates
(Target_Type
) then
3233 Enable_Range_Check
(Expr
);
3239 elsif Comes_From_Source
(N
)
3240 and then not Discriminant_Checks_Suppressed
(Target_Type
)
3241 and then Is_Record_Type
(Target_Type
)
3242 and then Is_Derived_Type
(Target_Type
)
3243 and then not Is_Tagged_Type
(Target_Type
)
3244 and then not Is_Constrained
(Target_Type
)
3245 and then Present
(Stored_Constraint
(Target_Type
))
3247 -- An unconstrained derived type may have inherited discriminant.
3248 -- Build an actual discriminant constraint list using the stored
3249 -- constraint, to verify that the expression of the parent type
3250 -- satisfies the constraints imposed by the (unconstrained!)
3251 -- derived type. This applies to value conversions, not to view
3252 -- conversions of tagged types.
3255 Loc
: constant Source_Ptr
:= Sloc
(N
);
3257 Constraint
: Elmt_Id
;
3258 Discr_Value
: Node_Id
;
3261 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
3262 Old_Constraints
: constant Elist_Id
:=
3263 Discriminant_Constraint
(Expr_Type
);
3266 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
3267 while Present
(Constraint
) loop
3268 Discr_Value
:= Node
(Constraint
);
3270 if Is_Entity_Name
(Discr_Value
)
3271 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
3273 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
3276 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
3278 -- Parent is constrained by new discriminant. Obtain
3279 -- Value of original discriminant in expression. If the
3280 -- new discriminant has been used to constrain more than
3281 -- one of the stored discriminants, this will provide the
3282 -- required consistency check.
3285 (Make_Selected_Component
(Loc
,
3287 Duplicate_Subexpr_No_Checks
3288 (Expr
, Name_Req
=> True),
3290 Make_Identifier
(Loc
, Chars
(Discr
))),
3294 -- Discriminant of more remote ancestor ???
3299 -- Derived type definition has an explicit value for this
3300 -- stored discriminant.
3304 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
3308 Next_Elmt
(Constraint
);
3311 -- Use the unconstrained expression type to retrieve the
3312 -- discriminants of the parent, and apply momentarily the
3313 -- discriminant constraint synthesized above.
3315 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
3316 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
3317 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
3320 Make_Raise_Constraint_Error
(Loc
,
3322 Reason
=> CE_Discriminant_Check_Failed
));
3325 -- For arrays, checks are set now, but conversions are applied during
3326 -- expansion, to take into accounts changes of representation. The
3327 -- checks become range checks on the base type or length checks on the
3328 -- subtype, depending on whether the target type is unconstrained or
3329 -- constrained. Note that the range check is put on the expression of a
3330 -- type conversion, while the length check is put on the type conversion
3333 elsif Is_Array_Type
(Target_Type
) then
3334 if Is_Constrained
(Target_Type
) then
3335 Set_Do_Length_Check
(N
);
3337 Set_Do_Range_Check
(Expr
);
3340 end Apply_Type_Conversion_Checks
;
3342 ----------------------------------------------
3343 -- Apply_Universal_Integer_Attribute_Checks --
3344 ----------------------------------------------
3346 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
3347 Loc
: constant Source_Ptr
:= Sloc
(N
);
3348 Typ
: constant Entity_Id
:= Etype
(N
);
3351 if Inside_A_Generic
then
3354 -- Nothing to do if checks are suppressed
3356 elsif Range_Checks_Suppressed
(Typ
)
3357 and then Overflow_Checks_Suppressed
(Typ
)
3361 -- Nothing to do if the attribute does not come from source. The
3362 -- internal attributes we generate of this type do not need checks,
3363 -- and furthermore the attempt to check them causes some circular
3364 -- elaboration orders when dealing with packed types.
3366 elsif not Comes_From_Source
(N
) then
3369 -- If the prefix is a selected component that depends on a discriminant
3370 -- the check may improperly expose a discriminant instead of using
3371 -- the bounds of the object itself. Set the type of the attribute to
3372 -- the base type of the context, so that a check will be imposed when
3373 -- needed (e.g. if the node appears as an index).
3375 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
3376 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
3377 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
3379 Set_Etype
(N
, Base_Type
(Typ
));
3381 -- Otherwise, replace the attribute node with a type conversion node
3382 -- whose expression is the attribute, retyped to universal integer, and
3383 -- whose subtype mark is the target type. The call to analyze this
3384 -- conversion will set range and overflow checks as required for proper
3385 -- detection of an out of range value.
3388 Set_Etype
(N
, Universal_Integer
);
3389 Set_Analyzed
(N
, True);
3392 Make_Type_Conversion
(Loc
,
3393 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
3394 Expression
=> Relocate_Node
(N
)));
3396 Analyze_And_Resolve
(N
, Typ
);
3399 end Apply_Universal_Integer_Attribute_Checks
;
3401 -------------------------------------
3402 -- Atomic_Synchronization_Disabled --
3403 -------------------------------------
3405 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented
3406 -- using a bogus check called Atomic_Synchronization. This is to make it
3407 -- more convenient to get exactly the same semantics as [Un]Suppress.
3409 function Atomic_Synchronization_Disabled
(E
: Entity_Id
) return Boolean is
3411 -- If debug flag d.e is set, always return False, i.e. all atomic sync
3412 -- looks enabled, since it is never disabled.
3414 if Debug_Flag_Dot_E
then
3417 -- If debug flag d.d is set then always return True, i.e. all atomic
3418 -- sync looks disabled, since it always tests True.
3420 elsif Debug_Flag_Dot_D
then
3423 -- If entity present, then check result for that entity
3425 elsif Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3426 return Is_Check_Suppressed
(E
, Atomic_Synchronization
);
3428 -- Otherwise result depends on current scope setting
3431 return Scope_Suppress
.Suppress
(Atomic_Synchronization
);
3433 end Atomic_Synchronization_Disabled
;
3435 -------------------------------
3436 -- Build_Discriminant_Checks --
3437 -------------------------------
3439 function Build_Discriminant_Checks
3441 T_Typ
: Entity_Id
) return Node_Id
3443 Loc
: constant Source_Ptr
:= Sloc
(N
);
3446 Disc_Ent
: Entity_Id
;
3450 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
;
3452 ----------------------------------
3453 -- Aggregate_Discriminant_Value --
3454 ----------------------------------
3456 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
is
3460 -- The aggregate has been normalized with named associations. We use
3461 -- the Chars field to locate the discriminant to take into account
3462 -- discriminants in derived types, which carry the same name as those
3465 Assoc
:= First
(Component_Associations
(N
));
3466 while Present
(Assoc
) loop
3467 if Chars
(First
(Choices
(Assoc
))) = Chars
(Disc
) then
3468 return Expression
(Assoc
);
3474 -- Discriminant must have been found in the loop above
3476 raise Program_Error
;
3477 end Aggregate_Discriminant_Val
;
3479 -- Start of processing for Build_Discriminant_Checks
3482 -- Loop through discriminants evolving the condition
3485 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
3487 -- For a fully private type, use the discriminants of the parent type
3489 if Is_Private_Type
(T_Typ
)
3490 and then No
(Full_View
(T_Typ
))
3492 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
3494 Disc_Ent
:= First_Discriminant
(T_Typ
);
3497 while Present
(Disc
) loop
3498 Dval
:= Node
(Disc
);
3500 if Nkind
(Dval
) = N_Identifier
3501 and then Ekind
(Entity
(Dval
)) = E_Discriminant
3503 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
3505 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
3508 -- If we have an Unchecked_Union node, we can infer the discriminants
3511 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
3513 Get_Discriminant_Value
(
3514 First_Discriminant
(T_Typ
),
3516 Stored_Constraint
(T_Typ
)));
3518 elsif Nkind
(N
) = N_Aggregate
then
3520 Duplicate_Subexpr_No_Checks
3521 (Aggregate_Discriminant_Val
(Disc_Ent
));
3525 Make_Selected_Component
(Loc
,
3527 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
3529 Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
3531 Set_Is_In_Discriminant_Check
(Dref
);
3534 Evolve_Or_Else
(Cond
,
3537 Right_Opnd
=> Dval
));
3540 Next_Discriminant
(Disc_Ent
);
3544 end Build_Discriminant_Checks
;
3550 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
3557 function Left_Expression
(Op
: Node_Id
) return Node_Id
;
3558 -- Return the relevant expression from the left operand of the given
3559 -- short circuit form: this is LO itself, except if LO is a qualified
3560 -- expression, a type conversion, or an expression with actions, in
3561 -- which case this is Left_Expression (Expression (LO)).
3563 ---------------------
3564 -- Left_Expression --
3565 ---------------------
3567 function Left_Expression
(Op
: Node_Id
) return Node_Id
is
3568 LE
: Node_Id
:= Left_Opnd
(Op
);
3571 N_Qualified_Expression
,
3573 N_Expression_With_Actions
)
3575 LE
:= Expression
(LE
);
3579 end Left_Expression
;
3581 -- Start of processing for Check_Needed
3584 -- Always check if not simple entity
3586 if Nkind
(Nod
) not in N_Has_Entity
3587 or else not Comes_From_Source
(Nod
)
3592 -- Look up tree for short circuit
3599 -- Done if out of subexpression (note that we allow generated stuff
3600 -- such as itype declarations in this context, to keep the loop going
3601 -- since we may well have generated such stuff in complex situations.
3602 -- Also done if no parent (probably an error condition, but no point
3603 -- in behaving nasty if we find it!)
3606 or else (K
not in N_Subexpr
and then Comes_From_Source
(P
))
3610 -- Or/Or Else case, where test is part of the right operand, or is
3611 -- part of one of the actions associated with the right operand, and
3612 -- the left operand is an equality test.
3614 elsif K
= N_Op_Or
then
3615 exit when N
= Right_Opnd
(P
)
3616 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
3618 elsif K
= N_Or_Else
then
3619 exit when (N
= Right_Opnd
(P
)
3622 and then List_Containing
(N
) = Actions
(P
)))
3623 and then Nkind
(Left_Expression
(P
)) = N_Op_Eq
;
3625 -- Similar test for the And/And then case, where the left operand
3626 -- is an inequality test.
3628 elsif K
= N_Op_And
then
3629 exit when N
= Right_Opnd
(P
)
3630 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
3632 elsif K
= N_And_Then
then
3633 exit when (N
= Right_Opnd
(P
)
3636 and then List_Containing
(N
) = Actions
(P
)))
3637 and then Nkind
(Left_Expression
(P
)) = N_Op_Ne
;
3643 -- If we fall through the loop, then we have a conditional with an
3644 -- appropriate test as its left operand, so look further.
3646 L
:= Left_Expression
(P
);
3648 -- L is an "=" or "/=" operator: extract its operands
3650 R
:= Right_Opnd
(L
);
3653 -- Left operand of test must match original variable
3655 if Nkind
(L
) not in N_Has_Entity
3656 or else Entity
(L
) /= Entity
(Nod
)
3661 -- Right operand of test must be key value (zero or null)
3664 when Access_Check
=>
3665 if not Known_Null
(R
) then
3669 when Division_Check
=>
3670 if not Compile_Time_Known_Value
(R
)
3671 or else Expr_Value
(R
) /= Uint_0
3677 raise Program_Error
;
3680 -- Here we have the optimizable case, warn if not short-circuited
3682 if K
= N_Op_And
or else K
= N_Op_Or
then
3684 when Access_Check
=>
3686 ("Constraint_Error may be raised (access check)??",
3688 when Division_Check
=>
3690 ("Constraint_Error may be raised (zero divide)??",
3694 raise Program_Error
;
3697 if K
= N_Op_And
then
3698 Error_Msg_N
-- CODEFIX
3699 ("use `AND THEN` instead of AND??", P
);
3701 Error_Msg_N
-- CODEFIX
3702 ("use `OR ELSE` instead of OR??", P
);
3705 -- If not short-circuited, we need the check
3709 -- If short-circuited, we can omit the check
3716 -----------------------------------
3717 -- Check_Valid_Lvalue_Subscripts --
3718 -----------------------------------
3720 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
3722 -- Skip this if range checks are suppressed
3724 if Range_Checks_Suppressed
(Etype
(Expr
)) then
3727 -- Only do this check for expressions that come from source. We assume
3728 -- that expander generated assignments explicitly include any necessary
3729 -- checks. Note that this is not just an optimization, it avoids
3730 -- infinite recursions!
3732 elsif not Comes_From_Source
(Expr
) then
3735 -- For a selected component, check the prefix
3737 elsif Nkind
(Expr
) = N_Selected_Component
then
3738 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3741 -- Case of indexed component
3743 elsif Nkind
(Expr
) = N_Indexed_Component
then
3744 Apply_Subscript_Validity_Checks
(Expr
);
3746 -- Prefix may itself be or contain an indexed component, and these
3747 -- subscripts need checking as well.
3749 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
3751 end Check_Valid_Lvalue_Subscripts
;
3753 ----------------------------------
3754 -- Null_Exclusion_Static_Checks --
3755 ----------------------------------
3757 procedure Null_Exclusion_Static_Checks
(N
: Node_Id
) is
3758 Error_Node
: Node_Id
;
3760 Has_Null
: constant Boolean := Has_Null_Exclusion
(N
);
3761 K
: constant Node_Kind
:= Nkind
(N
);
3766 (K
= N_Component_Declaration
3767 or else K
= N_Discriminant_Specification
3768 or else K
= N_Function_Specification
3769 or else K
= N_Object_Declaration
3770 or else K
= N_Parameter_Specification
);
3772 if K
= N_Function_Specification
then
3773 Typ
:= Etype
(Defining_Entity
(N
));
3775 Typ
:= Etype
(Defining_Identifier
(N
));
3779 when N_Component_Declaration
=>
3780 if Present
(Access_Definition
(Component_Definition
(N
))) then
3781 Error_Node
:= Component_Definition
(N
);
3783 Error_Node
:= Subtype_Indication
(Component_Definition
(N
));
3786 when N_Discriminant_Specification
=>
3787 Error_Node
:= Discriminant_Type
(N
);
3789 when N_Function_Specification
=>
3790 Error_Node
:= Result_Definition
(N
);
3792 when N_Object_Declaration
=>
3793 Error_Node
:= Object_Definition
(N
);
3795 when N_Parameter_Specification
=>
3796 Error_Node
:= Parameter_Type
(N
);
3799 raise Program_Error
;
3804 -- Enforce legality rule 3.10 (13): A null exclusion can only be
3805 -- applied to an access [sub]type.
3807 if not Is_Access_Type
(Typ
) then
3809 ("`NOT NULL` allowed only for an access type", Error_Node
);
3811 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
3812 -- be applied to a [sub]type that does not exclude null already.
3814 elsif Can_Never_Be_Null
(Typ
)
3815 and then Comes_From_Source
(Typ
)
3818 ("`NOT NULL` not allowed (& already excludes null)",
3823 -- Check that null-excluding objects are always initialized, except for
3824 -- deferred constants, for which the expression will appear in the full
3827 if K
= N_Object_Declaration
3828 and then No
(Expression
(N
))
3829 and then not Constant_Present
(N
)
3830 and then not No_Initialization
(N
)
3832 -- Add an expression that assigns null. This node is needed by
3833 -- Apply_Compile_Time_Constraint_Error, which will replace this with
3834 -- a Constraint_Error node.
3836 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
3837 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
3839 Apply_Compile_Time_Constraint_Error
3840 (N
=> Expression
(N
),
3842 "(Ada 2005) null-excluding objects must be initialized??",
3843 Reason
=> CE_Null_Not_Allowed
);
3846 -- Check that a null-excluding component, formal or object is not being
3847 -- assigned a null value. Otherwise generate a warning message and
3848 -- replace Expression (N) by an N_Constraint_Error node.
3850 if K
/= N_Function_Specification
then
3851 Expr
:= Expression
(N
);
3853 if Present
(Expr
) and then Known_Null
(Expr
) then
3855 when N_Component_Declaration |
3856 N_Discriminant_Specification
=>
3857 Apply_Compile_Time_Constraint_Error
3859 Msg
=> "(Ada 2005) null not allowed " &
3860 "in null-excluding components??",
3861 Reason
=> CE_Null_Not_Allowed
);
3863 when N_Object_Declaration
=>
3864 Apply_Compile_Time_Constraint_Error
3866 Msg
=> "(Ada 2005) null not allowed " &
3867 "in null-excluding objects?",
3868 Reason
=> CE_Null_Not_Allowed
);
3870 when N_Parameter_Specification
=>
3871 Apply_Compile_Time_Constraint_Error
3873 Msg
=> "(Ada 2005) null not allowed " &
3874 "in null-excluding formals??",
3875 Reason
=> CE_Null_Not_Allowed
);
3882 end Null_Exclusion_Static_Checks
;
3884 ----------------------------------
3885 -- Conditional_Statements_Begin --
3886 ----------------------------------
3888 procedure Conditional_Statements_Begin
is
3890 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
3892 -- If stack overflows, kill all checks, that way we know to simply reset
3893 -- the number of saved checks to zero on return. This should never occur
3896 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
3899 -- In the normal case, we just make a new stack entry saving the current
3900 -- number of saved checks for a later restore.
3903 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
3905 if Debug_Flag_CC
then
3906 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
3910 end Conditional_Statements_Begin
;
3912 --------------------------------
3913 -- Conditional_Statements_End --
3914 --------------------------------
3916 procedure Conditional_Statements_End
is
3918 pragma Assert
(Saved_Checks_TOS
> 0);
3920 -- If the saved checks stack overflowed, then we killed all checks, so
3921 -- setting the number of saved checks back to zero is correct. This
3922 -- should never occur in practice.
3924 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
3925 Num_Saved_Checks
:= 0;
3927 -- In the normal case, restore the number of saved checks from the top
3931 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
3932 if Debug_Flag_CC
then
3933 w
("Conditional_Statements_End: Num_Saved_Checks = ",
3938 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
3939 end Conditional_Statements_End
;
3941 -------------------------
3942 -- Convert_From_Bignum --
3943 -------------------------
3945 function Convert_From_Bignum
(N
: Node_Id
) return Node_Id
is
3946 Loc
: constant Source_Ptr
:= Sloc
(N
);
3949 pragma Assert
(Is_RTE
(Etype
(N
), RE_Bignum
));
3951 -- Construct call From Bignum
3954 Make_Function_Call
(Loc
,
3956 New_Occurrence_Of
(RTE
(RE_From_Bignum
), Loc
),
3957 Parameter_Associations
=> New_List
(Relocate_Node
(N
)));
3958 end Convert_From_Bignum
;
3960 -----------------------
3961 -- Convert_To_Bignum --
3962 -----------------------
3964 function Convert_To_Bignum
(N
: Node_Id
) return Node_Id
is
3965 Loc
: constant Source_Ptr
:= Sloc
(N
);
3968 -- Nothing to do if Bignum already except call Relocate_Node
3970 if Is_RTE
(Etype
(N
), RE_Bignum
) then
3971 return Relocate_Node
(N
);
3973 -- Otherwise construct call to To_Bignum, converting the operand to the
3974 -- required Long_Long_Integer form.
3977 pragma Assert
(Is_Signed_Integer_Type
(Etype
(N
)));
3979 Make_Function_Call
(Loc
,
3981 New_Occurrence_Of
(RTE
(RE_To_Bignum
), Loc
),
3982 Parameter_Associations
=> New_List
(
3983 Convert_To
(Standard_Long_Long_Integer
, Relocate_Node
(N
))));
3985 end Convert_To_Bignum
;
3987 ---------------------
3988 -- Determine_Range --
3989 ---------------------
3991 Cache_Size
: constant := 2 ** 10;
3992 type Cache_Index
is range 0 .. Cache_Size
- 1;
3993 -- Determine size of below cache (power of 2 is more efficient!)
3995 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
3996 Determine_Range_Cache_V
: array (Cache_Index
) of Boolean;
3997 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
3998 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
3999 -- The above arrays are used to implement a small direct cache for
4000 -- Determine_Range calls. Because of the way Determine_Range recursively
4001 -- traces subexpressions, and because overflow checking calls the routine
4002 -- on the way up the tree, a quadratic behavior can otherwise be
4003 -- encountered in large expressions. The cache entry for node N is stored
4004 -- in the (N mod Cache_Size) entry, and can be validated by checking the
4005 -- actual node value stored there. The Range_Cache_V array records the
4006 -- setting of Assume_Valid for the cache entry.
4008 procedure Determine_Range
4013 Assume_Valid
: Boolean := False)
4015 Typ
: Entity_Id
:= Etype
(N
);
4016 -- Type to use, may get reset to base type for possibly invalid entity
4020 -- Lo and Hi bounds of left operand
4024 -- Lo and Hi bounds of right (or only) operand
4027 -- Temp variable used to hold a bound node
4030 -- High bound of base type of expression
4034 -- Refined values for low and high bounds, after tightening
4037 -- Used in lower level calls to indicate if call succeeded
4039 Cindex
: Cache_Index
;
4040 -- Used to search cache
4045 function OK_Operands
return Boolean;
4046 -- Used for binary operators. Determines the ranges of the left and
4047 -- right operands, and if they are both OK, returns True, and puts
4048 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
4054 function OK_Operands
return Boolean is
4057 (Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
, Assume_Valid
);
4064 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4068 -- Start of processing for Determine_Range
4071 -- For temporary constants internally generated to remove side effects
4072 -- we must use the corresponding expression to determine the range of
4075 if Is_Entity_Name
(N
)
4076 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
4077 and then Ekind
(Entity
(N
)) = E_Constant
4078 and then Is_Internal_Name
(Chars
(Entity
(N
)))
4081 (Expression
(Parent
(Entity
(N
))), OK
, Lo
, Hi
, Assume_Valid
);
4085 -- Prevent junk warnings by initializing range variables
4092 -- If type is not defined, we can't determine its range
4096 -- We don't deal with anything except discrete types
4098 or else not Is_Discrete_Type
(Typ
)
4100 -- Ignore type for which an error has been posted, since range in
4101 -- this case may well be a bogosity deriving from the error. Also
4102 -- ignore if error posted on the reference node.
4104 or else Error_Posted
(N
) or else Error_Posted
(Typ
)
4110 -- For all other cases, we can determine the range
4114 -- If value is compile time known, then the possible range is the one
4115 -- value that we know this expression definitely has!
4117 if Compile_Time_Known_Value
(N
) then
4118 Lo
:= Expr_Value
(N
);
4123 -- Return if already in the cache
4125 Cindex
:= Cache_Index
(N
mod Cache_Size
);
4127 if Determine_Range_Cache_N
(Cindex
) = N
4129 Determine_Range_Cache_V
(Cindex
) = Assume_Valid
4131 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
4132 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
4136 -- Otherwise, start by finding the bounds of the type of the expression,
4137 -- the value cannot be outside this range (if it is, then we have an
4138 -- overflow situation, which is a separate check, we are talking here
4139 -- only about the expression value).
4141 -- First a check, never try to find the bounds of a generic type, since
4142 -- these bounds are always junk values, and it is only valid to look at
4143 -- the bounds in an instance.
4145 if Is_Generic_Type
(Typ
) then
4150 -- First step, change to use base type unless we know the value is valid
4152 if (Is_Entity_Name
(N
) and then Is_Known_Valid
(Entity
(N
)))
4153 or else Assume_No_Invalid_Values
4154 or else Assume_Valid
4158 Typ
:= Underlying_Type
(Base_Type
(Typ
));
4161 -- Retrieve the base type. Handle the case where the base type is a
4162 -- private enumeration type.
4164 Btyp
:= Base_Type
(Typ
);
4166 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
4167 Btyp
:= Full_View
(Btyp
);
4170 -- We use the actual bound unless it is dynamic, in which case use the
4171 -- corresponding base type bound if possible. If we can't get a bound
4172 -- then we figure we can't determine the range (a peculiar case, that
4173 -- perhaps cannot happen, but there is no point in bombing in this
4174 -- optimization circuit.
4176 -- First the low bound
4178 Bound
:= Type_Low_Bound
(Typ
);
4180 if Compile_Time_Known_Value
(Bound
) then
4181 Lo
:= Expr_Value
(Bound
);
4183 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Btyp
)) then
4184 Lo
:= Expr_Value
(Type_Low_Bound
(Btyp
));
4191 -- Now the high bound
4193 Bound
:= Type_High_Bound
(Typ
);
4195 -- We need the high bound of the base type later on, and this should
4196 -- always be compile time known. Again, it is not clear that this
4197 -- can ever be false, but no point in bombing.
4199 if Compile_Time_Known_Value
(Type_High_Bound
(Btyp
)) then
4200 Hbound
:= Expr_Value
(Type_High_Bound
(Btyp
));
4208 -- If we have a static subtype, then that may have a tighter bound so
4209 -- use the upper bound of the subtype instead in this case.
4211 if Compile_Time_Known_Value
(Bound
) then
4212 Hi
:= Expr_Value
(Bound
);
4215 -- We may be able to refine this value in certain situations. If any
4216 -- refinement is possible, then Lor and Hir are set to possibly tighter
4217 -- bounds, and OK1 is set to True.
4221 -- For unary plus, result is limited by range of operand
4225 (Right_Opnd
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4227 -- For unary minus, determine range of operand, and negate it
4231 (Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
, Assume_Valid
);
4238 -- For binary addition, get range of each operand and do the
4239 -- addition to get the result range.
4243 Lor
:= Lo_Left
+ Lo_Right
;
4244 Hir
:= Hi_Left
+ Hi_Right
;
4247 -- Division is tricky. The only case we consider is where the right
4248 -- operand is a positive constant, and in this case we simply divide
4249 -- the bounds of the left operand
4253 if Lo_Right
= Hi_Right
4254 and then Lo_Right
> 0
4256 Lor
:= Lo_Left
/ Lo_Right
;
4257 Hir
:= Hi_Left
/ Lo_Right
;
4264 -- For binary subtraction, get range of each operand and do the worst
4265 -- case subtraction to get the result range.
4267 when N_Op_Subtract
=>
4269 Lor
:= Lo_Left
- Hi_Right
;
4270 Hir
:= Hi_Left
- Lo_Right
;
4273 -- For MOD, if right operand is a positive constant, then result must
4274 -- be in the allowable range of mod results.
4278 if Lo_Right
= Hi_Right
4279 and then Lo_Right
/= 0
4281 if Lo_Right
> 0 then
4283 Hir
:= Lo_Right
- 1;
4285 else -- Lo_Right < 0
4286 Lor
:= Lo_Right
+ 1;
4295 -- For REM, if right operand is a positive constant, then result must
4296 -- be in the allowable range of mod results.
4300 if Lo_Right
= Hi_Right
4301 and then Lo_Right
/= 0
4304 Dval
: constant Uint
:= (abs Lo_Right
) - 1;
4307 -- The sign of the result depends on the sign of the
4308 -- dividend (but not on the sign of the divisor, hence
4309 -- the abs operation above).
4329 -- Attribute reference cases
4331 when N_Attribute_Reference
=>
4332 case Attribute_Name
(N
) is
4334 -- For Pos/Val attributes, we can refine the range using the
4335 -- possible range of values of the attribute expression.
4337 when Name_Pos | Name_Val
=>
4339 (First
(Expressions
(N
)), OK1
, Lor
, Hir
, Assume_Valid
);
4341 -- For Length attribute, use the bounds of the corresponding
4342 -- index type to refine the range.
4346 Atyp
: Entity_Id
:= Etype
(Prefix
(N
));
4354 if Is_Access_Type
(Atyp
) then
4355 Atyp
:= Designated_Type
(Atyp
);
4358 -- For string literal, we know exact value
4360 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
4362 Lo
:= String_Literal_Length
(Atyp
);
4363 Hi
:= String_Literal_Length
(Atyp
);
4367 -- Otherwise check for expression given
4369 if No
(Expressions
(N
)) then
4373 UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
4376 Indx
:= First_Index
(Atyp
);
4377 for J
in 2 .. Inum
loop
4378 Indx
:= Next_Index
(Indx
);
4381 -- If the index type is a formal type or derived from
4382 -- one, the bounds are not static.
4384 if Is_Generic_Type
(Root_Type
(Etype
(Indx
))) then
4390 (Type_Low_Bound
(Etype
(Indx
)), OK1
, LL
, LU
,
4395 (Type_High_Bound
(Etype
(Indx
)), OK1
, UL
, UU
,
4400 -- The maximum value for Length is the biggest
4401 -- possible gap between the values of the bounds.
4402 -- But of course, this value cannot be negative.
4404 Hir
:= UI_Max
(Uint_0
, UU
- LL
+ 1);
4406 -- For constrained arrays, the minimum value for
4407 -- Length is taken from the actual value of the
4408 -- bounds, since the index will be exactly of this
4411 if Is_Constrained
(Atyp
) then
4412 Lor
:= UI_Max
(Uint_0
, UL
- LU
+ 1);
4414 -- For an unconstrained array, the minimum value
4415 -- for length is always zero.
4424 -- No special handling for other attributes
4425 -- Probably more opportunities exist here???
4432 -- For type conversion from one discrete type to another, we can
4433 -- refine the range using the converted value.
4435 when N_Type_Conversion
=>
4436 Determine_Range
(Expression
(N
), OK1
, Lor
, Hir
, Assume_Valid
);
4438 -- Nothing special to do for all other expression kinds
4446 -- At this stage, if OK1 is true, then we know that the actual result of
4447 -- the computed expression is in the range Lor .. Hir. We can use this
4448 -- to restrict the possible range of results.
4452 -- If the refined value of the low bound is greater than the type
4453 -- high bound, then reset it to the more restrictive value. However,
4454 -- we do NOT do this for the case of a modular type where the
4455 -- possible upper bound on the value is above the base type high
4456 -- bound, because that means the result could wrap.
4459 and then not (Is_Modular_Integer_Type
(Typ
) and then Hir
> Hbound
)
4464 -- Similarly, if the refined value of the high bound is less than the
4465 -- value so far, then reset it to the more restrictive value. Again,
4466 -- we do not do this if the refined low bound is negative for a
4467 -- modular type, since this would wrap.
4470 and then not (Is_Modular_Integer_Type
(Typ
) and then Lor
< Uint_0
)
4476 -- Set cache entry for future call and we are all done
4478 Determine_Range_Cache_N
(Cindex
) := N
;
4479 Determine_Range_Cache_V
(Cindex
) := Assume_Valid
;
4480 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
4481 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
4484 -- If any exception occurs, it means that we have some bug in the compiler,
4485 -- possibly triggered by a previous error, or by some unforeseen peculiar
4486 -- occurrence. However, this is only an optimization attempt, so there is
4487 -- really no point in crashing the compiler. Instead we just decide, too
4488 -- bad, we can't figure out a range in this case after all.
4493 -- Debug flag K disables this behavior (useful for debugging)
4495 if Debug_Flag_K
then
4503 end Determine_Range
;
4505 ------------------------------------
4506 -- Discriminant_Checks_Suppressed --
4507 ------------------------------------
4509 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4512 if Is_Unchecked_Union
(E
) then
4514 elsif Checks_May_Be_Suppressed
(E
) then
4515 return Is_Check_Suppressed
(E
, Discriminant_Check
);
4519 return Scope_Suppress
.Suppress
(Discriminant_Check
);
4520 end Discriminant_Checks_Suppressed
;
4522 --------------------------------
4523 -- Division_Checks_Suppressed --
4524 --------------------------------
4526 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4528 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4529 return Is_Check_Suppressed
(E
, Division_Check
);
4531 return Scope_Suppress
.Suppress
(Division_Check
);
4533 end Division_Checks_Suppressed
;
4535 -----------------------------------
4536 -- Elaboration_Checks_Suppressed --
4537 -----------------------------------
4539 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4541 -- The complication in this routine is that if we are in the dynamic
4542 -- model of elaboration, we also check All_Checks, since All_Checks
4543 -- does not set Elaboration_Check explicitly.
4546 if Kill_Elaboration_Checks
(E
) then
4549 elsif Checks_May_Be_Suppressed
(E
) then
4550 if Is_Check_Suppressed
(E
, Elaboration_Check
) then
4552 elsif Dynamic_Elaboration_Checks
then
4553 return Is_Check_Suppressed
(E
, All_Checks
);
4560 if Scope_Suppress
.Suppress
(Elaboration_Check
) then
4562 elsif Dynamic_Elaboration_Checks
then
4563 return Scope_Suppress
.Suppress
(All_Checks
);
4567 end Elaboration_Checks_Suppressed
;
4569 ---------------------------
4570 -- Enable_Overflow_Check --
4571 ---------------------------
4573 procedure Enable_Overflow_Check
(N
: Node_Id
) is
4574 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
4575 Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
4584 if Debug_Flag_CC
then
4585 w
("Enable_Overflow_Check for node ", Int
(N
));
4586 Write_Str
(" Source location = ");
4591 -- No check if overflow checks suppressed for type of node
4593 if Overflow_Checks_Suppressed
(Etype
(N
)) then
4596 -- Nothing to do for unsigned integer types, which do not overflow
4598 elsif Is_Modular_Integer_Type
(Typ
) then
4602 -- This is the point at which processing for STRICT mode diverges
4603 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
4604 -- probably more extreme that it needs to be, but what is going on here
4605 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
4606 -- to leave the processing for STRICT mode untouched. There were
4607 -- two reasons for this. First it avoided any incompatible change of
4608 -- behavior. Second, it guaranteed that STRICT mode continued to be
4611 -- The big difference is that in STRICT mode there is a fair amount of
4612 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
4613 -- know that no check is needed. We skip all that in the two new modes,
4614 -- since really overflow checking happens over a whole subtree, and we
4615 -- do the corresponding optimizations later on when applying the checks.
4617 if Mode
in Minimized_Or_Eliminated
then
4618 if not (Overflow_Checks_Suppressed
(Etype
(N
)))
4619 and then not (Is_Entity_Name
(N
)
4620 and then Overflow_Checks_Suppressed
(Entity
(N
)))
4622 Activate_Overflow_Check
(N
);
4625 if Debug_Flag_CC
then
4626 w
("Minimized/Eliminated mode");
4632 -- Remainder of processing is for STRICT case, and is unchanged from
4633 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
4635 -- Nothing to do if the range of the result is known OK. We skip this
4636 -- for conversions, since the caller already did the check, and in any
4637 -- case the condition for deleting the check for a type conversion is
4640 if Nkind
(N
) /= N_Type_Conversion
then
4641 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> True);
4643 -- Note in the test below that we assume that the range is not OK
4644 -- if a bound of the range is equal to that of the type. That's not
4645 -- quite accurate but we do this for the following reasons:
4647 -- a) The way that Determine_Range works, it will typically report
4648 -- the bounds of the value as being equal to the bounds of the
4649 -- type, because it either can't tell anything more precise, or
4650 -- does not think it is worth the effort to be more precise.
4652 -- b) It is very unusual to have a situation in which this would
4653 -- generate an unnecessary overflow check (an example would be
4654 -- a subtype with a range 0 .. Integer'Last - 1 to which the
4655 -- literal value one is added).
4657 -- c) The alternative is a lot of special casing in this routine
4658 -- which would partially duplicate Determine_Range processing.
4661 and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
4662 and then Hi
< Expr_Value
(Type_High_Bound
(Typ
))
4664 if Debug_Flag_CC
then
4665 w
("No overflow check required");
4672 -- If not in optimizing mode, set flag and we are done. We are also done
4673 -- (and just set the flag) if the type is not a discrete type, since it
4674 -- is not worth the effort to eliminate checks for other than discrete
4675 -- types. In addition, we take this same path if we have stored the
4676 -- maximum number of checks possible already (a very unlikely situation,
4677 -- but we do not want to blow up!)
4679 if Optimization_Level
= 0
4680 or else not Is_Discrete_Type
(Etype
(N
))
4681 or else Num_Saved_Checks
= Saved_Checks
'Last
4683 Activate_Overflow_Check
(N
);
4685 if Debug_Flag_CC
then
4686 w
("Optimization off");
4692 -- Otherwise evaluate and check the expression
4697 Target_Type
=> Empty
,
4703 if Debug_Flag_CC
then
4704 w
("Called Find_Check");
4708 w
(" Check_Num = ", Chk
);
4709 w
(" Ent = ", Int
(Ent
));
4710 Write_Str
(" Ofs = ");
4715 -- If check is not of form to optimize, then set flag and we are done
4718 Activate_Overflow_Check
(N
);
4722 -- If check is already performed, then return without setting flag
4725 if Debug_Flag_CC
then
4726 w
("Check suppressed!");
4732 -- Here we will make a new entry for the new check
4734 Activate_Overflow_Check
(N
);
4735 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
4736 Saved_Checks
(Num_Saved_Checks
) :=
4741 Target_Type
=> Empty
);
4743 if Debug_Flag_CC
then
4744 w
("Make new entry, check number = ", Num_Saved_Checks
);
4745 w
(" Entity = ", Int
(Ent
));
4746 Write_Str
(" Offset = ");
4748 w
(" Check_Type = O");
4749 w
(" Target_Type = Empty");
4752 -- If we get an exception, then something went wrong, probably because of
4753 -- an error in the structure of the tree due to an incorrect program. Or it
4754 -- may be a bug in the optimization circuit. In either case the safest
4755 -- thing is simply to set the check flag unconditionally.
4759 Activate_Overflow_Check
(N
);
4761 if Debug_Flag_CC
then
4762 w
(" exception occurred, overflow flag set");
4766 end Enable_Overflow_Check
;
4768 ------------------------
4769 -- Enable_Range_Check --
4770 ------------------------
4772 procedure Enable_Range_Check
(N
: Node_Id
) is
4781 -- Return if unchecked type conversion with range check killed. In this
4782 -- case we never set the flag (that's what Kill_Range_Check is about!)
4784 if Nkind
(N
) = N_Unchecked_Type_Conversion
4785 and then Kill_Range_Check
(N
)
4790 -- Do not set range check flag if parent is assignment statement or
4791 -- object declaration with Suppress_Assignment_Checks flag set
4793 if Nkind_In
(Parent
(N
), N_Assignment_Statement
, N_Object_Declaration
)
4794 and then Suppress_Assignment_Checks
(Parent
(N
))
4799 -- Check for various cases where we should suppress the range check
4801 -- No check if range checks suppressed for type of node
4803 if Present
(Etype
(N
))
4804 and then Range_Checks_Suppressed
(Etype
(N
))
4808 -- No check if node is an entity name, and range checks are suppressed
4809 -- for this entity, or for the type of this entity.
4811 elsif Is_Entity_Name
(N
)
4812 and then (Range_Checks_Suppressed
(Entity
(N
))
4813 or else Range_Checks_Suppressed
(Etype
(Entity
(N
))))
4817 -- No checks if index of array, and index checks are suppressed for
4818 -- the array object or the type of the array.
4820 elsif Nkind
(Parent
(N
)) = N_Indexed_Component
then
4822 Pref
: constant Node_Id
:= Prefix
(Parent
(N
));
4824 if Is_Entity_Name
(Pref
)
4825 and then Index_Checks_Suppressed
(Entity
(Pref
))
4828 elsif Index_Checks_Suppressed
(Etype
(Pref
)) then
4834 -- Debug trace output
4836 if Debug_Flag_CC
then
4837 w
("Enable_Range_Check for node ", Int
(N
));
4838 Write_Str
(" Source location = ");
4843 -- If not in optimizing mode, set flag and we are done. We are also done
4844 -- (and just set the flag) if the type is not a discrete type, since it
4845 -- is not worth the effort to eliminate checks for other than discrete
4846 -- types. In addition, we take this same path if we have stored the
4847 -- maximum number of checks possible already (a very unlikely situation,
4848 -- but we do not want to blow up!)
4850 if Optimization_Level
= 0
4851 or else No
(Etype
(N
))
4852 or else not Is_Discrete_Type
(Etype
(N
))
4853 or else Num_Saved_Checks
= Saved_Checks
'Last
4855 Activate_Range_Check
(N
);
4857 if Debug_Flag_CC
then
4858 w
("Optimization off");
4864 -- Otherwise find out the target type
4868 -- For assignment, use left side subtype
4870 if Nkind
(P
) = N_Assignment_Statement
4871 and then Expression
(P
) = N
4873 Ttyp
:= Etype
(Name
(P
));
4875 -- For indexed component, use subscript subtype
4877 elsif Nkind
(P
) = N_Indexed_Component
then
4884 Atyp
:= Etype
(Prefix
(P
));
4886 if Is_Access_Type
(Atyp
) then
4887 Atyp
:= Designated_Type
(Atyp
);
4889 -- If the prefix is an access to an unconstrained array,
4890 -- perform check unconditionally: it depends on the bounds of
4891 -- an object and we cannot currently recognize whether the test
4892 -- may be redundant.
4894 if not Is_Constrained
(Atyp
) then
4895 Activate_Range_Check
(N
);
4899 -- Ditto if the prefix is an explicit dereference whose designated
4900 -- type is unconstrained.
4902 elsif Nkind
(Prefix
(P
)) = N_Explicit_Dereference
4903 and then not Is_Constrained
(Atyp
)
4905 Activate_Range_Check
(N
);
4909 Indx
:= First_Index
(Atyp
);
4910 Subs
:= First
(Expressions
(P
));
4913 Ttyp
:= Etype
(Indx
);
4922 -- For now, ignore all other cases, they are not so interesting
4925 if Debug_Flag_CC
then
4926 w
(" target type not found, flag set");
4929 Activate_Range_Check
(N
);
4933 -- Evaluate and check the expression
4938 Target_Type
=> Ttyp
,
4944 if Debug_Flag_CC
then
4945 w
("Called Find_Check");
4946 w
("Target_Typ = ", Int
(Ttyp
));
4950 w
(" Check_Num = ", Chk
);
4951 w
(" Ent = ", Int
(Ent
));
4952 Write_Str
(" Ofs = ");
4957 -- If check is not of form to optimize, then set flag and we are done
4960 if Debug_Flag_CC
then
4961 w
(" expression not of optimizable type, flag set");
4964 Activate_Range_Check
(N
);
4968 -- If check is already performed, then return without setting flag
4971 if Debug_Flag_CC
then
4972 w
("Check suppressed!");
4978 -- Here we will make a new entry for the new check
4980 Activate_Range_Check
(N
);
4981 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
4982 Saved_Checks
(Num_Saved_Checks
) :=
4987 Target_Type
=> Ttyp
);
4989 if Debug_Flag_CC
then
4990 w
("Make new entry, check number = ", Num_Saved_Checks
);
4991 w
(" Entity = ", Int
(Ent
));
4992 Write_Str
(" Offset = ");
4994 w
(" Check_Type = R");
4995 w
(" Target_Type = ", Int
(Ttyp
));
4996 pg
(Union_Id
(Ttyp
));
4999 -- If we get an exception, then something went wrong, probably because of
5000 -- an error in the structure of the tree due to an incorrect program. Or
5001 -- it may be a bug in the optimization circuit. In either case the safest
5002 -- thing is simply to set the check flag unconditionally.
5006 Activate_Range_Check
(N
);
5008 if Debug_Flag_CC
then
5009 w
(" exception occurred, range flag set");
5013 end Enable_Range_Check
;
5019 procedure Ensure_Valid
(Expr
: Node_Id
; Holes_OK
: Boolean := False) is
5020 Typ
: constant Entity_Id
:= Etype
(Expr
);
5023 -- Ignore call if we are not doing any validity checking
5025 if not Validity_Checks_On
then
5028 -- Ignore call if range or validity checks suppressed on entity or type
5030 elsif Range_Or_Validity_Checks_Suppressed
(Expr
) then
5033 -- No check required if expression is from the expander, we assume the
5034 -- expander will generate whatever checks are needed. Note that this is
5035 -- not just an optimization, it avoids infinite recursions!
5037 -- Unchecked conversions must be checked, unless they are initialized
5038 -- scalar values, as in a component assignment in an init proc.
5040 -- In addition, we force a check if Force_Validity_Checks is set
5042 elsif not Comes_From_Source
(Expr
)
5043 and then not Force_Validity_Checks
5044 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
5045 or else Kill_Range_Check
(Expr
))
5049 -- No check required if expression is known to have valid value
5051 elsif Expr_Known_Valid
(Expr
) then
5054 -- Ignore case of enumeration with holes where the flag is set not to
5055 -- worry about holes, since no special validity check is needed
5057 elsif Is_Enumeration_Type
(Typ
)
5058 and then Has_Non_Standard_Rep
(Typ
)
5063 -- No check required on the left-hand side of an assignment
5065 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
5066 and then Expr
= Name
(Parent
(Expr
))
5070 -- No check on a universal real constant. The context will eventually
5071 -- convert it to a machine number for some target type, or report an
5074 elsif Nkind
(Expr
) = N_Real_Literal
5075 and then Etype
(Expr
) = Universal_Real
5079 -- If the expression denotes a component of a packed boolean array,
5080 -- no possible check applies. We ignore the old ACATS chestnuts that
5081 -- involve Boolean range True..True.
5083 -- Note: validity checks are generated for expressions that yield a
5084 -- scalar type, when it is possible to create a value that is outside of
5085 -- the type. If this is a one-bit boolean no such value exists. This is
5086 -- an optimization, and it also prevents compiler blowing up during the
5087 -- elaboration of improperly expanded packed array references.
5089 elsif Nkind
(Expr
) = N_Indexed_Component
5090 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Expr
)))
5091 and then Root_Type
(Etype
(Expr
)) = Standard_Boolean
5095 -- An annoying special case. If this is an out parameter of a scalar
5096 -- type, then the value is not going to be accessed, therefore it is
5097 -- inappropriate to do any validity check at the call site.
5100 -- Only need to worry about scalar types
5102 if Is_Scalar_Type
(Typ
) then
5112 -- Find actual argument (which may be a parameter association)
5113 -- and the parent of the actual argument (the call statement)
5118 if Nkind
(P
) = N_Parameter_Association
then
5123 -- Only need to worry if we are argument of a procedure call
5124 -- since functions don't have out parameters. If this is an
5125 -- indirect or dispatching call, get signature from the
5128 if Nkind
(P
) = N_Procedure_Call_Statement
then
5129 L
:= Parameter_Associations
(P
);
5131 if Is_Entity_Name
(Name
(P
)) then
5132 E
:= Entity
(Name
(P
));
5134 pragma Assert
(Nkind
(Name
(P
)) = N_Explicit_Dereference
);
5135 E
:= Etype
(Name
(P
));
5138 -- Only need to worry if there are indeed actuals, and if
5139 -- this could be a procedure call, otherwise we cannot get a
5140 -- match (either we are not an argument, or the mode of the
5141 -- formal is not OUT). This test also filters out the
5144 if Is_Non_Empty_List
(L
)
5145 and then Is_Subprogram
(E
)
5147 -- This is the loop through parameters, looking for an
5148 -- OUT parameter for which we are the argument.
5150 F
:= First_Formal
(E
);
5152 while Present
(F
) loop
5153 if Ekind
(F
) = E_Out_Parameter
and then A
= N
then
5166 -- If this is a boolean expression, only its elementary operands need
5167 -- checking: if they are valid, a boolean or short-circuit operation
5168 -- with them will be valid as well.
5170 if Base_Type
(Typ
) = Standard_Boolean
5172 (Nkind
(Expr
) in N_Op
or else Nkind
(Expr
) in N_Short_Circuit
)
5177 -- If we fall through, a validity check is required
5179 Insert_Valid_Check
(Expr
);
5181 if Is_Entity_Name
(Expr
)
5182 and then Safe_To_Capture_Value
(Expr
, Entity
(Expr
))
5184 Set_Is_Known_Valid
(Entity
(Expr
));
5188 ----------------------
5189 -- Expr_Known_Valid --
5190 ----------------------
5192 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
5193 Typ
: constant Entity_Id
:= Etype
(Expr
);
5196 -- Non-scalar types are always considered valid, since they never give
5197 -- rise to the issues of erroneous or bounded error behavior that are
5198 -- the concern. In formal reference manual terms the notion of validity
5199 -- only applies to scalar types. Note that even when packed arrays are
5200 -- represented using modular types, they are still arrays semantically,
5201 -- so they are also always valid (in particular, the unused bits can be
5202 -- random rubbish without affecting the validity of the array value).
5204 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Type
(Typ
) then
5207 -- If no validity checking, then everything is considered valid
5209 elsif not Validity_Checks_On
then
5212 -- Floating-point types are considered valid unless floating-point
5213 -- validity checks have been specifically turned on.
5215 elsif Is_Floating_Point_Type
(Typ
)
5216 and then not Validity_Check_Floating_Point
5220 -- If the expression is the value of an object that is known to be
5221 -- valid, then clearly the expression value itself is valid.
5223 elsif Is_Entity_Name
(Expr
)
5224 and then Is_Known_Valid
(Entity
(Expr
))
5228 -- References to discriminants are always considered valid. The value
5229 -- of a discriminant gets checked when the object is built. Within the
5230 -- record, we consider it valid, and it is important to do so, since
5231 -- otherwise we can try to generate bogus validity checks which
5232 -- reference discriminants out of scope. Discriminants of concurrent
5233 -- types are excluded for the same reason.
5235 elsif Is_Entity_Name
(Expr
)
5236 and then Denotes_Discriminant
(Expr
, Check_Concurrent
=> True)
5240 -- If the type is one for which all values are known valid, then we are
5241 -- sure that the value is valid except in the slightly odd case where
5242 -- the expression is a reference to a variable whose size has been
5243 -- explicitly set to a value greater than the object size.
5245 elsif Is_Known_Valid
(Typ
) then
5246 if Is_Entity_Name
(Expr
)
5247 and then Ekind
(Entity
(Expr
)) = E_Variable
5248 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
5255 -- Integer and character literals always have valid values, where
5256 -- appropriate these will be range checked in any case.
5258 elsif Nkind
(Expr
) = N_Integer_Literal
5260 Nkind
(Expr
) = N_Character_Literal
5264 -- Real literals are assumed to be valid in VM targets
5266 elsif VM_Target
/= No_VM
5267 and then Nkind
(Expr
) = N_Real_Literal
5271 -- If we have a type conversion or a qualification of a known valid
5272 -- value, then the result will always be valid.
5274 elsif Nkind
(Expr
) = N_Type_Conversion
5276 Nkind
(Expr
) = N_Qualified_Expression
5278 return Expr_Known_Valid
(Expression
(Expr
));
5280 -- The result of any operator is always considered valid, since we
5281 -- assume the necessary checks are done by the operator. For operators
5282 -- on floating-point operations, we must also check when the operation
5283 -- is the right-hand side of an assignment, or is an actual in a call.
5285 elsif Nkind
(Expr
) in N_Op
then
5286 if Is_Floating_Point_Type
(Typ
)
5287 and then Validity_Check_Floating_Point
5289 (Nkind
(Parent
(Expr
)) = N_Assignment_Statement
5290 or else Nkind
(Parent
(Expr
)) = N_Function_Call
5291 or else Nkind
(Parent
(Expr
)) = N_Parameter_Association
)
5298 -- The result of a membership test is always valid, since it is true or
5299 -- false, there are no other possibilities.
5301 elsif Nkind
(Expr
) in N_Membership_Test
then
5304 -- For all other cases, we do not know the expression is valid
5309 end Expr_Known_Valid
;
5315 procedure Find_Check
5317 Check_Type
: Character;
5318 Target_Type
: Entity_Id
;
5319 Entry_OK
: out Boolean;
5320 Check_Num
: out Nat
;
5321 Ent
: out Entity_Id
;
5324 function Within_Range_Of
5325 (Target_Type
: Entity_Id
;
5326 Check_Type
: Entity_Id
) return Boolean;
5327 -- Given a requirement for checking a range against Target_Type, and
5328 -- and a range Check_Type against which a check has already been made,
5329 -- determines if the check against check type is sufficient to ensure
5330 -- that no check against Target_Type is required.
5332 ---------------------
5333 -- Within_Range_Of --
5334 ---------------------
5336 function Within_Range_Of
5337 (Target_Type
: Entity_Id
;
5338 Check_Type
: Entity_Id
) return Boolean
5341 if Target_Type
= Check_Type
then
5346 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
5347 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
5348 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
5349 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
5353 or else (Compile_Time_Known_Value
(Tlo
)
5355 Compile_Time_Known_Value
(Clo
)
5357 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
5360 or else (Compile_Time_Known_Value
(Thi
)
5362 Compile_Time_Known_Value
(Chi
)
5364 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
5372 end Within_Range_Of
;
5374 -- Start of processing for Find_Check
5377 -- Establish default, in case no entry is found
5381 -- Case of expression is simple entity reference
5383 if Is_Entity_Name
(Expr
) then
5384 Ent
:= Entity
(Expr
);
5387 -- Case of expression is entity + known constant
5389 elsif Nkind
(Expr
) = N_Op_Add
5390 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
5391 and then Is_Entity_Name
(Left_Opnd
(Expr
))
5393 Ent
:= Entity
(Left_Opnd
(Expr
));
5394 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
5396 -- Case of expression is entity - known constant
5398 elsif Nkind
(Expr
) = N_Op_Subtract
5399 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
5400 and then Is_Entity_Name
(Left_Opnd
(Expr
))
5402 Ent
:= Entity
(Left_Opnd
(Expr
));
5403 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
5405 -- Any other expression is not of the right form
5414 -- Come here with expression of appropriate form, check if entity is an
5415 -- appropriate one for our purposes.
5417 if (Ekind
(Ent
) = E_Variable
5418 or else Is_Constant_Object
(Ent
))
5419 and then not Is_Library_Level_Entity
(Ent
)
5427 -- See if there is matching check already
5429 for J
in reverse 1 .. Num_Saved_Checks
loop
5431 SC
: Saved_Check
renames Saved_Checks
(J
);
5434 if SC
.Killed
= False
5435 and then SC
.Entity
= Ent
5436 and then SC
.Offset
= Ofs
5437 and then SC
.Check_Type
= Check_Type
5438 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
5446 -- If we fall through entry was not found
5451 ---------------------------------
5452 -- Generate_Discriminant_Check --
5453 ---------------------------------
5455 -- Note: the code for this procedure is derived from the
5456 -- Emit_Discriminant_Check Routine in trans.c.
5458 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
5459 Loc
: constant Source_Ptr
:= Sloc
(N
);
5460 Pref
: constant Node_Id
:= Prefix
(N
);
5461 Sel
: constant Node_Id
:= Selector_Name
(N
);
5463 Orig_Comp
: constant Entity_Id
:=
5464 Original_Record_Component
(Entity
(Sel
));
5465 -- The original component to be checked
5467 Discr_Fct
: constant Entity_Id
:=
5468 Discriminant_Checking_Func
(Orig_Comp
);
5469 -- The discriminant checking function
5472 -- One discriminant to be checked in the type
5474 Real_Discr
: Entity_Id
;
5475 -- Actual discriminant in the call
5477 Pref_Type
: Entity_Id
;
5478 -- Type of relevant prefix (ignoring private/access stuff)
5481 -- List of arguments for function call
5484 -- Keep track of the formal corresponding to the actual we build for
5485 -- each discriminant, in order to be able to perform the necessary type
5489 -- Selected component reference for checking function argument
5492 Pref_Type
:= Etype
(Pref
);
5494 -- Force evaluation of the prefix, so that it does not get evaluated
5495 -- twice (once for the check, once for the actual reference). Such a
5496 -- double evaluation is always a potential source of inefficiency,
5497 -- and is functionally incorrect in the volatile case, or when the
5498 -- prefix may have side-effects. An entity or a component of an
5499 -- entity requires no evaluation.
5501 if Is_Entity_Name
(Pref
) then
5502 if Treat_As_Volatile
(Entity
(Pref
)) then
5503 Force_Evaluation
(Pref
, Name_Req
=> True);
5506 elsif Treat_As_Volatile
(Etype
(Pref
)) then
5507 Force_Evaluation
(Pref
, Name_Req
=> True);
5509 elsif Nkind
(Pref
) = N_Selected_Component
5510 and then Is_Entity_Name
(Prefix
(Pref
))
5515 Force_Evaluation
(Pref
, Name_Req
=> True);
5518 -- For a tagged type, use the scope of the original component to
5519 -- obtain the type, because ???
5521 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
5522 Pref_Type
:= Scope
(Orig_Comp
);
5524 -- For an untagged derived type, use the discriminants of the parent
5525 -- which have been renamed in the derivation, possibly by a one-to-many
5526 -- discriminant constraint. For non-tagged type, initially get the Etype
5530 if Is_Derived_Type
(Pref_Type
)
5531 and then Number_Discriminants
(Pref_Type
) /=
5532 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
5534 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
5538 -- We definitely should have a checking function, This routine should
5539 -- not be called if no discriminant checking function is present.
5541 pragma Assert
(Present
(Discr_Fct
));
5543 -- Create the list of the actual parameters for the call. This list
5544 -- is the list of the discriminant fields of the record expression to
5545 -- be discriminant checked.
5548 Formal
:= First_Formal
(Discr_Fct
);
5549 Discr
:= First_Discriminant
(Pref_Type
);
5550 while Present
(Discr
) loop
5552 -- If we have a corresponding discriminant field, and a parent
5553 -- subtype is present, then we want to use the corresponding
5554 -- discriminant since this is the one with the useful value.
5556 if Present
(Corresponding_Discriminant
(Discr
))
5557 and then Ekind
(Pref_Type
) = E_Record_Type
5558 and then Present
(Parent_Subtype
(Pref_Type
))
5560 Real_Discr
:= Corresponding_Discriminant
(Discr
);
5562 Real_Discr
:= Discr
;
5565 -- Construct the reference to the discriminant
5568 Make_Selected_Component
(Loc
,
5570 Unchecked_Convert_To
(Pref_Type
,
5571 Duplicate_Subexpr
(Pref
)),
5572 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
5574 -- Manually analyze and resolve this selected component. We really
5575 -- want it just as it appears above, and do not want the expander
5576 -- playing discriminal games etc with this reference. Then we append
5577 -- the argument to the list we are gathering.
5579 Set_Etype
(Scomp
, Etype
(Real_Discr
));
5580 Set_Analyzed
(Scomp
, True);
5581 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
5583 Next_Formal_With_Extras
(Formal
);
5584 Next_Discriminant
(Discr
);
5587 -- Now build and insert the call
5590 Make_Raise_Constraint_Error
(Loc
,
5592 Make_Function_Call
(Loc
,
5593 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
5594 Parameter_Associations
=> Args
),
5595 Reason
=> CE_Discriminant_Check_Failed
));
5596 end Generate_Discriminant_Check
;
5598 ---------------------------
5599 -- Generate_Index_Checks --
5600 ---------------------------
5602 procedure Generate_Index_Checks
(N
: Node_Id
) is
5604 function Entity_Of_Prefix
return Entity_Id
;
5605 -- Returns the entity of the prefix of N (or Empty if not found)
5607 ----------------------
5608 -- Entity_Of_Prefix --
5609 ----------------------
5611 function Entity_Of_Prefix
return Entity_Id
is
5616 while not Is_Entity_Name
(P
) loop
5617 if not Nkind_In
(P
, N_Selected_Component
,
5618 N_Indexed_Component
)
5627 end Entity_Of_Prefix
;
5631 Loc
: constant Source_Ptr
:= Sloc
(N
);
5632 A
: constant Node_Id
:= Prefix
(N
);
5633 A_Ent
: constant Entity_Id
:= Entity_Of_Prefix
;
5636 -- Start of processing for Generate_Index_Checks
5639 -- Ignore call if the prefix is not an array since we have a serious
5640 -- error in the sources. Ignore it also if index checks are suppressed
5641 -- for array object or type.
5643 if not Is_Array_Type
(Etype
(A
))
5644 or else (Present
(A_Ent
)
5645 and then Index_Checks_Suppressed
(A_Ent
))
5646 or else Index_Checks_Suppressed
(Etype
(A
))
5650 -- The indexed component we are dealing with contains 'Loop_Entry in its
5651 -- prefix. This case arises when analysis has determined that constructs
5654 -- Prefix'Loop_Entry (Expr)
5655 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
5657 -- require rewriting for error detection purposes. A side effect of this
5658 -- action is the generation of index checks that mention 'Loop_Entry.
5659 -- Delay the generation of the check until 'Loop_Entry has been properly
5660 -- expanded. This is done in Expand_Loop_Entry_Attributes.
5662 elsif Nkind
(Prefix
(N
)) = N_Attribute_Reference
5663 and then Attribute_Name
(Prefix
(N
)) = Name_Loop_Entry
5668 -- Generate a raise of constraint error with the appropriate reason and
5669 -- a condition of the form:
5671 -- Base_Type (Sub) not in Array'Range (Subscript)
5673 -- Note that the reason we generate the conversion to the base type here
5674 -- is that we definitely want the range check to take place, even if it
5675 -- looks like the subtype is OK. Optimization considerations that allow
5676 -- us to omit the check have already been taken into account in the
5677 -- setting of the Do_Range_Check flag earlier on.
5679 Sub
:= First
(Expressions
(N
));
5681 -- Handle string literals
5683 if Ekind
(Etype
(A
)) = E_String_Literal_Subtype
then
5684 if Do_Range_Check
(Sub
) then
5685 Set_Do_Range_Check
(Sub
, False);
5687 -- For string literals we obtain the bounds of the string from the
5688 -- associated subtype.
5691 Make_Raise_Constraint_Error
(Loc
,
5695 Convert_To
(Base_Type
(Etype
(Sub
)),
5696 Duplicate_Subexpr_Move_Checks
(Sub
)),
5698 Make_Attribute_Reference
(Loc
,
5699 Prefix
=> New_Reference_To
(Etype
(A
), Loc
),
5700 Attribute_Name
=> Name_Range
)),
5701 Reason
=> CE_Index_Check_Failed
));
5708 A_Idx
: Node_Id
:= Empty
;
5715 A_Idx
:= First_Index
(Etype
(A
));
5717 while Present
(Sub
) loop
5718 if Do_Range_Check
(Sub
) then
5719 Set_Do_Range_Check
(Sub
, False);
5721 -- Force evaluation except for the case of a simple name of
5722 -- a non-volatile entity.
5724 if not Is_Entity_Name
(Sub
)
5725 or else Treat_As_Volatile
(Entity
(Sub
))
5727 Force_Evaluation
(Sub
);
5730 if Nkind
(A_Idx
) = N_Range
then
5733 elsif Nkind
(A_Idx
) = N_Identifier
5734 or else Nkind
(A_Idx
) = N_Expanded_Name
5736 A_Range
:= Scalar_Range
(Entity
(A_Idx
));
5738 else pragma Assert
(Nkind
(A_Idx
) = N_Subtype_Indication
);
5739 A_Range
:= Range_Expression
(Constraint
(A_Idx
));
5742 -- For array objects with constant bounds we can generate
5743 -- the index check using the bounds of the type of the index
5746 and then Ekind
(A_Ent
) = E_Variable
5747 and then Is_Constant_Bound
(Low_Bound
(A_Range
))
5748 and then Is_Constant_Bound
(High_Bound
(A_Range
))
5751 Make_Attribute_Reference
(Loc
,
5753 New_Reference_To
(Etype
(A_Idx
), Loc
),
5754 Attribute_Name
=> Name_Range
);
5756 -- For arrays with non-constant bounds we cannot generate
5757 -- the index check using the bounds of the type of the index
5758 -- since it may reference discriminants of some enclosing
5759 -- type. We obtain the bounds directly from the prefix
5766 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
5770 Make_Attribute_Reference
(Loc
,
5772 Duplicate_Subexpr_Move_Checks
(A
, Name_Req
=> True),
5773 Attribute_Name
=> Name_Range
,
5774 Expressions
=> Num
);
5778 Make_Raise_Constraint_Error
(Loc
,
5782 Convert_To
(Base_Type
(Etype
(Sub
)),
5783 Duplicate_Subexpr_Move_Checks
(Sub
)),
5784 Right_Opnd
=> Range_N
),
5785 Reason
=> CE_Index_Check_Failed
));
5788 A_Idx
:= Next_Index
(A_Idx
);
5794 end Generate_Index_Checks
;
5796 --------------------------
5797 -- Generate_Range_Check --
5798 --------------------------
5800 procedure Generate_Range_Check
5802 Target_Type
: Entity_Id
;
5803 Reason
: RT_Exception_Code
)
5805 Loc
: constant Source_Ptr
:= Sloc
(N
);
5806 Source_Type
: constant Entity_Id
:= Etype
(N
);
5807 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
5808 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
5811 -- First special case, if the source type is already within the range
5812 -- of the target type, then no check is needed (probably we should have
5813 -- stopped Do_Range_Check from being set in the first place, but better
5814 -- late than never in preventing junk code!
5816 if In_Subrange_Of
(Source_Type
, Target_Type
)
5818 -- We do NOT apply this if the source node is a literal, since in this
5819 -- case the literal has already been labeled as having the subtype of
5823 (Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
, N_Character_Literal
)
5826 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
5828 -- Also do not apply this for floating-point if Check_Float_Overflow
5831 (Is_Floating_Point_Type
(Source_Type
) and Check_Float_Overflow
)
5836 -- We need a check, so force evaluation of the node, so that it does
5837 -- not get evaluated twice (once for the check, once for the actual
5838 -- reference). Such a double evaluation is always a potential source
5839 -- of inefficiency, and is functionally incorrect in the volatile case.
5841 if not Is_Entity_Name
(N
) or else Treat_As_Volatile
(Entity
(N
)) then
5842 Force_Evaluation
(N
);
5845 -- The easiest case is when Source_Base_Type and Target_Base_Type are
5846 -- the same since in this case we can simply do a direct check of the
5847 -- value of N against the bounds of Target_Type.
5849 -- [constraint_error when N not in Target_Type]
5851 -- Note: this is by far the most common case, for example all cases of
5852 -- checks on the RHS of assignments are in this category, but not all
5853 -- cases are like this. Notably conversions can involve two types.
5855 if Source_Base_Type
= Target_Base_Type
then
5857 Make_Raise_Constraint_Error
(Loc
,
5860 Left_Opnd
=> Duplicate_Subexpr
(N
),
5861 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
5864 -- Next test for the case where the target type is within the bounds
5865 -- of the base type of the source type, since in this case we can
5866 -- simply convert these bounds to the base type of T to do the test.
5868 -- [constraint_error when N not in
5869 -- Source_Base_Type (Target_Type'First)
5871 -- Source_Base_Type(Target_Type'Last))]
5873 -- The conversions will always work and need no check
5875 -- Unchecked_Convert_To is used instead of Convert_To to handle the case
5876 -- of converting from an enumeration value to an integer type, such as
5877 -- occurs for the case of generating a range check on Enum'Val(Exp)
5878 -- (which used to be handled by gigi). This is OK, since the conversion
5879 -- itself does not require a check.
5881 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
5883 Make_Raise_Constraint_Error
(Loc
,
5886 Left_Opnd
=> Duplicate_Subexpr
(N
),
5891 Unchecked_Convert_To
(Source_Base_Type
,
5892 Make_Attribute_Reference
(Loc
,
5894 New_Occurrence_Of
(Target_Type
, Loc
),
5895 Attribute_Name
=> Name_First
)),
5898 Unchecked_Convert_To
(Source_Base_Type
,
5899 Make_Attribute_Reference
(Loc
,
5901 New_Occurrence_Of
(Target_Type
, Loc
),
5902 Attribute_Name
=> Name_Last
)))),
5905 -- Note that at this stage we now that the Target_Base_Type is not in
5906 -- the range of the Source_Base_Type (since even the Target_Type itself
5907 -- is not in this range). It could still be the case that Source_Type is
5908 -- in range of the target base type since we have not checked that case.
5910 -- If that is the case, we can freely convert the source to the target,
5911 -- and then test the target result against the bounds.
5913 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
5915 -- We make a temporary to hold the value of the converted value
5916 -- (converted to the base type), and then we will do the test against
5919 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
5920 -- [constraint_error when Tnn not in Target_Type]
5922 -- Then the conversion itself is replaced by an occurrence of Tnn
5925 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
5928 Insert_Actions
(N
, New_List
(
5929 Make_Object_Declaration
(Loc
,
5930 Defining_Identifier
=> Tnn
,
5931 Object_Definition
=>
5932 New_Occurrence_Of
(Target_Base_Type
, Loc
),
5933 Constant_Present
=> True,
5935 Make_Type_Conversion
(Loc
,
5936 Subtype_Mark
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
5937 Expression
=> Duplicate_Subexpr
(N
))),
5939 Make_Raise_Constraint_Error
(Loc
,
5942 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
5943 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
5945 Reason
=> Reason
)));
5947 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
5949 -- Set the type of N, because the declaration for Tnn might not
5950 -- be analyzed yet, as is the case if N appears within a record
5951 -- declaration, as a discriminant constraint or expression.
5953 Set_Etype
(N
, Target_Base_Type
);
5956 -- At this stage, we know that we have two scalar types, which are
5957 -- directly convertible, and where neither scalar type has a base
5958 -- range that is in the range of the other scalar type.
5960 -- The only way this can happen is with a signed and unsigned type.
5961 -- So test for these two cases:
5964 -- Case of the source is unsigned and the target is signed
5966 if Is_Unsigned_Type
(Source_Base_Type
)
5967 and then not Is_Unsigned_Type
(Target_Base_Type
)
5969 -- If the source is unsigned and the target is signed, then we
5970 -- know that the source is not shorter than the target (otherwise
5971 -- the source base type would be in the target base type range).
5973 -- In other words, the unsigned type is either the same size as
5974 -- the target, or it is larger. It cannot be smaller.
5977 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
5979 -- We only need to check the low bound if the low bound of the
5980 -- target type is non-negative. If the low bound of the target
5981 -- type is negative, then we know that we will fit fine.
5983 -- If the high bound of the target type is negative, then we
5984 -- know we have a constraint error, since we can't possibly
5985 -- have a negative source.
5987 -- With these two checks out of the way, we can do the check
5988 -- using the source type safely
5990 -- This is definitely the most annoying case!
5992 -- [constraint_error
5993 -- when (Target_Type'First >= 0
5995 -- N < Source_Base_Type (Target_Type'First))
5996 -- or else Target_Type'Last < 0
5997 -- or else N > Source_Base_Type (Target_Type'Last)];
5999 -- We turn off all checks since we know that the conversions
6000 -- will work fine, given the guards for negative values.
6003 Make_Raise_Constraint_Error
(Loc
,
6009 Left_Opnd
=> Make_Op_Ge
(Loc
,
6011 Make_Attribute_Reference
(Loc
,
6013 New_Occurrence_Of
(Target_Type
, Loc
),
6014 Attribute_Name
=> Name_First
),
6015 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
6019 Left_Opnd
=> Duplicate_Subexpr
(N
),
6021 Convert_To
(Source_Base_Type
,
6022 Make_Attribute_Reference
(Loc
,
6024 New_Occurrence_Of
(Target_Type
, Loc
),
6025 Attribute_Name
=> Name_First
)))),
6030 Make_Attribute_Reference
(Loc
,
6031 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
6032 Attribute_Name
=> Name_Last
),
6033 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
6037 Left_Opnd
=> Duplicate_Subexpr
(N
),
6039 Convert_To
(Source_Base_Type
,
6040 Make_Attribute_Reference
(Loc
,
6041 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
6042 Attribute_Name
=> Name_Last
)))),
6045 Suppress
=> All_Checks
);
6047 -- Only remaining possibility is that the source is signed and
6048 -- the target is unsigned.
6051 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
6052 and then Is_Unsigned_Type
(Target_Base_Type
));
6054 -- If the source is signed and the target is unsigned, then we
6055 -- know that the target is not shorter than the source (otherwise
6056 -- the target base type would be in the source base type range).
6058 -- In other words, the unsigned type is either the same size as
6059 -- the target, or it is larger. It cannot be smaller.
6061 -- Clearly we have an error if the source value is negative since
6062 -- no unsigned type can have negative values. If the source type
6063 -- is non-negative, then the check can be done using the target
6066 -- Tnn : constant Target_Base_Type (N) := Target_Type;
6068 -- [constraint_error
6069 -- when N < 0 or else Tnn not in Target_Type];
6071 -- We turn off all checks for the conversion of N to the target
6072 -- base type, since we generate the explicit check to ensure that
6073 -- the value is non-negative
6076 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
6079 Insert_Actions
(N
, New_List
(
6080 Make_Object_Declaration
(Loc
,
6081 Defining_Identifier
=> Tnn
,
6082 Object_Definition
=>
6083 New_Occurrence_Of
(Target_Base_Type
, Loc
),
6084 Constant_Present
=> True,
6086 Make_Unchecked_Type_Conversion
(Loc
,
6088 New_Occurrence_Of
(Target_Base_Type
, Loc
),
6089 Expression
=> Duplicate_Subexpr
(N
))),
6091 Make_Raise_Constraint_Error
(Loc
,
6096 Left_Opnd
=> Duplicate_Subexpr
(N
),
6097 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
6101 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
6103 New_Occurrence_Of
(Target_Type
, Loc
))),
6106 Suppress
=> All_Checks
);
6108 -- Set the Etype explicitly, because Insert_Actions may have
6109 -- placed the declaration in the freeze list for an enclosing
6110 -- construct, and thus it is not analyzed yet.
6112 Set_Etype
(Tnn
, Target_Base_Type
);
6113 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
6117 end Generate_Range_Check
;
6123 function Get_Check_Id
(N
: Name_Id
) return Check_Id
is
6125 -- For standard check name, we can do a direct computation
6127 if N
in First_Check_Name
.. Last_Check_Name
then
6128 return Check_Id
(N
- (First_Check_Name
- 1));
6130 -- For non-standard names added by pragma Check_Name, search table
6133 for J
in All_Checks
+ 1 .. Check_Names
.Last
loop
6134 if Check_Names
.Table
(J
) = N
then
6140 -- No matching name found
6145 ---------------------
6146 -- Get_Discriminal --
6147 ---------------------
6149 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
6150 Loc
: constant Source_Ptr
:= Sloc
(E
);
6155 -- The bound can be a bona fide parameter of a protected operation,
6156 -- rather than a prival encoded as an in-parameter.
6158 if No
(Discriminal_Link
(Entity
(Bound
))) then
6162 -- Climb the scope stack looking for an enclosing protected type. If
6163 -- we run out of scopes, return the bound itself.
6166 while Present
(Sc
) loop
6167 if Sc
= Standard_Standard
then
6170 elsif Ekind
(Sc
) = E_Protected_Type
then
6177 D
:= First_Discriminant
(Sc
);
6178 while Present
(D
) loop
6179 if Chars
(D
) = Chars
(Bound
) then
6180 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
6183 Next_Discriminant
(D
);
6187 end Get_Discriminal
;
6189 ----------------------
6190 -- Get_Range_Checks --
6191 ----------------------
6193 function Get_Range_Checks
6195 Target_Typ
: Entity_Id
;
6196 Source_Typ
: Entity_Id
:= Empty
;
6197 Warn_Node
: Node_Id
:= Empty
) return Check_Result
6200 return Selected_Range_Checks
6201 (Ck_Node
, Target_Typ
, Source_Typ
, Warn_Node
);
6202 end Get_Range_Checks
;
6208 function Guard_Access
6211 Ck_Node
: Node_Id
) return Node_Id
6214 if Nkind
(Cond
) = N_Or_Else
then
6215 Set_Paren_Count
(Cond
, 1);
6218 if Nkind
(Ck_Node
) = N_Allocator
then
6225 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
6226 Right_Opnd
=> Make_Null
(Loc
)),
6227 Right_Opnd
=> Cond
);
6231 -----------------------------
6232 -- Index_Checks_Suppressed --
6233 -----------------------------
6235 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6237 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6238 return Is_Check_Suppressed
(E
, Index_Check
);
6240 return Scope_Suppress
.Suppress
(Index_Check
);
6242 end Index_Checks_Suppressed
;
6248 procedure Initialize
is
6250 for J
in Determine_Range_Cache_N
'Range loop
6251 Determine_Range_Cache_N
(J
) := Empty
;
6256 for J
in Int
range 1 .. All_Checks
loop
6257 Check_Names
.Append
(Name_Id
(Int
(First_Check_Name
) + J
- 1));
6261 -------------------------
6262 -- Insert_Range_Checks --
6263 -------------------------
6265 procedure Insert_Range_Checks
6266 (Checks
: Check_Result
;
6268 Suppress_Typ
: Entity_Id
;
6269 Static_Sloc
: Source_Ptr
:= No_Location
;
6270 Flag_Node
: Node_Id
:= Empty
;
6271 Do_Before
: Boolean := False)
6273 Internal_Flag_Node
: Node_Id
:= Flag_Node
;
6274 Internal_Static_Sloc
: Source_Ptr
:= Static_Sloc
;
6276 Check_Node
: Node_Id
;
6277 Checks_On
: constant Boolean :=
6278 (not Index_Checks_Suppressed
(Suppress_Typ
))
6279 or else (not Range_Checks_Suppressed
(Suppress_Typ
));
6282 -- For now we just return if Checks_On is false, however this should be
6283 -- enhanced to check for an always True value in the condition and to
6284 -- generate a compilation warning???
6286 if not Full_Expander_Active
or else not Checks_On
then
6290 if Static_Sloc
= No_Location
then
6291 Internal_Static_Sloc
:= Sloc
(Node
);
6294 if No
(Flag_Node
) then
6295 Internal_Flag_Node
:= Node
;
6298 for J
in 1 .. 2 loop
6299 exit when No
(Checks
(J
));
6301 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
6302 and then Present
(Condition
(Checks
(J
)))
6304 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
6305 Check_Node
:= Checks
(J
);
6306 Mark_Rewrite_Insertion
(Check_Node
);
6309 Insert_Before_And_Analyze
(Node
, Check_Node
);
6311 Insert_After_And_Analyze
(Node
, Check_Node
);
6314 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
6319 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
6320 Reason
=> CE_Range_Check_Failed
);
6321 Mark_Rewrite_Insertion
(Check_Node
);
6324 Insert_Before_And_Analyze
(Node
, Check_Node
);
6326 Insert_After_And_Analyze
(Node
, Check_Node
);
6330 end Insert_Range_Checks
;
6332 ------------------------
6333 -- Insert_Valid_Check --
6334 ------------------------
6336 procedure Insert_Valid_Check
(Expr
: Node_Id
) is
6337 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6338 Typ
: constant Entity_Id
:= Etype
(Expr
);
6342 -- Do not insert if checks off, or if not checking validity or
6343 -- if expression is known to be valid
6345 if not Validity_Checks_On
6346 or else Range_Or_Validity_Checks_Suppressed
(Expr
)
6347 or else Expr_Known_Valid
(Expr
)
6352 -- Do not insert checks within a predicate function. This will arise
6353 -- if the current unit and the predicate function are being compiled
6354 -- with validity checks enabled.
6356 if Present
(Predicate_Function
(Typ
))
6357 and then Current_Scope
= Predicate_Function
(Typ
)
6362 -- If we have a checked conversion, then validity check applies to
6363 -- the expression inside the conversion, not the result, since if
6364 -- the expression inside is valid, then so is the conversion result.
6367 while Nkind
(Exp
) = N_Type_Conversion
loop
6368 Exp
:= Expression
(Exp
);
6371 -- We are about to insert the validity check for Exp. We save and
6372 -- reset the Do_Range_Check flag over this validity check, and then
6373 -- put it back for the final original reference (Exp may be rewritten).
6376 DRC
: constant Boolean := Do_Range_Check
(Exp
);
6381 Set_Do_Range_Check
(Exp
, False);
6383 -- Force evaluation to avoid multiple reads for atomic/volatile
6385 if Is_Entity_Name
(Exp
)
6386 and then Is_Volatile
(Entity
(Exp
))
6388 Force_Evaluation
(Exp
, Name_Req
=> True);
6391 -- Build the prefix for the 'Valid call
6393 PV
:= Duplicate_Subexpr_No_Checks
(Exp
, Name_Req
=> True);
6395 -- A rather specialized kludge. If PV is an analyzed expression
6396 -- which is an indexed component of a packed array that has not
6397 -- been properly expanded, turn off its Analyzed flag to make sure
6398 -- it gets properly reexpanded.
6400 -- The reason this arises is that Duplicate_Subexpr_No_Checks did
6401 -- an analyze with the old parent pointer. This may point e.g. to
6402 -- a subprogram call, which deactivates this expansion.
6405 and then Nkind
(PV
) = N_Indexed_Component
6406 and then Present
(Packed_Array_Type
(Etype
(Prefix
(PV
))))
6408 Set_Analyzed
(PV
, False);
6411 -- Build the raise CE node to check for validity
6414 Make_Raise_Constraint_Error
(Loc
,
6418 Make_Attribute_Reference
(Loc
,
6420 Attribute_Name
=> Name_Valid
)),
6421 Reason
=> CE_Invalid_Data
);
6423 -- Insert the validity check. Note that we do this with validity
6424 -- checks turned off, to avoid recursion, we do not want validity
6425 -- checks on the validity checking code itself!
6427 Insert_Action
(Expr
, CE
, Suppress
=> Validity_Check
);
6429 -- If the expression is a reference to an element of a bit-packed
6430 -- array, then it is rewritten as a renaming declaration. If the
6431 -- expression is an actual in a call, it has not been expanded,
6432 -- waiting for the proper point at which to do it. The same happens
6433 -- with renamings, so that we have to force the expansion now. This
6434 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
6437 if Is_Entity_Name
(Exp
)
6438 and then Nkind
(Parent
(Entity
(Exp
))) =
6439 N_Object_Renaming_Declaration
6442 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
6444 if Nkind
(Old_Exp
) = N_Indexed_Component
6445 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
6447 Expand_Packed_Element_Reference
(Old_Exp
);
6452 -- Put back the Do_Range_Check flag on the resulting (possibly
6453 -- rewritten) expression.
6455 -- Note: it might be thought that a validity check is not required
6456 -- when a range check is present, but that's not the case, because
6457 -- the back end is allowed to assume for the range check that the
6458 -- operand is within its declared range (an assumption that validity
6459 -- checking is all about NOT assuming!)
6461 -- Note: no need to worry about Possible_Local_Raise here, it will
6462 -- already have been called if original node has Do_Range_Check set.
6464 Set_Do_Range_Check
(Exp
, DRC
);
6466 end Insert_Valid_Check
;
6468 -------------------------------------
6469 -- Is_Signed_Integer_Arithmetic_Op --
6470 -------------------------------------
6472 function Is_Signed_Integer_Arithmetic_Op
(N
: Node_Id
) return Boolean is
6475 when N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
6476 N_Op_Minus | N_Op_Mod | N_Op_Multiply | N_Op_Plus |
6477 N_Op_Rem | N_Op_Subtract
=>
6478 return Is_Signed_Integer_Type
(Etype
(N
));
6480 when N_If_Expression | N_Case_Expression
=>
6481 return Is_Signed_Integer_Type
(Etype
(N
));
6486 end Is_Signed_Integer_Arithmetic_Op
;
6488 ----------------------------------
6489 -- Install_Null_Excluding_Check --
6490 ----------------------------------
6492 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
6493 Loc
: constant Source_Ptr
:= Sloc
(Parent
(N
));
6494 Typ
: constant Entity_Id
:= Etype
(N
);
6496 function Safe_To_Capture_In_Parameter_Value
return Boolean;
6497 -- Determines if it is safe to capture Known_Non_Null status for an
6498 -- the entity referenced by node N. The caller ensures that N is indeed
6499 -- an entity name. It is safe to capture the non-null status for an IN
6500 -- parameter when the reference occurs within a declaration that is sure
6501 -- to be executed as part of the declarative region.
6503 procedure Mark_Non_Null
;
6504 -- After installation of check, if the node in question is an entity
6505 -- name, then mark this entity as non-null if possible.
6507 function Safe_To_Capture_In_Parameter_Value
return Boolean is
6508 E
: constant Entity_Id
:= Entity
(N
);
6509 S
: constant Entity_Id
:= Current_Scope
;
6513 if Ekind
(E
) /= E_In_Parameter
then
6517 -- Two initial context checks. We must be inside a subprogram body
6518 -- with declarations and reference must not appear in nested scopes.
6520 if (Ekind
(S
) /= E_Function
and then Ekind
(S
) /= E_Procedure
)
6521 or else Scope
(E
) /= S
6526 S_Par
:= Parent
(Parent
(S
));
6528 if Nkind
(S_Par
) /= N_Subprogram_Body
6529 or else No
(Declarations
(S_Par
))
6539 -- Retrieve the declaration node of N (if any). Note that N
6540 -- may be a part of a complex initialization expression.
6544 while Present
(P
) loop
6546 -- If we have a short circuit form, and we are within the right
6547 -- hand expression, we return false, since the right hand side
6548 -- is not guaranteed to be elaborated.
6550 if Nkind
(P
) in N_Short_Circuit
6551 and then N
= Right_Opnd
(P
)
6556 -- Similarly, if we are in an if expression and not part of the
6557 -- condition, then we return False, since neither the THEN or
6558 -- ELSE dependent expressions will always be elaborated.
6560 if Nkind
(P
) = N_If_Expression
6561 and then N
/= First
(Expressions
(P
))
6566 -- If we are in a case expression, and not part of the
6567 -- expression, then we return False, since a particular
6568 -- dependent expression may not always be elaborated
6570 if Nkind
(P
) = N_Case_Expression
6571 and then N
/= Expression
(P
)
6576 -- While traversing the parent chain, we find that N
6577 -- belongs to a statement, thus it may never appear in
6578 -- a declarative region.
6580 if Nkind
(P
) in N_Statement_Other_Than_Procedure_Call
6581 or else Nkind
(P
) = N_Procedure_Call_Statement
6586 -- If we are at a declaration, record it and exit
6588 if Nkind
(P
) in N_Declaration
6589 and then Nkind
(P
) not in N_Subprogram_Specification
6602 return List_Containing
(N_Decl
) = Declarations
(S_Par
);
6604 end Safe_To_Capture_In_Parameter_Value
;
6610 procedure Mark_Non_Null
is
6612 -- Only case of interest is if node N is an entity name
6614 if Is_Entity_Name
(N
) then
6616 -- For sure, we want to clear an indication that this is known to
6617 -- be null, since if we get past this check, it definitely is not!
6619 Set_Is_Known_Null
(Entity
(N
), False);
6621 -- We can mark the entity as known to be non-null if either it is
6622 -- safe to capture the value, or in the case of an IN parameter,
6623 -- which is a constant, if the check we just installed is in the
6624 -- declarative region of the subprogram body. In this latter case,
6625 -- a check is decisive for the rest of the body if the expression
6626 -- is sure to be elaborated, since we know we have to elaborate
6627 -- all declarations before executing the body.
6629 -- Couldn't this always be part of Safe_To_Capture_Value ???
6631 if Safe_To_Capture_Value
(N
, Entity
(N
))
6632 or else Safe_To_Capture_In_Parameter_Value
6634 Set_Is_Known_Non_Null
(Entity
(N
));
6639 -- Start of processing for Install_Null_Excluding_Check
6642 pragma Assert
(Is_Access_Type
(Typ
));
6644 -- No check inside a generic (why not???)
6646 if Inside_A_Generic
then
6650 -- No check needed if known to be non-null
6652 if Known_Non_Null
(N
) then
6656 -- If known to be null, here is where we generate a compile time check
6658 if Known_Null
(N
) then
6660 -- Avoid generating warning message inside init procs
6662 if not Inside_Init_Proc
then
6663 Apply_Compile_Time_Constraint_Error
6665 "null value not allowed here??",
6666 CE_Access_Check_Failed
);
6669 Make_Raise_Constraint_Error
(Loc
,
6670 Reason
=> CE_Access_Check_Failed
));
6677 -- If entity is never assigned, for sure a warning is appropriate
6679 if Is_Entity_Name
(N
) then
6680 Check_Unset_Reference
(N
);
6683 -- No check needed if checks are suppressed on the range. Note that we
6684 -- don't set Is_Known_Non_Null in this case (we could legitimately do
6685 -- so, since the program is erroneous, but we don't like to casually
6686 -- propagate such conclusions from erroneosity).
6688 if Access_Checks_Suppressed
(Typ
) then
6692 -- No check needed for access to concurrent record types generated by
6693 -- the expander. This is not just an optimization (though it does indeed
6694 -- remove junk checks). It also avoids generation of junk warnings.
6696 if Nkind
(N
) in N_Has_Chars
6697 and then Chars
(N
) = Name_uObject
6698 and then Is_Concurrent_Record_Type
6699 (Directly_Designated_Type
(Etype
(N
)))
6704 -- No check needed in interface thunks since the runtime check is
6705 -- already performed at the caller side.
6707 if Is_Thunk
(Current_Scope
) then
6711 -- No check needed for the Get_Current_Excep.all.all idiom generated by
6712 -- the expander within exception handlers, since we know that the value
6713 -- can never be null.
6715 -- Is this really the right way to do this? Normally we generate such
6716 -- code in the expander with checks off, and that's how we suppress this
6717 -- kind of junk check ???
6719 if Nkind
(N
) = N_Function_Call
6720 and then Nkind
(Name
(N
)) = N_Explicit_Dereference
6721 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
6722 and then Is_RTE
(Entity
(Prefix
(Name
(N
))), RE_Get_Current_Excep
)
6727 -- Otherwise install access check
6730 Make_Raise_Constraint_Error
(Loc
,
6733 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
6734 Right_Opnd
=> Make_Null
(Loc
)),
6735 Reason
=> CE_Access_Check_Failed
));
6738 end Install_Null_Excluding_Check
;
6740 --------------------------
6741 -- Install_Static_Check --
6742 --------------------------
6744 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
6745 Stat
: constant Boolean := Is_Static_Expression
(R_Cno
);
6746 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
6750 Make_Raise_Constraint_Error
(Loc
,
6751 Reason
=> CE_Range_Check_Failed
));
6752 Set_Analyzed
(R_Cno
);
6753 Set_Etype
(R_Cno
, Typ
);
6754 Set_Raises_Constraint_Error
(R_Cno
);
6755 Set_Is_Static_Expression
(R_Cno
, Stat
);
6757 -- Now deal with possible local raise handling
6759 Possible_Local_Raise
(R_Cno
, Standard_Constraint_Error
);
6760 end Install_Static_Check
;
6762 -------------------------
6763 -- Is_Check_Suppressed --
6764 -------------------------
6766 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
6767 Ptr
: Suppress_Stack_Entry_Ptr
;
6770 -- First search the local entity suppress stack. We search this from the
6771 -- top of the stack down so that we get the innermost entry that applies
6772 -- to this case if there are nested entries.
6774 Ptr
:= Local_Suppress_Stack_Top
;
6775 while Ptr
/= null loop
6776 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
6777 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
6779 return Ptr
.Suppress
;
6785 -- Now search the global entity suppress table for a matching entry.
6786 -- We also search this from the top down so that if there are multiple
6787 -- pragmas for the same entity, the last one applies (not clear what
6788 -- or whether the RM specifies this handling, but it seems reasonable).
6790 Ptr
:= Global_Suppress_Stack_Top
;
6791 while Ptr
/= null loop
6792 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
6793 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
6795 return Ptr
.Suppress
;
6801 -- If we did not find a matching entry, then use the normal scope
6802 -- suppress value after all (actually this will be the global setting
6803 -- since it clearly was not overridden at any point). For a predefined
6804 -- check, we test the specific flag. For a user defined check, we check
6805 -- the All_Checks flag. The Overflow flag requires special handling to
6806 -- deal with the General vs Assertion case
6808 if C
= Overflow_Check
then
6809 return Overflow_Checks_Suppressed
(Empty
);
6810 elsif C
in Predefined_Check_Id
then
6811 return Scope_Suppress
.Suppress
(C
);
6813 return Scope_Suppress
.Suppress
(All_Checks
);
6815 end Is_Check_Suppressed
;
6817 ---------------------
6818 -- Kill_All_Checks --
6819 ---------------------
6821 procedure Kill_All_Checks
is
6823 if Debug_Flag_CC
then
6824 w
("Kill_All_Checks");
6827 -- We reset the number of saved checks to zero, and also modify all
6828 -- stack entries for statement ranges to indicate that the number of
6829 -- checks at each level is now zero.
6831 Num_Saved_Checks
:= 0;
6833 -- Note: the Int'Min here avoids any possibility of J being out of
6834 -- range when called from e.g. Conditional_Statements_Begin.
6836 for J
in 1 .. Int
'Min (Saved_Checks_TOS
, Saved_Checks_Stack
'Last) loop
6837 Saved_Checks_Stack
(J
) := 0;
6839 end Kill_All_Checks
;
6845 procedure Kill_Checks
(V
: Entity_Id
) is
6847 if Debug_Flag_CC
then
6848 w
("Kill_Checks for entity", Int
(V
));
6851 for J
in 1 .. Num_Saved_Checks
loop
6852 if Saved_Checks
(J
).Entity
= V
then
6853 if Debug_Flag_CC
then
6854 w
(" Checks killed for saved check ", J
);
6857 Saved_Checks
(J
).Killed
:= True;
6862 ------------------------------
6863 -- Length_Checks_Suppressed --
6864 ------------------------------
6866 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6868 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6869 return Is_Check_Suppressed
(E
, Length_Check
);
6871 return Scope_Suppress
.Suppress
(Length_Check
);
6873 end Length_Checks_Suppressed
;
6875 -----------------------
6876 -- Make_Bignum_Block --
6877 -----------------------
6879 function Make_Bignum_Block
(Loc
: Source_Ptr
) return Node_Id
is
6880 M
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_uM
);
6884 Make_Block_Statement
(Loc
,
6885 Declarations
=> New_List
(
6886 Make_Object_Declaration
(Loc
,
6887 Defining_Identifier
=> M
,
6888 Object_Definition
=>
6889 New_Occurrence_Of
(RTE
(RE_Mark_Id
), Loc
),
6891 Make_Function_Call
(Loc
,
6892 Name
=> New_Reference_To
(RTE
(RE_SS_Mark
), Loc
)))),
6894 Handled_Statement_Sequence
=>
6895 Make_Handled_Sequence_Of_Statements
(Loc
,
6896 Statements
=> New_List
(
6897 Make_Procedure_Call_Statement
(Loc
,
6898 Name
=> New_Occurrence_Of
(RTE
(RE_SS_Release
), Loc
),
6899 Parameter_Associations
=> New_List
(
6900 New_Reference_To
(M
, Loc
))))));
6901 end Make_Bignum_Block
;
6903 ----------------------------------
6904 -- Minimize_Eliminate_Overflows --
6905 ----------------------------------
6907 -- This is a recursive routine that is called at the top of an expression
6908 -- tree to properly process overflow checking for a whole subtree by making
6909 -- recursive calls to process operands. This processing may involve the use
6910 -- of bignum or long long integer arithmetic, which will change the types
6911 -- of operands and results. That's why we can't do this bottom up (since
6912 -- it would interfere with semantic analysis).
6914 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
6915 -- the operator expansion routines, as well as the expansion routines for
6916 -- if/case expression, do nothing (for the moment) except call the routine
6917 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
6918 -- routine does nothing for non top-level nodes, so at the point where the
6919 -- call is made for the top level node, the entire expression subtree has
6920 -- not been expanded, or processed for overflow. All that has to happen as
6921 -- a result of the top level call to this routine.
6923 -- As noted above, the overflow processing works by making recursive calls
6924 -- for the operands, and figuring out what to do, based on the processing
6925 -- of these operands (e.g. if a bignum operand appears, the parent op has
6926 -- to be done in bignum mode), and the determined ranges of the operands.
6928 -- After possible rewriting of a constituent subexpression node, a call is
6929 -- made to either reexpand the node (if nothing has changed) or reanalyze
6930 -- the node (if it has been modified by the overflow check processing). The
6931 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
6932 -- a recursive call into the whole overflow apparatus, an important rule
6933 -- for this call is that the overflow handling mode must be temporarily set
6936 procedure Minimize_Eliminate_Overflows
6940 Top_Level
: Boolean)
6942 Rtyp
: constant Entity_Id
:= Etype
(N
);
6943 pragma Assert
(Is_Signed_Integer_Type
(Rtyp
));
6944 -- Result type, must be a signed integer type
6946 Check_Mode
: constant Overflow_Mode_Type
:= Overflow_Check_Mode
;
6947 pragma Assert
(Check_Mode
in Minimized_Or_Eliminated
);
6949 Loc
: constant Source_Ptr
:= Sloc
(N
);
6952 -- Ranges of values for right operand (operator case)
6955 -- Ranges of values for left operand (operator case)
6957 LLIB
: constant Entity_Id
:= Base_Type
(Standard_Long_Long_Integer
);
6958 -- Operands and results are of this type when we convert
6960 LLLo
: constant Uint
:= Intval
(Type_Low_Bound
(LLIB
));
6961 LLHi
: constant Uint
:= Intval
(Type_High_Bound
(LLIB
));
6962 -- Bounds of Long_Long_Integer
6964 Binary
: constant Boolean := Nkind
(N
) in N_Binary_Op
;
6965 -- Indicates binary operator case
6968 -- Used in call to Determine_Range
6970 Bignum_Operands
: Boolean;
6971 -- Set True if one or more operands is already of type Bignum, meaning
6972 -- that for sure (regardless of Top_Level setting) we are committed to
6973 -- doing the operation in Bignum mode (or in the case of a case or if
6974 -- expression, converting all the dependent expressions to Bignum).
6976 Long_Long_Integer_Operands
: Boolean;
6977 -- Set True if one or more operands is already of type Long_Long_Integer
6978 -- which means that if the result is known to be in the result type
6979 -- range, then we must convert such operands back to the result type.
6981 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False);
6982 -- This is called when we have modified the node and we therefore need
6983 -- to reanalyze it. It is important that we reset the mode to STRICT for
6984 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
6985 -- we would reenter this routine recursively which would not be good!
6986 -- The argument Suppress is set True if we also want to suppress
6987 -- overflow checking for the reexpansion (this is set when we know
6988 -- overflow is not possible). Typ is the type for the reanalysis.
6990 procedure Reexpand
(Suppress
: Boolean := False);
6991 -- This is like Reanalyze, but does not do the Analyze step, it only
6992 -- does a reexpansion. We do this reexpansion in STRICT mode, so that
6993 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
6994 -- follow the normal expansion path (e.g. converting A**4 to A**2**2).
6995 -- Note that skipping reanalysis is not just an optimization, testing
6996 -- has showed up several complex cases in which reanalyzing an already
6997 -- analyzed node causes incorrect behavior.
6999 function In_Result_Range
return Boolean;
7000 -- Returns True iff Lo .. Hi are within range of the result type
7002 procedure Max
(A
: in out Uint
; B
: Uint
);
7003 -- If A is No_Uint, sets A to B, else to UI_Max (A, B)
7005 procedure Min
(A
: in out Uint
; B
: Uint
);
7006 -- If A is No_Uint, sets A to B, else to UI_Min (A, B)
7008 ---------------------
7009 -- In_Result_Range --
7010 ---------------------
7012 function In_Result_Range
return Boolean is
7014 if Lo
= No_Uint
or else Hi
= No_Uint
then
7017 elsif Is_Static_Subtype
(Etype
(N
)) then
7018 return Lo
>= Expr_Value
(Type_Low_Bound
(Rtyp
))
7020 Hi
<= Expr_Value
(Type_High_Bound
(Rtyp
));
7023 return Lo
>= Expr_Value
(Type_Low_Bound
(Base_Type
(Rtyp
)))
7025 Hi
<= Expr_Value
(Type_High_Bound
(Base_Type
(Rtyp
)));
7027 end In_Result_Range
;
7033 procedure Max
(A
: in out Uint
; B
: Uint
) is
7035 if A
= No_Uint
or else B
> A
then
7044 procedure Min
(A
: in out Uint
; B
: Uint
) is
7046 if A
= No_Uint
or else B
< A
then
7055 procedure Reanalyze
(Typ
: Entity_Id
; Suppress
: Boolean := False) is
7056 Svg
: constant Overflow_Mode_Type
:=
7057 Scope_Suppress
.Overflow_Mode_General
;
7058 Sva
: constant Overflow_Mode_Type
:=
7059 Scope_Suppress
.Overflow_Mode_Assertions
;
7060 Svo
: constant Boolean :=
7061 Scope_Suppress
.Suppress
(Overflow_Check
);
7064 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7065 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7068 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
7071 Analyze_And_Resolve
(N
, Typ
);
7073 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
7074 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
7075 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
7082 procedure Reexpand
(Suppress
: Boolean := False) is
7083 Svg
: constant Overflow_Mode_Type
:=
7084 Scope_Suppress
.Overflow_Mode_General
;
7085 Sva
: constant Overflow_Mode_Type
:=
7086 Scope_Suppress
.Overflow_Mode_Assertions
;
7087 Svo
: constant Boolean :=
7088 Scope_Suppress
.Suppress
(Overflow_Check
);
7091 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7092 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7093 Set_Analyzed
(N
, False);
7096 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
7101 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
7102 Scope_Suppress
.Overflow_Mode_General
:= Svg
;
7103 Scope_Suppress
.Overflow_Mode_Assertions
:= Sva
;
7106 -- Start of processing for Minimize_Eliminate_Overflows
7109 -- Case where we do not have a signed integer arithmetic operation
7111 if not Is_Signed_Integer_Arithmetic_Op
(N
) then
7113 -- Use the normal Determine_Range routine to get the range. We
7114 -- don't require operands to be valid, invalid values may result in
7115 -- rubbish results where the result has not been properly checked for
7116 -- overflow, that's fine!
7118 Determine_Range
(N
, OK
, Lo
, Hi
, Assume_Valid
=> False);
7120 -- If Determine_Range did not work (can this in fact happen? Not
7121 -- clear but might as well protect), use type bounds.
7124 Lo
:= Intval
(Type_Low_Bound
(Base_Type
(Etype
(N
))));
7125 Hi
:= Intval
(Type_High_Bound
(Base_Type
(Etype
(N
))));
7128 -- If we don't have a binary operator, all we have to do is to set
7129 -- the Hi/Lo range, so we are done
7133 -- Processing for if expression
7135 elsif Nkind
(N
) = N_If_Expression
then
7137 Then_DE
: constant Node_Id
:= Next
(First
(Expressions
(N
)));
7138 Else_DE
: constant Node_Id
:= Next
(Then_DE
);
7141 Bignum_Operands
:= False;
7143 Minimize_Eliminate_Overflows
7144 (Then_DE
, Lo
, Hi
, Top_Level
=> False);
7146 if Lo
= No_Uint
then
7147 Bignum_Operands
:= True;
7150 Minimize_Eliminate_Overflows
7151 (Else_DE
, Rlo
, Rhi
, Top_Level
=> False);
7153 if Rlo
= No_Uint
then
7154 Bignum_Operands
:= True;
7156 Long_Long_Integer_Operands
:=
7157 Etype
(Then_DE
) = LLIB
or else Etype
(Else_DE
) = LLIB
;
7163 -- If at least one of our operands is now Bignum, we must rebuild
7164 -- the if expression to use Bignum operands. We will analyze the
7165 -- rebuilt if expression with overflow checks off, since once we
7166 -- are in bignum mode, we are all done with overflow checks!
7168 if Bignum_Operands
then
7170 Make_If_Expression
(Loc
,
7171 Expressions
=> New_List
(
7172 Remove_Head
(Expressions
(N
)),
7173 Convert_To_Bignum
(Then_DE
),
7174 Convert_To_Bignum
(Else_DE
)),
7175 Is_Elsif
=> Is_Elsif
(N
)));
7177 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
7179 -- If we have no Long_Long_Integer operands, then we are in result
7180 -- range, since it means that none of our operands felt the need
7181 -- to worry about overflow (otherwise it would have already been
7182 -- converted to long long integer or bignum). We reexpand to
7183 -- complete the expansion of the if expression (but we do not
7184 -- need to reanalyze).
7186 elsif not Long_Long_Integer_Operands
then
7187 Set_Do_Overflow_Check
(N
, False);
7190 -- Otherwise convert us to long long integer mode. Note that we
7191 -- don't need any further overflow checking at this level.
7194 Convert_To_And_Rewrite
(LLIB
, Then_DE
);
7195 Convert_To_And_Rewrite
(LLIB
, Else_DE
);
7196 Set_Etype
(N
, LLIB
);
7198 -- Now reanalyze with overflow checks off
7200 Set_Do_Overflow_Check
(N
, False);
7201 Reanalyze
(LLIB
, Suppress
=> True);
7207 -- Here for case expression
7209 elsif Nkind
(N
) = N_Case_Expression
then
7210 Bignum_Operands
:= False;
7211 Long_Long_Integer_Operands
:= False;
7217 -- Loop through expressions applying recursive call
7219 Alt
:= First
(Alternatives
(N
));
7220 while Present
(Alt
) loop
7222 Aexp
: constant Node_Id
:= Expression
(Alt
);
7225 Minimize_Eliminate_Overflows
7226 (Aexp
, Lo
, Hi
, Top_Level
=> False);
7228 if Lo
= No_Uint
then
7229 Bignum_Operands
:= True;
7230 elsif Etype
(Aexp
) = LLIB
then
7231 Long_Long_Integer_Operands
:= True;
7238 -- If we have no bignum or long long integer operands, it means
7239 -- that none of our dependent expressions could raise overflow.
7240 -- In this case, we simply return with no changes except for
7241 -- resetting the overflow flag, since we are done with overflow
7242 -- checks for this node. We will reexpand to get the needed
7243 -- expansion for the case expression, but we do not need to
7244 -- reanalyze, since nothing has changed.
7246 if not (Bignum_Operands
or Long_Long_Integer_Operands
) then
7247 Set_Do_Overflow_Check
(N
, False);
7248 Reexpand
(Suppress
=> True);
7250 -- Otherwise we are going to rebuild the case expression using
7251 -- either bignum or long long integer operands throughout.
7260 New_Alts
:= New_List
;
7261 Alt
:= First
(Alternatives
(N
));
7262 while Present
(Alt
) loop
7263 if Bignum_Operands
then
7264 New_Exp
:= Convert_To_Bignum
(Expression
(Alt
));
7265 Rtype
:= RTE
(RE_Bignum
);
7267 New_Exp
:= Convert_To
(LLIB
, Expression
(Alt
));
7271 Append_To
(New_Alts
,
7272 Make_Case_Expression_Alternative
(Sloc
(Alt
),
7274 Discrete_Choices
=> Discrete_Choices
(Alt
),
7275 Expression
=> New_Exp
));
7281 Make_Case_Expression
(Loc
,
7282 Expression
=> Expression
(N
),
7283 Alternatives
=> New_Alts
));
7285 Reanalyze
(Rtype
, Suppress
=> True);
7293 -- If we have an arithmetic operator we make recursive calls on the
7294 -- operands to get the ranges (and to properly process the subtree
7295 -- that lies below us!)
7297 Minimize_Eliminate_Overflows
7298 (Right_Opnd
(N
), Rlo
, Rhi
, Top_Level
=> False);
7301 Minimize_Eliminate_Overflows
7302 (Left_Opnd
(N
), Llo
, Lhi
, Top_Level
=> False);
7305 -- Record if we have Long_Long_Integer operands
7307 Long_Long_Integer_Operands
:=
7308 Etype
(Right_Opnd
(N
)) = LLIB
7309 or else (Binary
and then Etype
(Left_Opnd
(N
)) = LLIB
);
7311 -- If either operand is a bignum, then result will be a bignum and we
7312 -- don't need to do any range analysis. As previously discussed we could
7313 -- do range analysis in such cases, but it could mean working with giant
7314 -- numbers at compile time for very little gain (the number of cases
7315 -- in which we could slip back from bignum mode is small).
7317 if Rlo
= No_Uint
or else (Binary
and then Llo
= No_Uint
) then
7320 Bignum_Operands
:= True;
7322 -- Otherwise compute result range
7325 Bignum_Operands
:= False;
7333 Hi
:= UI_Max
(abs Rlo
, abs Rhi
);
7345 -- If the right operand can only be zero, set 0..0
7347 if Rlo
= 0 and then Rhi
= 0 then
7351 -- Possible bounds of division must come from dividing end
7352 -- values of the input ranges (four possibilities), provided
7353 -- zero is not included in the possible values of the right
7356 -- Otherwise, we just consider two intervals of values for
7357 -- the right operand: the interval of negative values (up to
7358 -- -1) and the interval of positive values (starting at 1).
7359 -- Since division by 1 is the identity, and division by -1
7360 -- is negation, we get all possible bounds of division in that
7361 -- case by considering:
7362 -- - all values from the division of end values of input
7364 -- - the end values of the left operand;
7365 -- - the negation of the end values of the left operand.
7369 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
7370 -- Mark so we can release the RR and Ev values
7378 -- Discard extreme values of zero for the divisor, since
7379 -- they will simply result in an exception in any case.
7387 -- Compute possible bounds coming from dividing end
7388 -- values of the input ranges.
7395 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
7396 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
7398 -- If the right operand can be both negative or positive,
7399 -- include the end values of the left operand in the
7400 -- extreme values, as well as their negation.
7402 if Rlo
< 0 and then Rhi
> 0 then
7409 UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
)));
7411 UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
)));
7414 -- Release the RR and Ev values
7416 Release_And_Save
(Mrk
, Lo
, Hi
);
7424 -- Discard negative values for the exponent, since they will
7425 -- simply result in an exception in any case.
7433 -- Estimate number of bits in result before we go computing
7434 -- giant useless bounds. Basically the number of bits in the
7435 -- result is the number of bits in the base multiplied by the
7436 -- value of the exponent. If this is big enough that the result
7437 -- definitely won't fit in Long_Long_Integer, switch to bignum
7438 -- mode immediately, and avoid computing giant bounds.
7440 -- The comparison here is approximate, but conservative, it
7441 -- only clicks on cases that are sure to exceed the bounds.
7443 if Num_Bits
(UI_Max
(abs Llo
, abs Lhi
)) * Rhi
+ 1 > 100 then
7447 -- If right operand is zero then result is 1
7454 -- High bound comes either from exponentiation of largest
7455 -- positive value to largest exponent value, or from
7456 -- the exponentiation of most negative value to an
7470 if Rhi
mod 2 = 0 then
7473 Hi2
:= Llo
** (Rhi
- 1);
7479 Hi
:= UI_Max
(Hi1
, Hi2
);
7482 -- Result can only be negative if base can be negative
7485 if Rhi
mod 2 = 0 then
7486 Lo
:= Llo
** (Rhi
- 1);
7491 -- Otherwise low bound is minimum ** minimum
7508 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
7509 -- This is the maximum absolute value of the result
7515 -- The result depends only on the sign and magnitude of
7516 -- the right operand, it does not depend on the sign or
7517 -- magnitude of the left operand.
7530 when N_Op_Multiply
=>
7532 -- Possible bounds of multiplication must come from multiplying
7533 -- end values of the input ranges (four possibilities).
7536 Mrk
: constant Uintp
.Save_Mark
:= Mark
;
7537 -- Mark so we can release the Ev values
7539 Ev1
: constant Uint
:= Llo
* Rlo
;
7540 Ev2
: constant Uint
:= Llo
* Rhi
;
7541 Ev3
: constant Uint
:= Lhi
* Rlo
;
7542 Ev4
: constant Uint
:= Lhi
* Rhi
;
7545 Lo
:= UI_Min
(UI_Min
(Ev1
, Ev2
), UI_Min
(Ev3
, Ev4
));
7546 Hi
:= UI_Max
(UI_Max
(Ev1
, Ev2
), UI_Max
(Ev3
, Ev4
));
7548 -- Release the Ev values
7550 Release_And_Save
(Mrk
, Lo
, Hi
);
7553 -- Plus operator (affirmation)
7563 Maxabs
: constant Uint
:= UI_Max
(abs Rlo
, abs Rhi
) - 1;
7564 -- This is the maximum absolute value of the result. Note
7565 -- that the result range does not depend on the sign of the
7572 -- Case of left operand negative, which results in a range
7573 -- of -Maxabs .. 0 for those negative values. If there are
7574 -- no negative values then Lo value of result is always 0.
7580 -- Case of left operand positive
7589 when N_Op_Subtract
=>
7593 -- Nothing else should be possible
7596 raise Program_Error
;
7600 -- Here for the case where we have not rewritten anything (no bignum
7601 -- operands or long long integer operands), and we know the result.
7602 -- If we know we are in the result range, and we do not have Bignum
7603 -- operands or Long_Long_Integer operands, we can just reexpand with
7604 -- overflow checks turned off (since we know we cannot have overflow).
7605 -- As always the reexpansion is required to complete expansion of the
7606 -- operator, but we do not need to reanalyze, and we prevent recursion
7607 -- by suppressing the check.
7609 if not (Bignum_Operands
or Long_Long_Integer_Operands
)
7610 and then In_Result_Range
7612 Set_Do_Overflow_Check
(N
, False);
7613 Reexpand
(Suppress
=> True);
7616 -- Here we know that we are not in the result range, and in the general
7617 -- case we will move into either the Bignum or Long_Long_Integer domain
7618 -- to compute the result. However, there is one exception. If we are
7619 -- at the top level, and we do not have Bignum or Long_Long_Integer
7620 -- operands, we will have to immediately convert the result back to
7621 -- the result type, so there is no point in Bignum/Long_Long_Integer
7625 and then not (Bignum_Operands
or Long_Long_Integer_Operands
)
7627 -- One further refinement. If we are at the top level, but our parent
7628 -- is a type conversion, then go into bignum or long long integer node
7629 -- since the result will be converted to that type directly without
7630 -- going through the result type, and we may avoid an overflow. This
7631 -- is the case for example of Long_Long_Integer (A ** 4), where A is
7632 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer
7633 -- but does not fit in Integer.
7635 and then Nkind
(Parent
(N
)) /= N_Type_Conversion
7637 -- Here keep original types, but we need to complete analysis
7639 -- One subtlety. We can't just go ahead and do an analyze operation
7640 -- here because it will cause recursion into the whole MINIMIZED/
7641 -- ELIMINATED overflow processing which is not what we want. Here
7642 -- we are at the top level, and we need a check against the result
7643 -- mode (i.e. we want to use STRICT mode). So do exactly that!
7644 -- Also, we have not modified the node, so this is a case where
7645 -- we need to reexpand, but not reanalyze.
7650 -- Cases where we do the operation in Bignum mode. This happens either
7651 -- because one of our operands is in Bignum mode already, or because
7652 -- the computed bounds are outside the bounds of Long_Long_Integer,
7653 -- which in some cases can be indicated by Hi and Lo being No_Uint.
7655 -- Note: we could do better here and in some cases switch back from
7656 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range
7657 -- 0 .. 1, but the cases are rare and it is not worth the effort.
7658 -- Failing to do this switching back is only an efficiency issue.
7660 elsif Lo
= No_Uint
or else Lo
< LLLo
or else Hi
> LLHi
then
7662 -- OK, we are definitely outside the range of Long_Long_Integer. The
7663 -- question is whether to move to Bignum mode, or stay in the domain
7664 -- of Long_Long_Integer, signalling that an overflow check is needed.
7666 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in
7667 -- the Bignum business. In ELIMINATED mode, we will normally move
7668 -- into Bignum mode, but there is an exception if neither of our
7669 -- operands is Bignum now, and we are at the top level (Top_Level
7670 -- set True). In this case, there is no point in moving into Bignum
7671 -- mode to prevent overflow if the caller will immediately convert
7672 -- the Bignum value back to LLI with an overflow check. It's more
7673 -- efficient to stay in LLI mode with an overflow check (if needed)
7675 if Check_Mode
= Minimized
7676 or else (Top_Level
and not Bignum_Operands
)
7678 if Do_Overflow_Check
(N
) then
7679 Enable_Overflow_Check
(N
);
7682 -- The result now has to be in Long_Long_Integer mode, so adjust
7683 -- the possible range to reflect this. Note these calls also
7684 -- change No_Uint values from the top level case to LLI bounds.
7689 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode
7692 pragma Assert
(Check_Mode
= Eliminated
);
7701 Fent
:= RTE
(RE_Big_Abs
);
7704 Fent
:= RTE
(RE_Big_Add
);
7707 Fent
:= RTE
(RE_Big_Div
);
7710 Fent
:= RTE
(RE_Big_Exp
);
7713 Fent
:= RTE
(RE_Big_Neg
);
7716 Fent
:= RTE
(RE_Big_Mod
);
7718 when N_Op_Multiply
=>
7719 Fent
:= RTE
(RE_Big_Mul
);
7722 Fent
:= RTE
(RE_Big_Rem
);
7724 when N_Op_Subtract
=>
7725 Fent
:= RTE
(RE_Big_Sub
);
7727 -- Anything else is an internal error, this includes the
7728 -- N_Op_Plus case, since how can plus cause the result
7729 -- to be out of range if the operand is in range?
7732 raise Program_Error
;
7735 -- Construct argument list for Bignum call, converting our
7736 -- operands to Bignum form if they are not already there.
7741 Append_To
(Args
, Convert_To_Bignum
(Left_Opnd
(N
)));
7744 Append_To
(Args
, Convert_To_Bignum
(Right_Opnd
(N
)));
7746 -- Now rewrite the arithmetic operator with a call to the
7747 -- corresponding bignum function.
7750 Make_Function_Call
(Loc
,
7751 Name
=> New_Occurrence_Of
(Fent
, Loc
),
7752 Parameter_Associations
=> Args
));
7753 Reanalyze
(RTE
(RE_Bignum
), Suppress
=> True);
7755 -- Indicate result is Bignum mode
7763 -- Otherwise we are in range of Long_Long_Integer, so no overflow
7764 -- check is required, at least not yet.
7767 Set_Do_Overflow_Check
(N
, False);
7770 -- Here we are not in Bignum territory, but we may have long long
7771 -- integer operands that need special handling. First a special check:
7772 -- If an exponentiation operator exponent is of type Long_Long_Integer,
7773 -- it means we converted it to prevent overflow, but exponentiation
7774 -- requires a Natural right operand, so convert it back to Natural.
7775 -- This conversion may raise an exception which is fine.
7777 if Nkind
(N
) = N_Op_Expon
and then Etype
(Right_Opnd
(N
)) = LLIB
then
7778 Convert_To_And_Rewrite
(Standard_Natural
, Right_Opnd
(N
));
7781 -- Here we will do the operation in Long_Long_Integer. We do this even
7782 -- if we know an overflow check is required, better to do this in long
7783 -- long integer mode, since we are less likely to overflow!
7785 -- Convert right or only operand to Long_Long_Integer, except that
7786 -- we do not touch the exponentiation right operand.
7788 if Nkind
(N
) /= N_Op_Expon
then
7789 Convert_To_And_Rewrite
(LLIB
, Right_Opnd
(N
));
7792 -- Convert left operand to Long_Long_Integer for binary case
7795 Convert_To_And_Rewrite
(LLIB
, Left_Opnd
(N
));
7798 -- Reset node to unanalyzed
7800 Set_Analyzed
(N
, False);
7801 Set_Etype
(N
, Empty
);
7802 Set_Entity
(N
, Empty
);
7804 -- Now analyze this new node. This reanalysis will complete processing
7805 -- for the node. In particular we will complete the expansion of an
7806 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also
7807 -- we will complete any division checks (since we have not changed the
7808 -- setting of the Do_Division_Check flag).
7810 -- We do this reanalysis in STRICT mode to avoid recursion into the
7811 -- MINIMIZED/ELIMINATED handling, since we are now done with that!
7814 SG
: constant Overflow_Mode_Type
:=
7815 Scope_Suppress
.Overflow_Mode_General
;
7816 SA
: constant Overflow_Mode_Type
:=
7817 Scope_Suppress
.Overflow_Mode_Assertions
;
7820 Scope_Suppress
.Overflow_Mode_General
:= Strict
;
7821 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
7823 if not Do_Overflow_Check
(N
) then
7824 Reanalyze
(LLIB
, Suppress
=> True);
7829 Scope_Suppress
.Overflow_Mode_General
:= SG
;
7830 Scope_Suppress
.Overflow_Mode_Assertions
:= SA
;
7832 end Minimize_Eliminate_Overflows
;
7834 -------------------------
7835 -- Overflow_Check_Mode --
7836 -------------------------
7838 function Overflow_Check_Mode
return Overflow_Mode_Type
is
7840 if In_Assertion_Expr
= 0 then
7841 return Scope_Suppress
.Overflow_Mode_General
;
7843 return Scope_Suppress
.Overflow_Mode_Assertions
;
7845 end Overflow_Check_Mode
;
7847 --------------------------------
7848 -- Overflow_Checks_Suppressed --
7849 --------------------------------
7851 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7853 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7854 return Is_Check_Suppressed
(E
, Overflow_Check
);
7856 return Scope_Suppress
.Suppress
(Overflow_Check
);
7858 end Overflow_Checks_Suppressed
;
7860 ---------------------------------
7861 -- Predicate_Checks_Suppressed --
7862 ---------------------------------
7864 function Predicate_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7866 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
7867 return Is_Check_Suppressed
(E
, Predicate_Check
);
7869 return Scope_Suppress
.Suppress
(Predicate_Check
);
7871 end Predicate_Checks_Suppressed
;
7873 -----------------------------
7874 -- Range_Checks_Suppressed --
7875 -----------------------------
7877 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
7881 -- Note: for now we always suppress range checks on Vax float types,
7882 -- since Gigi does not know how to generate these checks.
7884 if Vax_Float
(E
) then
7886 elsif Kill_Range_Checks
(E
) then
7888 elsif Checks_May_Be_Suppressed
(E
) then
7889 return Is_Check_Suppressed
(E
, Range_Check
);
7893 return Scope_Suppress
.Suppress
(Range_Check
);
7894 end Range_Checks_Suppressed
;
7896 -----------------------------------------
7897 -- Range_Or_Validity_Checks_Suppressed --
7898 -----------------------------------------
7900 -- Note: the coding would be simpler here if we simply made appropriate
7901 -- calls to Range/Validity_Checks_Suppressed, but that would result in
7902 -- duplicated checks which we prefer to avoid.
7904 function Range_Or_Validity_Checks_Suppressed
7905 (Expr
: Node_Id
) return Boolean
7908 -- Immediate return if scope checks suppressed for either check
7910 if Scope_Suppress
.Suppress
(Range_Check
)
7912 Scope_Suppress
.Suppress
(Validity_Check
)
7917 -- If no expression, that's odd, decide that checks are suppressed,
7918 -- since we don't want anyone trying to do checks in this case, which
7919 -- is most likely the result of some other error.
7925 -- Expression is present, so perform suppress checks on type
7928 Typ
: constant Entity_Id
:= Etype
(Expr
);
7930 if Vax_Float
(Typ
) then
7932 elsif Checks_May_Be_Suppressed
(Typ
)
7933 and then (Is_Check_Suppressed
(Typ
, Range_Check
)
7935 Is_Check_Suppressed
(Typ
, Validity_Check
))
7941 -- If expression is an entity name, perform checks on this entity
7943 if Is_Entity_Name
(Expr
) then
7945 Ent
: constant Entity_Id
:= Entity
(Expr
);
7947 if Checks_May_Be_Suppressed
(Ent
) then
7948 return Is_Check_Suppressed
(Ent
, Range_Check
)
7949 or else Is_Check_Suppressed
(Ent
, Validity_Check
);
7954 -- If we fall through, no checks suppressed
7957 end Range_Or_Validity_Checks_Suppressed
;
7963 procedure Remove_Checks
(Expr
: Node_Id
) is
7964 function Process
(N
: Node_Id
) return Traverse_Result
;
7965 -- Process a single node during the traversal
7967 procedure Traverse
is new Traverse_Proc
(Process
);
7968 -- The traversal procedure itself
7974 function Process
(N
: Node_Id
) return Traverse_Result
is
7976 if Nkind
(N
) not in N_Subexpr
then
7980 Set_Do_Range_Check
(N
, False);
7984 Traverse
(Left_Opnd
(N
));
7987 when N_Attribute_Reference
=>
7988 Set_Do_Overflow_Check
(N
, False);
7990 when N_Function_Call
=>
7991 Set_Do_Tag_Check
(N
, False);
7994 Set_Do_Overflow_Check
(N
, False);
7998 Set_Do_Division_Check
(N
, False);
8001 Set_Do_Length_Check
(N
, False);
8004 Set_Do_Division_Check
(N
, False);
8007 Set_Do_Length_Check
(N
, False);
8010 Set_Do_Division_Check
(N
, False);
8013 Set_Do_Length_Check
(N
, False);
8020 Traverse
(Left_Opnd
(N
));
8023 when N_Selected_Component
=>
8024 Set_Do_Discriminant_Check
(N
, False);
8026 when N_Type_Conversion
=>
8027 Set_Do_Length_Check
(N
, False);
8028 Set_Do_Tag_Check
(N
, False);
8029 Set_Do_Overflow_Check
(N
, False);
8038 -- Start of processing for Remove_Checks
8044 ----------------------------
8045 -- Selected_Length_Checks --
8046 ----------------------------
8048 function Selected_Length_Checks
8050 Target_Typ
: Entity_Id
;
8051 Source_Typ
: Entity_Id
;
8052 Warn_Node
: Node_Id
) return Check_Result
8054 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
8057 Expr_Actual
: Node_Id
;
8059 Cond
: Node_Id
:= Empty
;
8060 Do_Access
: Boolean := False;
8061 Wnode
: Node_Id
:= Warn_Node
;
8062 Ret_Result
: Check_Result
:= (Empty
, Empty
);
8063 Num_Checks
: Natural := 0;
8065 procedure Add_Check
(N
: Node_Id
);
8066 -- Adds the action given to Ret_Result if N is non-Empty
8068 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
8069 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8070 -- Comments required ???
8072 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
8073 -- True for equal literals and for nodes that denote the same constant
8074 -- entity, even if its value is not a static constant. This includes the
8075 -- case of a discriminal reference within an init proc. Removes some
8076 -- obviously superfluous checks.
8078 function Length_E_Cond
8079 (Exptyp
: Entity_Id
;
8081 Indx
: Nat
) return Node_Id
;
8082 -- Returns expression to compute:
8083 -- Typ'Length /= Exptyp'Length
8085 function Length_N_Cond
8088 Indx
: Nat
) return Node_Id
;
8089 -- Returns expression to compute:
8090 -- Typ'Length /= Expr'Length
8096 procedure Add_Check
(N
: Node_Id
) is
8100 -- For now, ignore attempt to place more than 2 checks ???
8102 if Num_Checks
= 2 then
8106 pragma Assert
(Num_Checks
<= 1);
8107 Num_Checks
:= Num_Checks
+ 1;
8108 Ret_Result
(Num_Checks
) := N
;
8116 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
8117 SE
: constant Entity_Id
:= Scope
(E
);
8119 E1
: Entity_Id
:= E
;
8122 if Ekind
(Scope
(E
)) = E_Record_Type
8123 and then Has_Discriminants
(Scope
(E
))
8125 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
8128 Insert_Action
(Ck_Node
, N
);
8129 E1
:= Defining_Identifier
(N
);
8133 if Ekind
(E1
) = E_String_Literal_Subtype
then
8135 Make_Integer_Literal
(Loc
,
8136 Intval
=> String_Literal_Length
(E1
));
8138 elsif SE
/= Standard_Standard
8139 and then Ekind
(Scope
(SE
)) = E_Protected_Type
8140 and then Has_Discriminants
(Scope
(SE
))
8141 and then Has_Completion
(Scope
(SE
))
8142 and then not Inside_Init_Proc
8144 -- If the type whose length is needed is a private component
8145 -- constrained by a discriminant, we must expand the 'Length
8146 -- attribute into an explicit computation, using the discriminal
8147 -- of the current protected operation. This is because the actual
8148 -- type of the prival is constructed after the protected opera-
8149 -- tion has been fully expanded.
8152 Indx_Type
: Node_Id
;
8155 Do_Expand
: Boolean := False;
8158 Indx_Type
:= First_Index
(E
);
8160 for J
in 1 .. Indx
- 1 loop
8161 Next_Index
(Indx_Type
);
8164 Get_Index_Bounds
(Indx_Type
, Lo
, Hi
);
8166 if Nkind
(Lo
) = N_Identifier
8167 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
8169 Lo
:= Get_Discriminal
(E
, Lo
);
8173 if Nkind
(Hi
) = N_Identifier
8174 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
8176 Hi
:= Get_Discriminal
(E
, Hi
);
8181 if not Is_Entity_Name
(Lo
) then
8182 Lo
:= Duplicate_Subexpr_No_Checks
(Lo
);
8185 if not Is_Entity_Name
(Hi
) then
8186 Lo
:= Duplicate_Subexpr_No_Checks
(Hi
);
8192 Make_Op_Subtract
(Loc
,
8196 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
8201 Make_Attribute_Reference
(Loc
,
8202 Attribute_Name
=> Name_Length
,
8204 New_Occurrence_Of
(E1
, Loc
));
8207 Set_Expressions
(N
, New_List
(
8208 Make_Integer_Literal
(Loc
, Indx
)));
8217 Make_Attribute_Reference
(Loc
,
8218 Attribute_Name
=> Name_Length
,
8220 New_Occurrence_Of
(E1
, Loc
));
8223 Set_Expressions
(N
, New_List
(
8224 Make_Integer_Literal
(Loc
, Indx
)));
8235 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8238 Make_Attribute_Reference
(Loc
,
8239 Attribute_Name
=> Name_Length
,
8241 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8242 Expressions
=> New_List
(
8243 Make_Integer_Literal
(Loc
, Indx
)));
8250 function Length_E_Cond
8251 (Exptyp
: Entity_Id
;
8253 Indx
: Nat
) return Node_Id
8258 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8259 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
8266 function Length_N_Cond
8269 Indx
: Nat
) return Node_Id
8274 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
8275 Right_Opnd
=> Get_N_Length
(Expr
, Indx
));
8282 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
8285 (Nkind
(L
) = N_Integer_Literal
8286 and then Nkind
(R
) = N_Integer_Literal
8287 and then Intval
(L
) = Intval
(R
))
8291 and then Ekind
(Entity
(L
)) = E_Constant
8292 and then ((Is_Entity_Name
(R
)
8293 and then Entity
(L
) = Entity
(R
))
8295 (Nkind
(R
) = N_Type_Conversion
8296 and then Is_Entity_Name
(Expression
(R
))
8297 and then Entity
(L
) = Entity
(Expression
(R
)))))
8301 and then Ekind
(Entity
(R
)) = E_Constant
8302 and then Nkind
(L
) = N_Type_Conversion
8303 and then Is_Entity_Name
(Expression
(L
))
8304 and then Entity
(R
) = Entity
(Expression
(L
)))
8308 and then Is_Entity_Name
(R
)
8309 and then Entity
(L
) = Entity
(R
)
8310 and then Ekind
(Entity
(L
)) = E_In_Parameter
8311 and then Inside_Init_Proc
);
8314 -- Start of processing for Selected_Length_Checks
8317 if not Full_Expander_Active
then
8321 if Target_Typ
= Any_Type
8322 or else Target_Typ
= Any_Composite
8323 or else Raises_Constraint_Error
(Ck_Node
)
8332 T_Typ
:= Target_Typ
;
8334 if No
(Source_Typ
) then
8335 S_Typ
:= Etype
(Ck_Node
);
8337 S_Typ
:= Source_Typ
;
8340 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
8344 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
8345 S_Typ
:= Designated_Type
(S_Typ
);
8346 T_Typ
:= Designated_Type
(T_Typ
);
8349 -- A simple optimization for the null case
8351 if Known_Null
(Ck_Node
) then
8356 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
8357 if Is_Constrained
(T_Typ
) then
8359 -- The checking code to be generated will freeze the corresponding
8360 -- array type. However, we must freeze the type now, so that the
8361 -- freeze node does not appear within the generated if expression,
8364 Freeze_Before
(Ck_Node
, T_Typ
);
8366 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
8367 Exptyp
:= Get_Actual_Subtype
(Ck_Node
);
8369 if Is_Access_Type
(Exptyp
) then
8370 Exptyp
:= Designated_Type
(Exptyp
);
8373 -- String_Literal case. This needs to be handled specially be-
8374 -- cause no index types are available for string literals. The
8375 -- condition is simply:
8377 -- T_Typ'Length = string-literal-length
8379 if Nkind
(Expr_Actual
) = N_String_Literal
8380 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
8384 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
8386 Make_Integer_Literal
(Loc
,
8388 String_Literal_Length
(Etype
(Expr_Actual
))));
8390 -- General array case. Here we have a usable actual subtype for
8391 -- the expression, and the condition is built from the two types
8394 -- T_Typ'Length /= Exptyp'Length or else
8395 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
8396 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
8399 elsif Is_Constrained
(Exptyp
) then
8401 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
8414 -- At the library level, we need to ensure that the type of
8415 -- the object is elaborated before the check itself is
8416 -- emitted. This is only done if the object is in the
8417 -- current compilation unit, otherwise the type is frozen
8418 -- and elaborated in its unit.
8420 if Is_Itype
(Exptyp
)
8422 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
8424 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
8425 and then In_Open_Scopes
(Scope
(Exptyp
))
8427 Ref_Node
:= Make_Itype_Reference
(Sloc
(Ck_Node
));
8428 Set_Itype
(Ref_Node
, Exptyp
);
8429 Insert_Action
(Ck_Node
, Ref_Node
);
8432 L_Index
:= First_Index
(T_Typ
);
8433 R_Index
:= First_Index
(Exptyp
);
8435 for Indx
in 1 .. Ndims
loop
8436 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
8438 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
8440 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
8441 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
8443 -- Deal with compile time length check. Note that we
8444 -- skip this in the access case, because the access
8445 -- value may be null, so we cannot know statically.
8448 and then Compile_Time_Known_Value
(L_Low
)
8449 and then Compile_Time_Known_Value
(L_High
)
8450 and then Compile_Time_Known_Value
(R_Low
)
8451 and then Compile_Time_Known_Value
(R_High
)
8453 if Expr_Value
(L_High
) >= Expr_Value
(L_Low
) then
8454 L_Length
:= Expr_Value
(L_High
) -
8455 Expr_Value
(L_Low
) + 1;
8457 L_Length
:= UI_From_Int
(0);
8460 if Expr_Value
(R_High
) >= Expr_Value
(R_Low
) then
8461 R_Length
:= Expr_Value
(R_High
) -
8462 Expr_Value
(R_Low
) + 1;
8464 R_Length
:= UI_From_Int
(0);
8467 if L_Length
> R_Length
then
8469 (Compile_Time_Constraint_Error
8470 (Wnode
, "too few elements for}??", T_Typ
));
8472 elsif L_Length
< R_Length
then
8474 (Compile_Time_Constraint_Error
8475 (Wnode
, "too many elements for}??", T_Typ
));
8478 -- The comparison for an individual index subtype
8479 -- is omitted if the corresponding index subtypes
8480 -- statically match, since the result is known to
8481 -- be true. Note that this test is worth while even
8482 -- though we do static evaluation, because non-static
8483 -- subtypes can statically match.
8486 Subtypes_Statically_Match
8487 (Etype
(L_Index
), Etype
(R_Index
))
8490 (Same_Bounds
(L_Low
, R_Low
)
8491 and then Same_Bounds
(L_High
, R_High
))
8494 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
8503 -- Handle cases where we do not get a usable actual subtype that
8504 -- is constrained. This happens for example in the function call
8505 -- and explicit dereference cases. In these cases, we have to get
8506 -- the length or range from the expression itself, making sure we
8507 -- do not evaluate it more than once.
8509 -- Here Ck_Node is the original expression, or more properly the
8510 -- result of applying Duplicate_Expr to the original tree, forcing
8511 -- the result to be a name.
8515 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
8518 -- Build the condition for the explicit dereference case
8520 for Indx
in 1 .. Ndims
loop
8522 (Cond
, Length_N_Cond
(Ck_Node
, T_Typ
, Indx
));
8529 -- Construct the test and insert into the tree
8531 if Present
(Cond
) then
8533 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
8537 (Make_Raise_Constraint_Error
(Loc
,
8539 Reason
=> CE_Length_Check_Failed
));
8543 end Selected_Length_Checks
;
8545 ---------------------------
8546 -- Selected_Range_Checks --
8547 ---------------------------
8549 function Selected_Range_Checks
8551 Target_Typ
: Entity_Id
;
8552 Source_Typ
: Entity_Id
;
8553 Warn_Node
: Node_Id
) return Check_Result
8555 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
8558 Expr_Actual
: Node_Id
;
8560 Cond
: Node_Id
:= Empty
;
8561 Do_Access
: Boolean := False;
8562 Wnode
: Node_Id
:= Warn_Node
;
8563 Ret_Result
: Check_Result
:= (Empty
, Empty
);
8564 Num_Checks
: Integer := 0;
8566 procedure Add_Check
(N
: Node_Id
);
8567 -- Adds the action given to Ret_Result if N is non-Empty
8569 function Discrete_Range_Cond
8571 Typ
: Entity_Id
) return Node_Id
;
8572 -- Returns expression to compute:
8573 -- Low_Bound (Expr) < Typ'First
8575 -- High_Bound (Expr) > Typ'Last
8577 function Discrete_Expr_Cond
8579 Typ
: Entity_Id
) return Node_Id
;
8580 -- Returns expression to compute:
8585 function Get_E_First_Or_Last
8589 Nam
: Name_Id
) return Node_Id
;
8590 -- Returns an attribute reference
8591 -- E'First or E'Last
8592 -- with a source location of Loc.
8594 -- Nam is Name_First or Name_Last, according to which attribute is
8595 -- desired. If Indx is non-zero, it is passed as a literal in the
8596 -- Expressions of the attribute reference (identifying the desired
8597 -- array dimension).
8599 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8600 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
8601 -- Returns expression to compute:
8602 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
8604 function Range_E_Cond
8605 (Exptyp
: Entity_Id
;
8609 -- Returns expression to compute:
8610 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
8612 function Range_Equal_E_Cond
8613 (Exptyp
: Entity_Id
;
8615 Indx
: Nat
) return Node_Id
;
8616 -- Returns expression to compute:
8617 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
8619 function Range_N_Cond
8622 Indx
: Nat
) return Node_Id
;
8623 -- Return expression to compute:
8624 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
8630 procedure Add_Check
(N
: Node_Id
) is
8634 -- For now, ignore attempt to place more than 2 checks ???
8636 if Num_Checks
= 2 then
8640 pragma Assert
(Num_Checks
<= 1);
8641 Num_Checks
:= Num_Checks
+ 1;
8642 Ret_Result
(Num_Checks
) := N
;
8646 -------------------------
8647 -- Discrete_Expr_Cond --
8648 -------------------------
8650 function Discrete_Expr_Cond
8652 Typ
: Entity_Id
) return Node_Id
8660 Convert_To
(Base_Type
(Typ
),
8661 Duplicate_Subexpr_No_Checks
(Expr
)),
8663 Convert_To
(Base_Type
(Typ
),
8664 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
))),
8669 Convert_To
(Base_Type
(Typ
),
8670 Duplicate_Subexpr_No_Checks
(Expr
)),
8674 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
))));
8675 end Discrete_Expr_Cond
;
8677 -------------------------
8678 -- Discrete_Range_Cond --
8679 -------------------------
8681 function Discrete_Range_Cond
8683 Typ
: Entity_Id
) return Node_Id
8685 LB
: Node_Id
:= Low_Bound
(Expr
);
8686 HB
: Node_Id
:= High_Bound
(Expr
);
8688 Left_Opnd
: Node_Id
;
8689 Right_Opnd
: Node_Id
;
8692 if Nkind
(LB
) = N_Identifier
8693 and then Ekind
(Entity
(LB
)) = E_Discriminant
8695 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
8702 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
8707 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_First
)));
8709 if Nkind
(HB
) = N_Identifier
8710 and then Ekind
(Entity
(HB
)) = E_Discriminant
8712 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
8719 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
8724 Get_E_First_Or_Last
(Loc
, Typ
, 0, Name_Last
)));
8726 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
8727 end Discrete_Range_Cond
;
8729 -------------------------
8730 -- Get_E_First_Or_Last --
8731 -------------------------
8733 function Get_E_First_Or_Last
8737 Nam
: Name_Id
) return Node_Id
8742 Exprs
:= New_List
(Make_Integer_Literal
(Loc
, UI_From_Int
(Indx
)));
8747 return Make_Attribute_Reference
(Loc
,
8748 Prefix
=> New_Occurrence_Of
(E
, Loc
),
8749 Attribute_Name
=> Nam
,
8750 Expressions
=> Exprs
);
8751 end Get_E_First_Or_Last
;
8757 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8760 Make_Attribute_Reference
(Loc
,
8761 Attribute_Name
=> Name_First
,
8763 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8764 Expressions
=> New_List
(
8765 Make_Integer_Literal
(Loc
, Indx
)));
8772 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
8775 Make_Attribute_Reference
(Loc
,
8776 Attribute_Name
=> Name_Last
,
8778 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
8779 Expressions
=> New_List
(
8780 Make_Integer_Literal
(Loc
, Indx
)));
8787 function Range_E_Cond
8788 (Exptyp
: Entity_Id
;
8790 Indx
: Nat
) return Node_Id
8798 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
8800 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8805 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
8807 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8810 ------------------------
8811 -- Range_Equal_E_Cond --
8812 ------------------------
8814 function Range_Equal_E_Cond
8815 (Exptyp
: Entity_Id
;
8817 Indx
: Nat
) return Node_Id
8825 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_First
),
8827 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8832 Get_E_First_Or_Last
(Loc
, Exptyp
, Indx
, Name_Last
),
8834 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8835 end Range_Equal_E_Cond
;
8841 function Range_N_Cond
8844 Indx
: Nat
) return Node_Id
8852 Get_N_First
(Expr
, Indx
),
8854 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_First
)),
8859 Get_N_Last
(Expr
, Indx
),
8861 Get_E_First_Or_Last
(Loc
, Typ
, Indx
, Name_Last
)));
8864 -- Start of processing for Selected_Range_Checks
8867 if not Full_Expander_Active
then
8871 if Target_Typ
= Any_Type
8872 or else Target_Typ
= Any_Composite
8873 or else Raises_Constraint_Error
(Ck_Node
)
8882 T_Typ
:= Target_Typ
;
8884 if No
(Source_Typ
) then
8885 S_Typ
:= Etype
(Ck_Node
);
8887 S_Typ
:= Source_Typ
;
8890 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
8894 -- The order of evaluating T_Typ before S_Typ seems to be critical
8895 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
8896 -- in, and since Node can be an N_Range node, it might be invalid.
8897 -- Should there be an assert check somewhere for taking the Etype of
8898 -- an N_Range node ???
8900 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
8901 S_Typ
:= Designated_Type
(S_Typ
);
8902 T_Typ
:= Designated_Type
(T_Typ
);
8905 -- A simple optimization for the null case
8907 if Known_Null
(Ck_Node
) then
8912 -- For an N_Range Node, check for a null range and then if not
8913 -- null generate a range check action.
8915 if Nkind
(Ck_Node
) = N_Range
then
8917 -- There's no point in checking a range against itself
8919 if Ck_Node
= Scalar_Range
(T_Typ
) then
8924 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
8925 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
8926 Known_T_LB
: constant Boolean := Compile_Time_Known_Value
(T_LB
);
8927 Known_T_HB
: constant Boolean := Compile_Time_Known_Value
(T_HB
);
8929 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
8930 HB
: Node_Id
:= High_Bound
(Ck_Node
);
8934 Null_Range
: Boolean;
8935 Out_Of_Range_L
: Boolean;
8936 Out_Of_Range_H
: Boolean;
8939 -- Compute what is known at compile time
8941 if Known_T_LB
and Known_T_HB
then
8942 if Compile_Time_Known_Value
(LB
) then
8945 -- There's no point in checking that a bound is within its
8946 -- own range so pretend that it is known in this case. First
8947 -- deal with low bound.
8949 elsif Ekind
(Etype
(LB
)) = E_Signed_Integer_Subtype
8950 and then Scalar_Range
(Etype
(LB
)) = Scalar_Range
(T_Typ
)
8959 -- Likewise for the high bound
8961 if Compile_Time_Known_Value
(HB
) then
8964 elsif Ekind
(Etype
(HB
)) = E_Signed_Integer_Subtype
8965 and then Scalar_Range
(Etype
(HB
)) = Scalar_Range
(T_Typ
)
8975 -- Check for case where everything is static and we can do the
8976 -- check at compile time. This is skipped if we have an access
8977 -- type, since the access value may be null.
8979 -- ??? This code can be improved since you only need to know that
8980 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at
8981 -- compile time to emit pertinent messages.
8983 if Known_T_LB
and Known_T_HB
and Known_LB
and Known_HB
8986 -- Floating-point case
8988 if Is_Floating_Point_Type
(S_Typ
) then
8989 Null_Range
:= Expr_Value_R
(HB
) < Expr_Value_R
(LB
);
8991 (Expr_Value_R
(LB
) < Expr_Value_R
(T_LB
))
8993 (Expr_Value_R
(LB
) > Expr_Value_R
(T_HB
));
8996 (Expr_Value_R
(HB
) > Expr_Value_R
(T_HB
))
8998 (Expr_Value_R
(HB
) < Expr_Value_R
(T_LB
));
9000 -- Fixed or discrete type case
9003 Null_Range
:= Expr_Value
(HB
) < Expr_Value
(LB
);
9005 (Expr_Value
(LB
) < Expr_Value
(T_LB
))
9007 (Expr_Value
(LB
) > Expr_Value
(T_HB
));
9010 (Expr_Value
(HB
) > Expr_Value
(T_HB
))
9012 (Expr_Value
(HB
) < Expr_Value
(T_LB
));
9015 if not Null_Range
then
9016 if Out_Of_Range_L
then
9017 if No
(Warn_Node
) then
9019 (Compile_Time_Constraint_Error
9020 (Low_Bound
(Ck_Node
),
9021 "static value out of range of}??", T_Typ
));
9025 (Compile_Time_Constraint_Error
9027 "static range out of bounds of}??", T_Typ
));
9031 if Out_Of_Range_H
then
9032 if No
(Warn_Node
) then
9034 (Compile_Time_Constraint_Error
9035 (High_Bound
(Ck_Node
),
9036 "static value out of range of}??", T_Typ
));
9040 (Compile_Time_Constraint_Error
9042 "static range out of bounds of}??", T_Typ
));
9049 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
9050 HB
: Node_Id
:= High_Bound
(Ck_Node
);
9053 -- If either bound is a discriminant and we are within the
9054 -- record declaration, it is a use of the discriminant in a
9055 -- constraint of a component, and nothing can be checked
9056 -- here. The check will be emitted within the init proc.
9057 -- Before then, the discriminal has no real meaning.
9058 -- Similarly, if the entity is a discriminal, there is no
9059 -- check to perform yet.
9061 -- The same holds within a discriminated synchronized type,
9062 -- where the discriminant may constrain a component or an
9065 if Nkind
(LB
) = N_Identifier
9066 and then Denotes_Discriminant
(LB
, True)
9068 if Current_Scope
= Scope
(Entity
(LB
))
9069 or else Is_Concurrent_Type
(Current_Scope
)
9070 or else Ekind
(Entity
(LB
)) /= E_Discriminant
9075 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
9079 if Nkind
(HB
) = N_Identifier
9080 and then Denotes_Discriminant
(HB
, True)
9082 if Current_Scope
= Scope
(Entity
(HB
))
9083 or else Is_Concurrent_Type
(Current_Scope
)
9084 or else Ekind
(Entity
(HB
)) /= E_Discriminant
9089 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
9093 Cond
:= Discrete_Range_Cond
(Ck_Node
, T_Typ
);
9094 Set_Paren_Count
(Cond
, 1);
9100 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(HB
),
9101 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(LB
)),
9102 Right_Opnd
=> Cond
);
9107 elsif Is_Scalar_Type
(S_Typ
) then
9109 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
9110 -- except the above simply sets a flag in the node and lets
9111 -- gigi generate the check base on the Etype of the expression.
9112 -- Sometimes, however we want to do a dynamic check against an
9113 -- arbitrary target type, so we do that here.
9115 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
9116 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9118 -- For literals, we can tell if the constraint error will be
9119 -- raised at compile time, so we never need a dynamic check, but
9120 -- if the exception will be raised, then post the usual warning,
9121 -- and replace the literal with a raise constraint error
9122 -- expression. As usual, skip this for access types
9124 elsif Compile_Time_Known_Value
(Ck_Node
)
9125 and then not Do_Access
9128 LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
9129 UB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
9131 Out_Of_Range
: Boolean;
9132 Static_Bounds
: constant Boolean :=
9133 Compile_Time_Known_Value
(LB
)
9134 and Compile_Time_Known_Value
(UB
);
9137 -- Following range tests should use Sem_Eval routine ???
9139 if Static_Bounds
then
9140 if Is_Floating_Point_Type
(S_Typ
) then
9142 (Expr_Value_R
(Ck_Node
) < Expr_Value_R
(LB
))
9144 (Expr_Value_R
(Ck_Node
) > Expr_Value_R
(UB
));
9146 -- Fixed or discrete type
9150 Expr_Value
(Ck_Node
) < Expr_Value
(LB
)
9152 Expr_Value
(Ck_Node
) > Expr_Value
(UB
);
9155 -- Bounds of the type are static and the literal is out of
9156 -- range so output a warning message.
9158 if Out_Of_Range
then
9159 if No
(Warn_Node
) then
9161 (Compile_Time_Constraint_Error
9163 "static value out of range of}??", T_Typ
));
9167 (Compile_Time_Constraint_Error
9169 "static value out of range of}??", T_Typ
));
9174 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9178 -- Here for the case of a non-static expression, we need a runtime
9179 -- check unless the source type range is guaranteed to be in the
9180 -- range of the target type.
9183 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
9184 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
9189 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
9190 if Is_Constrained
(T_Typ
) then
9192 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
9193 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
9195 if Is_Access_Type
(Exptyp
) then
9196 Exptyp
:= Designated_Type
(Exptyp
);
9199 -- String_Literal case. This needs to be handled specially be-
9200 -- cause no index types are available for string literals. The
9201 -- condition is simply:
9203 -- T_Typ'Length = string-literal-length
9205 if Nkind
(Expr_Actual
) = N_String_Literal
then
9208 -- General array case. Here we have a usable actual subtype for
9209 -- the expression, and the condition is built from the two types
9211 -- T_Typ'First < Exptyp'First or else
9212 -- T_Typ'Last > Exptyp'Last or else
9213 -- T_Typ'First(1) < Exptyp'First(1) or else
9214 -- T_Typ'Last(1) > Exptyp'Last(1) or else
9217 elsif Is_Constrained
(Exptyp
) then
9219 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9225 L_Index
:= First_Index
(T_Typ
);
9226 R_Index
:= First_Index
(Exptyp
);
9228 for Indx
in 1 .. Ndims
loop
9229 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
9231 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
9233 -- Deal with compile time length check. Note that we
9234 -- skip this in the access case, because the access
9235 -- value may be null, so we cannot know statically.
9238 Subtypes_Statically_Match
9239 (Etype
(L_Index
), Etype
(R_Index
))
9241 -- If the target type is constrained then we
9242 -- have to check for exact equality of bounds
9243 -- (required for qualified expressions).
9245 if Is_Constrained
(T_Typ
) then
9248 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
9251 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
9261 -- Handle cases where we do not get a usable actual subtype that
9262 -- is constrained. This happens for example in the function call
9263 -- and explicit dereference cases. In these cases, we have to get
9264 -- the length or range from the expression itself, making sure we
9265 -- do not evaluate it more than once.
9267 -- Here Ck_Node is the original expression, or more properly the
9268 -- result of applying Duplicate_Expr to the original tree,
9269 -- forcing the result to be a name.
9273 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
9276 -- Build the condition for the explicit dereference case
9278 for Indx
in 1 .. Ndims
loop
9280 (Cond
, Range_N_Cond
(Ck_Node
, T_Typ
, Indx
));
9286 -- For a conversion to an unconstrained array type, generate an
9287 -- Action to check that the bounds of the source value are within
9288 -- the constraints imposed by the target type (RM 4.6(38)). No
9289 -- check is needed for a conversion to an access to unconstrained
9290 -- array type, as 4.6(24.15/2) requires the designated subtypes
9291 -- of the two access types to statically match.
9293 if Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
9294 and then not Do_Access
9297 Opnd_Index
: Node_Id
;
9298 Targ_Index
: Node_Id
;
9299 Opnd_Range
: Node_Id
;
9302 Opnd_Index
:= First_Index
(Get_Actual_Subtype
(Ck_Node
));
9303 Targ_Index
:= First_Index
(T_Typ
);
9304 while Present
(Opnd_Index
) loop
9306 -- If the index is a range, use its bounds. If it is an
9307 -- entity (as will be the case if it is a named subtype
9308 -- or an itype created for a slice) retrieve its range.
9310 if Is_Entity_Name
(Opnd_Index
)
9311 and then Is_Type
(Entity
(Opnd_Index
))
9313 Opnd_Range
:= Scalar_Range
(Entity
(Opnd_Index
));
9315 Opnd_Range
:= Opnd_Index
;
9318 if Nkind
(Opnd_Range
) = N_Range
then
9320 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9321 Assume_Valid
=> True)
9324 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9325 Assume_Valid
=> True)
9329 -- If null range, no check needed
9332 Compile_Time_Known_Value
(High_Bound
(Opnd_Range
))
9334 Compile_Time_Known_Value
(Low_Bound
(Opnd_Range
))
9336 Expr_Value
(High_Bound
(Opnd_Range
)) <
9337 Expr_Value
(Low_Bound
(Opnd_Range
))
9341 elsif Is_Out_Of_Range
9342 (Low_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9343 Assume_Valid
=> True)
9346 (High_Bound
(Opnd_Range
), Etype
(Targ_Index
),
9347 Assume_Valid
=> True)
9350 (Compile_Time_Constraint_Error
9351 (Wnode
, "value out of range of}??", T_Typ
));
9357 (Opnd_Range
, Etype
(Targ_Index
)));
9361 Next_Index
(Opnd_Index
);
9362 Next_Index
(Targ_Index
);
9369 -- Construct the test and insert into the tree
9371 if Present
(Cond
) then
9373 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
9377 (Make_Raise_Constraint_Error
(Loc
,
9379 Reason
=> CE_Range_Check_Failed
));
9383 end Selected_Range_Checks
;
9385 -------------------------------
9386 -- Storage_Checks_Suppressed --
9387 -------------------------------
9389 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9391 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9392 return Is_Check_Suppressed
(E
, Storage_Check
);
9394 return Scope_Suppress
.Suppress
(Storage_Check
);
9396 end Storage_Checks_Suppressed
;
9398 ---------------------------
9399 -- Tag_Checks_Suppressed --
9400 ---------------------------
9402 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9405 and then Checks_May_Be_Suppressed
(E
)
9407 return Is_Check_Suppressed
(E
, Tag_Check
);
9410 return Scope_Suppress
.Suppress
(Tag_Check
);
9411 end Tag_Checks_Suppressed
;
9413 --------------------------
9414 -- Validity_Check_Range --
9415 --------------------------
9417 procedure Validity_Check_Range
(N
: Node_Id
) is
9419 if Validity_Checks_On
and Validity_Check_Operands
then
9420 if Nkind
(N
) = N_Range
then
9421 Ensure_Valid
(Low_Bound
(N
));
9422 Ensure_Valid
(High_Bound
(N
));
9425 end Validity_Check_Range
;
9427 --------------------------------
9428 -- Validity_Checks_Suppressed --
9429 --------------------------------
9431 function Validity_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
9433 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
9434 return Is_Check_Suppressed
(E
, Validity_Check
);
9436 return Scope_Suppress
.Suppress
(Validity_Check
);
9438 end Validity_Checks_Suppressed
;