1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
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_Pakd
; use Exp_Pakd
;
33 with Exp_Util
; use Exp_Util
;
34 with Elists
; use Elists
;
35 with Eval_Fat
; use Eval_Fat
;
36 with Freeze
; use Freeze
;
38 with Nlists
; use Nlists
;
39 with Nmake
; use Nmake
;
41 with Output
; use Output
;
42 with Restrict
; use Restrict
;
43 with Rident
; use Rident
;
44 with Rtsfind
; use Rtsfind
;
46 with Sem_Eval
; use Sem_Eval
;
47 with Sem_Ch3
; use Sem_Ch3
;
48 with Sem_Ch8
; use Sem_Ch8
;
49 with Sem_Res
; use Sem_Res
;
50 with Sem_Util
; use Sem_Util
;
51 with Sem_Warn
; use Sem_Warn
;
52 with Sinfo
; use Sinfo
;
53 with Sinput
; use Sinput
;
54 with Snames
; use Snames
;
55 with Sprint
; use Sprint
;
56 with Stand
; use Stand
;
57 with Targparm
; use Targparm
;
58 with Tbuild
; use Tbuild
;
59 with Ttypes
; use Ttypes
;
60 with Urealp
; use Urealp
;
61 with Validsw
; use Validsw
;
63 package body Checks
is
65 -- General note: many of these routines are concerned with generating
66 -- checking code to make sure that constraint error is raised at runtime.
67 -- Clearly this code is only needed if the expander is active, since
68 -- otherwise we will not be generating code or going into the runtime
71 -- We therefore disconnect most of these checks if the expander is
72 -- inactive. This has the additional benefit that we do not need to
73 -- worry about the tree being messed up by previous errors (since errors
74 -- turn off expansion anyway).
76 -- There are a few exceptions to the above rule. For instance routines
77 -- such as Apply_Scalar_Range_Check that do not insert any code can be
78 -- safely called even when the Expander is inactive (but Errors_Detected
79 -- is 0). The benefit of executing this code when expansion is off, is
80 -- the ability to emit constraint error warning for static expressions
81 -- even when we are not generating code.
83 -------------------------------------
84 -- Suppression of Redundant Checks --
85 -------------------------------------
87 -- This unit implements a limited circuit for removal of redundant
88 -- checks. The processing is based on a tracing of simple sequential
89 -- flow. For any sequence of statements, we save expressions that are
90 -- marked to be checked, and then if the same expression appears later
91 -- with the same check, then under certain circumstances, the second
92 -- check can be suppressed.
94 -- Basically, we can suppress the check if we know for certain that
95 -- the previous expression has been elaborated (together with its
96 -- check), and we know that the exception frame is the same, and that
97 -- nothing has happened to change the result of the exception.
99 -- Let us examine each of these three conditions in turn to describe
100 -- how we ensure that this condition is met.
102 -- First, we need to know for certain that the previous expression has
103 -- been executed. This is done principly by the mechanism of calling
104 -- Conditional_Statements_Begin at the start of any statement sequence
105 -- and Conditional_Statements_End at the end. The End call causes all
106 -- checks remembered since the Begin call to be discarded. This does
107 -- miss a few cases, notably the case of a nested BEGIN-END block with
108 -- no exception handlers. But the important thing is to be conservative.
109 -- The other protection is that all checks are discarded if a label
110 -- is encountered, since then the assumption of sequential execution
111 -- is violated, and we don't know enough about the flow.
113 -- Second, we need to know that the exception frame is the same. We
114 -- do this by killing all remembered checks when we enter a new frame.
115 -- Again, that's over-conservative, but generally the cases we can help
116 -- with are pretty local anyway (like the body of a loop for example).
118 -- Third, we must be sure to forget any checks which are no longer valid.
119 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
120 -- used to note any changes to local variables. We only attempt to deal
121 -- with checks involving local variables, so we do not need to worry
122 -- about global variables. Second, a call to any non-global procedure
123 -- causes us to abandon all stored checks, since such a all may affect
124 -- the values of any local variables.
126 -- The following define the data structures used to deal with remembering
127 -- checks so that redundant checks can be eliminated as described above.
129 -- Right now, the only expressions that we deal with are of the form of
130 -- simple local objects (either declared locally, or IN parameters) or
131 -- such objects plus/minus a compile time known constant. We can do
132 -- more later on if it seems worthwhile, but this catches many simple
133 -- cases in practice.
135 -- The following record type reflects a single saved check. An entry
136 -- is made in the stack of saved checks if and only if the expression
137 -- has been elaborated with the indicated checks.
139 type Saved_Check
is record
141 -- Set True if entry is killed by Kill_Checks
144 -- The entity involved in the expression that is checked
147 -- A compile time value indicating the result of adding or
148 -- subtracting a compile time value. This value is to be
149 -- added to the value of the Entity. A value of zero is
150 -- used for the case of a simple entity reference.
152 Check_Type
: Character;
153 -- This is set to 'R' for a range check (in which case Target_Type
154 -- is set to the target type for the range check) or to 'O' for an
155 -- overflow check (in which case Target_Type is set to Empty).
157 Target_Type
: Entity_Id
;
158 -- Used only if Do_Range_Check is set. Records the target type for
159 -- the check. We need this, because a check is a duplicate only if
160 -- it has a the same target type (or more accurately one with a
161 -- range that is smaller or equal to the stored target type of a
165 -- The following table keeps track of saved checks. Rather than use an
166 -- extensible table. We just use a table of fixed size, and we discard
167 -- any saved checks that do not fit. That's very unlikely to happen and
168 -- this is only an optimization in any case.
170 Saved_Checks
: array (Int
range 1 .. 200) of Saved_Check
;
171 -- Array of saved checks
173 Num_Saved_Checks
: Nat
:= 0;
174 -- Number of saved checks
176 -- The following stack keeps track of statement ranges. It is treated
177 -- as a stack. When Conditional_Statements_Begin is called, an entry
178 -- is pushed onto this stack containing the value of Num_Saved_Checks
179 -- at the time of the call. Then when Conditional_Statements_End is
180 -- called, this value is popped off and used to reset Num_Saved_Checks.
182 -- Note: again, this is a fixed length stack with a size that should
183 -- always be fine. If the value of the stack pointer goes above the
184 -- limit, then we just forget all saved checks.
186 Saved_Checks_Stack
: array (Int
range 1 .. 100) of Nat
;
187 Saved_Checks_TOS
: Nat
:= 0;
189 -----------------------
190 -- Local Subprograms --
191 -----------------------
193 procedure Apply_Float_Conversion_Check
195 Target_Typ
: Entity_Id
);
196 -- The checks on a conversion from a floating-point type to an integer
197 -- type are delicate. They have to be performed before conversion, they
198 -- have to raise an exception when the operand is a NaN, and rounding must
199 -- be taken into account to determine the safe bounds of the operand.
201 procedure Apply_Selected_Length_Checks
203 Target_Typ
: Entity_Id
;
204 Source_Typ
: Entity_Id
;
205 Do_Static
: Boolean);
206 -- This is the subprogram that does all the work for Apply_Length_Check
207 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
208 -- described for the above routines. The Do_Static flag indicates that
209 -- only a static check is to be done.
211 procedure Apply_Selected_Range_Checks
213 Target_Typ
: Entity_Id
;
214 Source_Typ
: Entity_Id
;
215 Do_Static
: Boolean);
216 -- This is the subprogram that does all the work for Apply_Range_Check.
217 -- Expr, Target_Typ and Source_Typ are as described for the above
218 -- routine. The Do_Static flag indicates that only a static check is
221 type Check_Type
is (Access_Check
, Division_Check
);
222 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean;
223 -- This function is used to see if an access or division by zero check is
224 -- needed. The check is to be applied to a single variable appearing in the
225 -- source, and N is the node for the reference. If N is not of this form,
226 -- True is returned with no further processing. If N is of the right form,
227 -- then further processing determines if the given Check is needed.
229 -- The particular circuit is to see if we have the case of a check that is
230 -- not needed because it appears in the right operand of a short circuited
231 -- conditional where the left operand guards the check. For example:
233 -- if Var = 0 or else Q / Var > 12 then
237 -- In this example, the division check is not required. At the same time
238 -- we can issue warnings for suspicious use of non-short-circuited forms,
241 -- if Var = 0 or Q / Var > 12 then
247 Check_Type
: Character;
248 Target_Type
: Entity_Id
;
249 Entry_OK
: out Boolean;
253 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
254 -- to see if a check is of the form for optimization, and if so, to see
255 -- if it has already been performed. Expr is the expression to check,
256 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
257 -- Target_Type is the target type for a range check, and Empty for an
258 -- overflow check. If the entry is not of the form for optimization,
259 -- then Entry_OK is set to False, and the remaining out parameters
260 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
261 -- entity and offset from the expression. Check_Num is the number of
262 -- a matching saved entry in Saved_Checks, or zero if no such entry
265 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
;
266 -- If a discriminal is used in constraining a prival, Return reference
267 -- to the discriminal of the protected body (which renames the parameter
268 -- of the enclosing protected operation). This clumsy transformation is
269 -- needed because privals are created too late and their actual subtypes
270 -- are not available when analysing the bodies of the protected operations.
271 -- To be cleaned up???
273 function Guard_Access
276 Ck_Node
: Node_Id
) return Node_Id
;
277 -- In the access type case, guard the test with a test to ensure
278 -- that the access value is non-null, since the checks do not
279 -- not apply to null access values.
281 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
);
282 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
283 -- Constraint_Error node.
285 function Selected_Length_Checks
287 Target_Typ
: Entity_Id
;
288 Source_Typ
: Entity_Id
;
289 Warn_Node
: Node_Id
) return Check_Result
;
290 -- Like Apply_Selected_Length_Checks, except it doesn't modify
291 -- anything, just returns a list of nodes as described in the spec of
292 -- this package for the Range_Check function.
294 function Selected_Range_Checks
296 Target_Typ
: Entity_Id
;
297 Source_Typ
: Entity_Id
;
298 Warn_Node
: Node_Id
) return Check_Result
;
299 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
300 -- just returns a list of nodes as described in the spec of this package
301 -- for the Range_Check function.
303 ------------------------------
304 -- Access_Checks_Suppressed --
305 ------------------------------
307 function Access_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
309 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
310 return Is_Check_Suppressed
(E
, Access_Check
);
312 return Scope_Suppress
(Access_Check
);
314 end Access_Checks_Suppressed
;
316 -------------------------------------
317 -- Accessibility_Checks_Suppressed --
318 -------------------------------------
320 function Accessibility_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
322 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
323 return Is_Check_Suppressed
(E
, Accessibility_Check
);
325 return Scope_Suppress
(Accessibility_Check
);
327 end Accessibility_Checks_Suppressed
;
329 -------------------------
330 -- Append_Range_Checks --
331 -------------------------
333 procedure Append_Range_Checks
334 (Checks
: Check_Result
;
336 Suppress_Typ
: Entity_Id
;
337 Static_Sloc
: Source_Ptr
;
340 Internal_Flag_Node
: constant Node_Id
:= Flag_Node
;
341 Internal_Static_Sloc
: constant Source_Ptr
:= Static_Sloc
;
343 Checks_On
: constant Boolean :=
344 (not Index_Checks_Suppressed
(Suppress_Typ
))
346 (not Range_Checks_Suppressed
(Suppress_Typ
));
349 -- For now we just return if Checks_On is false, however this should
350 -- be enhanced to check for an always True value in the condition
351 -- and to generate a compilation warning???
353 if not Checks_On
then
358 exit when No
(Checks
(J
));
360 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
361 and then Present
(Condition
(Checks
(J
)))
363 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
364 Append_To
(Stmts
, Checks
(J
));
365 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
371 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
372 Reason
=> CE_Range_Check_Failed
));
375 end Append_Range_Checks
;
377 ------------------------
378 -- Apply_Access_Check --
379 ------------------------
381 procedure Apply_Access_Check
(N
: Node_Id
) is
382 P
: constant Node_Id
:= Prefix
(N
);
385 if Inside_A_Generic
then
389 if Is_Entity_Name
(P
) then
390 Check_Unset_Reference
(P
);
393 -- We do not need access checks if prefix is known to be non-null
395 if Known_Non_Null
(P
) then
398 -- We do not need access checks if they are suppressed on the type
400 elsif Access_Checks_Suppressed
(Etype
(P
)) then
403 -- We do not need checks if we are not generating code (i.e. the
404 -- expander is not active). This is not just an optimization, there
405 -- are cases (e.g. with pragma Debug) where generating the checks
406 -- can cause real trouble).
408 elsif not Expander_Active
then
411 -- We do not need checks if not needed because of short circuiting
413 elsif not Check_Needed
(P
, Access_Check
) then
417 -- Case where P is an entity name
419 if Is_Entity_Name
(P
) then
421 Ent
: constant Entity_Id
:= Entity
(P
);
424 if Access_Checks_Suppressed
(Ent
) then
428 -- Otherwise we are going to generate an access check, and
429 -- are we have done it, the entity will now be known non null
430 -- But we have to check for safe sequential semantics here!
432 if Safe_To_Capture_Value
(N
, Ent
) then
433 Set_Is_Known_Non_Null
(Ent
);
438 -- Access check is required
440 Install_Null_Excluding_Check
(P
);
441 end Apply_Access_Check
;
443 -------------------------------
444 -- Apply_Accessibility_Check --
445 -------------------------------
447 procedure Apply_Accessibility_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
448 Loc
: constant Source_Ptr
:= Sloc
(N
);
449 Param_Ent
: constant Entity_Id
:= Param_Entity
(N
);
450 Param_Level
: Node_Id
;
451 Type_Level
: Node_Id
;
454 if Inside_A_Generic
then
457 -- Only apply the run-time check if the access parameter
458 -- has an associated extra access level parameter and
459 -- when the level of the type is less deep than the level
460 -- of the access parameter.
462 elsif Present
(Param_Ent
)
463 and then Present
(Extra_Accessibility
(Param_Ent
))
464 and then UI_Gt
(Object_Access_Level
(N
),
465 Type_Access_Level
(Typ
))
466 and then not Accessibility_Checks_Suppressed
(Param_Ent
)
467 and then not Accessibility_Checks_Suppressed
(Typ
)
470 New_Occurrence_Of
(Extra_Accessibility
(Param_Ent
), Loc
);
473 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
));
475 -- Raise Program_Error if the accessibility level of the
476 -- the access parameter is deeper than the level of the
477 -- target access type.
480 Make_Raise_Program_Error
(Loc
,
483 Left_Opnd
=> Param_Level
,
484 Right_Opnd
=> Type_Level
),
485 Reason
=> PE_Accessibility_Check_Failed
));
487 Analyze_And_Resolve
(N
);
489 end Apply_Accessibility_Check
;
491 ---------------------------
492 -- Apply_Alignment_Check --
493 ---------------------------
495 procedure Apply_Alignment_Check
(E
: Entity_Id
; N
: Node_Id
) is
496 AC
: constant Node_Id
:= Address_Clause
(E
);
497 Typ
: constant Entity_Id
:= Etype
(E
);
501 Alignment_Required
: constant Boolean := Maximum_Alignment
> 1;
502 -- Constant to show whether target requires alignment checks
505 -- See if check needed. Note that we never need a check if the
506 -- maximum alignment is one, since the check will always succeed
509 or else not Check_Address_Alignment
(AC
)
510 or else not Alignment_Required
516 Expr
:= Expression
(AC
);
518 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
519 Expr
:= Expression
(Expr
);
521 elsif Nkind
(Expr
) = N_Function_Call
522 and then Is_Entity_Name
(Name
(Expr
))
523 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
525 Expr
:= First
(Parameter_Associations
(Expr
));
527 if Nkind
(Expr
) = N_Parameter_Association
then
528 Expr
:= Explicit_Actual_Parameter
(Expr
);
532 -- Here Expr is the address value. See if we know that the
533 -- value is unacceptable at compile time.
535 if Compile_Time_Known_Value
(Expr
)
536 and then (Known_Alignment
(E
) or else Known_Alignment
(Typ
))
539 AL
: Uint
:= Alignment
(Typ
);
542 -- The object alignment might be more restrictive than the
545 if Known_Alignment
(E
) then
549 if Expr_Value
(Expr
) mod AL
/= 0 then
551 Make_Raise_Program_Error
(Loc
,
552 Reason
=> PE_Misaligned_Address_Value
));
554 ("?specified address for& not " &
555 "consistent with alignment ('R'M 13.3(27))", Expr
, E
);
559 -- Here we do not know if the value is acceptable, generate
560 -- code to raise PE if alignment is inappropriate.
563 -- Skip generation of this code if we don't want elab code
565 if not Restriction_Active
(No_Elaboration_Code
) then
566 Insert_After_And_Analyze
(N
,
567 Make_Raise_Program_Error
(Loc
,
574 (RTE
(RE_Integer_Address
),
575 Duplicate_Subexpr_No_Checks
(Expr
)),
577 Make_Attribute_Reference
(Loc
,
578 Prefix
=> New_Occurrence_Of
(E
, Loc
),
579 Attribute_Name
=> Name_Alignment
)),
580 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
581 Reason
=> PE_Misaligned_Address_Value
),
582 Suppress
=> All_Checks
);
589 when RE_Not_Available
=>
591 end Apply_Alignment_Check
;
593 -------------------------------------
594 -- Apply_Arithmetic_Overflow_Check --
595 -------------------------------------
597 -- This routine is called only if the type is an integer type, and
598 -- a software arithmetic overflow check must be performed for op
599 -- (add, subtract, multiply). The check is performed only if
600 -- Software_Overflow_Checking is enabled and Do_Overflow_Check
601 -- is set. In this case we expand the operation into a more complex
602 -- sequence of tests that ensures that overflow is properly caught.
604 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
605 Loc
: constant Source_Ptr
:= Sloc
(N
);
606 Typ
: constant Entity_Id
:= Etype
(N
);
607 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
608 Siz
: constant Int
:= UI_To_Int
(Esize
(Rtyp
));
609 Dsiz
: constant Int
:= Siz
* 2;
616 -- Skip this if overflow checks are done in back end, or the overflow
617 -- flag is not set anyway, or we are not doing code expansion.
619 if Backend_Overflow_Checks_On_Target
620 or else not Do_Overflow_Check
(N
)
621 or else not Expander_Active
626 -- Otherwise, we generate the full general code for front end overflow
627 -- detection, which works by doing arithmetic in a larger type:
633 -- Typ (Checktyp (x) op Checktyp (y));
635 -- where Typ is the type of the original expression, and Checktyp is
636 -- an integer type of sufficient length to hold the largest possible
639 -- In the case where check type exceeds the size of Long_Long_Integer,
640 -- we use a different approach, expanding to:
642 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
644 -- where xxx is Add, Multiply or Subtract as appropriate
646 -- Find check type if one exists
648 if Dsiz
<= Standard_Integer_Size
then
649 Ctyp
:= Standard_Integer
;
651 elsif Dsiz
<= Standard_Long_Long_Integer_Size
then
652 Ctyp
:= Standard_Long_Long_Integer
;
654 -- No check type exists, use runtime call
657 if Nkind
(N
) = N_Op_Add
then
658 Cent
:= RE_Add_With_Ovflo_Check
;
660 elsif Nkind
(N
) = N_Op_Multiply
then
661 Cent
:= RE_Multiply_With_Ovflo_Check
;
664 pragma Assert
(Nkind
(N
) = N_Op_Subtract
);
665 Cent
:= RE_Subtract_With_Ovflo_Check
;
670 Make_Function_Call
(Loc
,
671 Name
=> New_Reference_To
(RTE
(Cent
), Loc
),
672 Parameter_Associations
=> New_List
(
673 OK_Convert_To
(RTE
(RE_Integer_64
), Left_Opnd
(N
)),
674 OK_Convert_To
(RTE
(RE_Integer_64
), Right_Opnd
(N
))))));
676 Analyze_And_Resolve
(N
, Typ
);
680 -- If we fall through, we have the case where we do the arithmetic in
681 -- the next higher type and get the check by conversion. In these cases
682 -- Ctyp is set to the type to be used as the check type.
684 Opnod
:= Relocate_Node
(N
);
686 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
689 Set_Etype
(Opnd
, Ctyp
);
690 Set_Analyzed
(Opnd
, True);
691 Set_Left_Opnd
(Opnod
, Opnd
);
693 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
696 Set_Etype
(Opnd
, Ctyp
);
697 Set_Analyzed
(Opnd
, True);
698 Set_Right_Opnd
(Opnod
, Opnd
);
700 -- The type of the operation changes to the base type of the check
701 -- type, and we reset the overflow check indication, since clearly
702 -- no overflow is possible now that we are using a double length
703 -- type. We also set the Analyzed flag to avoid a recursive attempt
704 -- to expand the node.
706 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
707 Set_Do_Overflow_Check
(Opnod
, False);
708 Set_Analyzed
(Opnod
, True);
710 -- Now build the outer conversion
712 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
714 Set_Etype
(Opnd
, Typ
);
716 -- In the discrete type case, we directly generate the range check
717 -- for the outer operand. This range check will implement the required
720 if Is_Discrete_Type
(Typ
) then
722 Generate_Range_Check
(Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
724 -- For other types, we enable overflow checking on the conversion,
725 -- after setting the node as analyzed to prevent recursive attempts
726 -- to expand the conversion node.
729 Set_Analyzed
(Opnd
, True);
730 Enable_Overflow_Check
(Opnd
);
735 when RE_Not_Available
=>
737 end Apply_Arithmetic_Overflow_Check
;
739 ----------------------------
740 -- Apply_Array_Size_Check --
741 ----------------------------
743 -- The situation is as follows. In GNAT 3 (GCC 2.x), the size in bits
744 -- is computed in 32 bits without an overflow check. That's a real
745 -- problem for Ada. So what we do in GNAT 3 is to approximate the
746 -- size of an array by manually multiplying the element size by the
747 -- number of elements, and comparing that against the allowed limits.
749 -- In GNAT 5, the size in byte is still computed in 32 bits without
750 -- an overflow check in the dynamic case, but the size in bits is
751 -- computed in 64 bits. We assume that's good enough, and we do not
752 -- bother to generate any front end test.
754 procedure Apply_Array_Size_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
755 Loc
: constant Source_Ptr
:= Sloc
(N
);
756 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
757 Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
769 Static
: Boolean := True;
770 -- Set false if any index subtye bound is non-static
772 Umark
: constant Uintp
.Save_Mark
:= Uintp
.Mark
;
773 -- We can throw away all the Uint computations here, since they are
774 -- done only to generate boolean test results.
777 -- Size to check against
779 function Is_Address_Or_Import
(Decl
: Node_Id
) return Boolean;
780 -- Determines if Decl is an address clause or Import/Interface pragma
781 -- that references the defining identifier of the current declaration.
783 --------------------------
784 -- Is_Address_Or_Import --
785 --------------------------
787 function Is_Address_Or_Import
(Decl
: Node_Id
) return Boolean is
789 if Nkind
(Decl
) = N_At_Clause
then
790 return Chars
(Identifier
(Decl
)) = Chars
(Ent
);
792 elsif Nkind
(Decl
) = N_Attribute_Definition_Clause
then
794 Chars
(Decl
) = Name_Address
796 Nkind
(Name
(Decl
)) = N_Identifier
798 Chars
(Name
(Decl
)) = Chars
(Ent
);
800 elsif Nkind
(Decl
) = N_Pragma
then
801 if (Chars
(Decl
) = Name_Import
803 Chars
(Decl
) = Name_Interface
)
804 and then Present
(Pragma_Argument_Associations
(Decl
))
807 F
: constant Node_Id
:=
808 First
(Pragma_Argument_Associations
(Decl
));
816 Nkind
(Expression
(Next
(F
))) = N_Identifier
818 Chars
(Expression
(Next
(F
))) = Chars
(Ent
);
828 end Is_Address_Or_Import
;
830 -- Start of processing for Apply_Array_Size_Check
833 -- Do size check on local arrays. We only need this in the GCC 2
834 -- case, since in GCC 3, we expect the back end to properly handle
835 -- things. This routine can be removed when we baseline GNAT 3.
837 if Opt
.GCC_Version
>= 3 then
841 -- No need for a check if not expanding
843 if not Expander_Active
then
847 -- No need for a check if checks are suppressed
849 if Storage_Checks_Suppressed
(Typ
) then
853 -- It is pointless to insert this check inside an init proc, because
854 -- that's too late, we have already built the object to be the right
855 -- size, and if it's too large, too bad!
857 if Inside_Init_Proc
then
861 -- Look head for pragma interface/import or address clause applying
862 -- to this entity. If found, we suppress the check entirely. For now
863 -- we only look ahead 20 declarations to stop this becoming too slow
864 -- Note that eventually this whole routine gets moved to gigi.
867 for Ctr
in 1 .. 20 loop
871 if Is_Address_Or_Import
(Decl
) then
876 -- First step is to calculate the maximum number of elements. For
877 -- this calculation, we use the actual size of the subtype if it is
878 -- static, and if a bound of a subtype is non-static, we go to the
879 -- bound of the base type.
882 Indx
:= First_Index
(Typ
);
883 while Present
(Indx
) loop
884 Xtyp
:= Etype
(Indx
);
885 Lo
:= Type_Low_Bound
(Xtyp
);
886 Hi
:= Type_High_Bound
(Xtyp
);
888 -- If any bound raises constraint error, we will never get this
889 -- far, so there is no need to generate any kind of check.
891 if Raises_Constraint_Error
(Lo
)
893 Raises_Constraint_Error
(Hi
)
895 Uintp
.Release
(Umark
);
899 -- Otherwise get bounds values
901 if Is_Static_Expression
(Lo
) then
902 Lob
:= Expr_Value
(Lo
);
904 Lob
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Xtyp
)));
908 if Is_Static_Expression
(Hi
) then
909 Hib
:= Expr_Value
(Hi
);
911 Hib
:= Expr_Value
(Type_High_Bound
(Base_Type
(Xtyp
)));
915 Siz
:= Siz
* UI_Max
(Hib
- Lob
+ 1, Uint_0
);
919 -- Compute the limit against which we want to check. For subprograms,
920 -- where the array will go on the stack, we use 8*2**24, which (in
921 -- bits) is the size of a 16 megabyte array.
923 if Is_Subprogram
(Scope
(Ent
)) then
924 Check_Siz
:= Uint_2
** 27;
926 Check_Siz
:= Uint_2
** 31;
929 -- If we have all static bounds and Siz is too large, then we know
930 -- we know we have a storage error right now, so generate message
932 if Static
and then Siz
>= Check_Siz
then
934 Make_Raise_Storage_Error
(Loc
,
935 Reason
=> SE_Object_Too_Large
));
936 Error_Msg_N
("?Storage_Error will be raised at run-time", N
);
937 Uintp
.Release
(Umark
);
941 -- Case of component size known at compile time. If the array
942 -- size is definitely in range, then we do not need a check.
944 if Known_Esize
(Ctyp
)
945 and then Siz
* Esize
(Ctyp
) < Check_Siz
947 Uintp
.Release
(Umark
);
951 -- Here if a dynamic check is required
953 -- What we do is to build an expression for the size of the array,
954 -- which is computed as the 'Size of the array component, times
955 -- the size of each dimension.
957 Uintp
.Release
(Umark
);
960 Make_Attribute_Reference
(Loc
,
961 Prefix
=> New_Occurrence_Of
(Ctyp
, Loc
),
962 Attribute_Name
=> Name_Size
);
964 Indx
:= First_Index
(Typ
);
965 for J
in 1 .. Number_Dimensions
(Typ
) loop
966 if Sloc
(Etype
(Indx
)) = Sloc
(N
) then
967 Ensure_Defined
(Etype
(Indx
), N
);
971 Make_Op_Multiply
(Loc
,
974 Make_Attribute_Reference
(Loc
,
975 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
976 Attribute_Name
=> Name_Length
,
977 Expressions
=> New_List
(
978 Make_Integer_Literal
(Loc
, J
))));
985 Make_Raise_Storage_Error
(Loc
,
990 Make_Integer_Literal
(Loc
,
991 Intval
=> Check_Siz
)),
992 Reason
=> SE_Object_Too_Large
);
994 Set_Size_Check_Code
(Defining_Identifier
(N
), Code
);
995 Insert_Action
(N
, Code
, Suppress
=> All_Checks
);
996 end Apply_Array_Size_Check
;
998 ----------------------------
999 -- Apply_Constraint_Check --
1000 ----------------------------
1002 procedure Apply_Constraint_Check
1005 No_Sliding
: Boolean := False)
1007 Desig_Typ
: Entity_Id
;
1010 if Inside_A_Generic
then
1013 elsif Is_Scalar_Type
(Typ
) then
1014 Apply_Scalar_Range_Check
(N
, Typ
);
1016 elsif Is_Array_Type
(Typ
) then
1018 -- A useful optimization: an aggregate with only an others clause
1019 -- always has the right bounds.
1021 if Nkind
(N
) = N_Aggregate
1022 and then No
(Expressions
(N
))
1024 (First
(Choices
(First
(Component_Associations
(N
)))))
1030 if Is_Constrained
(Typ
) then
1031 Apply_Length_Check
(N
, Typ
);
1034 Apply_Range_Check
(N
, Typ
);
1037 Apply_Range_Check
(N
, Typ
);
1040 elsif (Is_Record_Type
(Typ
)
1041 or else Is_Private_Type
(Typ
))
1042 and then Has_Discriminants
(Base_Type
(Typ
))
1043 and then Is_Constrained
(Typ
)
1045 Apply_Discriminant_Check
(N
, Typ
);
1047 elsif Is_Access_Type
(Typ
) then
1049 Desig_Typ
:= Designated_Type
(Typ
);
1051 -- No checks necessary if expression statically null
1053 if Nkind
(N
) = N_Null
then
1056 -- No sliding possible on access to arrays
1058 elsif Is_Array_Type
(Desig_Typ
) then
1059 if Is_Constrained
(Desig_Typ
) then
1060 Apply_Length_Check
(N
, Typ
);
1063 Apply_Range_Check
(N
, Typ
);
1065 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
1066 and then Is_Constrained
(Desig_Typ
)
1068 Apply_Discriminant_Check
(N
, Typ
);
1071 if Can_Never_Be_Null
(Typ
)
1072 and then not Can_Never_Be_Null
(Etype
(N
))
1074 Install_Null_Excluding_Check
(N
);
1077 end Apply_Constraint_Check
;
1079 ------------------------------
1080 -- Apply_Discriminant_Check --
1081 ------------------------------
1083 procedure Apply_Discriminant_Check
1086 Lhs
: Node_Id
:= Empty
)
1088 Loc
: constant Source_Ptr
:= Sloc
(N
);
1089 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1090 S_Typ
: Entity_Id
:= Etype
(N
);
1094 function Is_Aliased_Unconstrained_Component
return Boolean;
1095 -- It is possible for an aliased component to have a nominal
1096 -- unconstrained subtype (through instantiation). If this is a
1097 -- discriminated component assigned in the expansion of an aggregate
1098 -- in an initialization, the check must be suppressed. This unusual
1099 -- situation requires a predicate of its own (see 7503-008).
1101 ----------------------------------------
1102 -- Is_Aliased_Unconstrained_Component --
1103 ----------------------------------------
1105 function Is_Aliased_Unconstrained_Component
return Boolean is
1110 if Nkind
(Lhs
) /= N_Selected_Component
then
1113 Comp
:= Entity
(Selector_Name
(Lhs
));
1114 Pref
:= Prefix
(Lhs
);
1117 if Ekind
(Comp
) /= E_Component
1118 or else not Is_Aliased
(Comp
)
1123 return not Comes_From_Source
(Pref
)
1124 and then In_Instance
1125 and then not Is_Constrained
(Etype
(Comp
));
1126 end Is_Aliased_Unconstrained_Component
;
1128 -- Start of processing for Apply_Discriminant_Check
1132 T_Typ
:= Designated_Type
(Typ
);
1137 -- Nothing to do if discriminant checks are suppressed or else no code
1138 -- is to be generated
1140 if not Expander_Active
1141 or else Discriminant_Checks_Suppressed
(T_Typ
)
1146 -- No discriminant checks necessary for an access when expression
1147 -- is statically Null. This is not only an optimization, this is
1148 -- fundamental because otherwise discriminant checks may be generated
1149 -- in init procs for types containing an access to a not-yet-frozen
1150 -- record, causing a deadly forward reference.
1152 -- Also, if the expression is of an access type whose designated
1153 -- type is incomplete, then the access value must be null and
1154 -- we suppress the check.
1156 if Nkind
(N
) = N_Null
then
1159 elsif Is_Access_Type
(S_Typ
) then
1160 S_Typ
:= Designated_Type
(S_Typ
);
1162 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1167 -- If an assignment target is present, then we need to generate
1168 -- the actual subtype if the target is a parameter or aliased
1169 -- object with an unconstrained nominal subtype.
1172 and then (Present
(Param_Entity
(Lhs
))
1173 or else (not Is_Constrained
(T_Typ
)
1174 and then Is_Aliased_View
(Lhs
)
1175 and then not Is_Aliased_Unconstrained_Component
))
1177 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1180 -- Nothing to do if the type is unconstrained (this is the case
1181 -- where the actual subtype in the RM sense of N is unconstrained
1182 -- and no check is required).
1184 if not Is_Constrained
(T_Typ
) then
1187 -- Ada 2005: nothing to do if the type is one for which there is a
1188 -- partial view that is constrained.
1190 elsif Ada_Version
>= Ada_05
1191 and then Has_Constrained_Partial_View
(Base_Type
(T_Typ
))
1196 -- Nothing to do if the type is an Unchecked_Union
1198 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
1202 -- Suppress checks if the subtypes are the same.
1203 -- the check must be preserved in an assignment to a formal, because
1204 -- the constraint is given by the actual.
1206 if Nkind
(Original_Node
(N
)) /= N_Allocator
1208 or else not Is_Entity_Name
(Lhs
)
1209 or else No
(Param_Entity
(Lhs
)))
1212 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1213 and then not Is_Aliased_View
(Lhs
)
1218 -- We can also eliminate checks on allocators with a subtype mark
1219 -- that coincides with the context type. The context type may be a
1220 -- subtype without a constraint (common case, a generic actual).
1222 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1223 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1226 Alloc_Typ
: constant Entity_Id
:=
1227 Entity
(Expression
(Original_Node
(N
)));
1230 if Alloc_Typ
= T_Typ
1231 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1232 and then Is_Entity_Name
(
1233 Subtype_Indication
(Parent
(T_Typ
)))
1234 and then Alloc_Typ
= Base_Type
(T_Typ
))
1242 -- See if we have a case where the types are both constrained, and
1243 -- all the constraints are constants. In this case, we can do the
1244 -- check successfully at compile time.
1246 -- We skip this check for the case where the node is a rewritten`
1247 -- allocator, because it already carries the context subtype, and
1248 -- extracting the discriminants from the aggregate is messy.
1250 if Is_Constrained
(S_Typ
)
1251 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1261 -- S_Typ may not have discriminants in the case where it is a
1262 -- private type completed by a default discriminated type. In
1263 -- that case, we need to get the constraints from the
1264 -- underlying_type. If the underlying type is unconstrained (i.e.
1265 -- has no default discriminants) no check is needed.
1267 if Has_Discriminants
(S_Typ
) then
1268 Discr
:= First_Discriminant
(S_Typ
);
1269 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1272 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1275 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1281 -- A further optimization: if T_Typ is derived from S_Typ
1282 -- without imposing a constraint, no check is needed.
1284 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1285 N_Full_Type_Declaration
1288 Type_Def
: constant Node_Id
:=
1290 (Original_Node
(Parent
(T_Typ
)));
1292 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1293 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1294 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1302 DconT
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
1304 while Present
(Discr
) loop
1305 ItemS
:= Node
(DconS
);
1306 ItemT
:= Node
(DconT
);
1309 not Is_OK_Static_Expression
(ItemS
)
1311 not Is_OK_Static_Expression
(ItemT
);
1313 if Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1314 if Do_Access
then -- needs run-time check.
1317 Apply_Compile_Time_Constraint_Error
1318 (N
, "incorrect value for discriminant&?",
1319 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1326 Next_Discriminant
(Discr
);
1335 -- Here we need a discriminant check. First build the expression
1336 -- for the comparisons of the discriminants:
1338 -- (n.disc1 /= typ.disc1) or else
1339 -- (n.disc2 /= typ.disc2) or else
1341 -- (n.discn /= typ.discn)
1343 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1345 -- If Lhs is set and is a parameter, then the condition is
1346 -- guarded by: lhs'constrained and then (condition built above)
1348 if Present
(Param_Entity
(Lhs
)) then
1352 Make_Attribute_Reference
(Loc
,
1353 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1354 Attribute_Name
=> Name_Constrained
),
1355 Right_Opnd
=> Cond
);
1359 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1363 Make_Raise_Constraint_Error
(Loc
,
1365 Reason
=> CE_Discriminant_Check_Failed
));
1366 end Apply_Discriminant_Check
;
1368 ------------------------
1369 -- Apply_Divide_Check --
1370 ------------------------
1372 procedure Apply_Divide_Check
(N
: Node_Id
) is
1373 Loc
: constant Source_Ptr
:= Sloc
(N
);
1374 Typ
: constant Entity_Id
:= Etype
(N
);
1375 Left
: constant Node_Id
:= Left_Opnd
(N
);
1376 Right
: constant Node_Id
:= Right_Opnd
(N
);
1388 and then not Backend_Divide_Checks_On_Target
1389 and then Check_Needed
(Right
, Division_Check
)
1391 Determine_Range
(Right
, ROK
, Rlo
, Rhi
);
1393 -- See if division by zero possible, and if so generate test. This
1394 -- part of the test is not controlled by the -gnato switch.
1396 if Do_Division_Check
(N
) then
1397 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1399 Make_Raise_Constraint_Error
(Loc
,
1402 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1403 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1404 Reason
=> CE_Divide_By_Zero
));
1408 -- Test for extremely annoying case of xxx'First divided by -1
1410 if Do_Overflow_Check
(N
) then
1411 if Nkind
(N
) = N_Op_Divide
1412 and then Is_Signed_Integer_Type
(Typ
)
1414 Determine_Range
(Left
, LOK
, Llo
, Lhi
);
1415 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1417 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1419 ((not LOK
) or else (Llo
= LLB
))
1422 Make_Raise_Constraint_Error
(Loc
,
1428 Duplicate_Subexpr_Move_Checks
(Left
),
1429 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1433 Duplicate_Subexpr
(Right
),
1435 Make_Integer_Literal
(Loc
, -1))),
1436 Reason
=> CE_Overflow_Check_Failed
));
1441 end Apply_Divide_Check
;
1443 ----------------------------------
1444 -- Apply_Float_Conversion_Check --
1445 ----------------------------------
1447 -- Let F and I be the source and target types of the conversion.
1448 -- The Ada standard specifies that a floating-point value X is rounded
1449 -- to the nearest integer, with halfway cases being rounded away from
1450 -- zero. The rounded value of X is checked against I'Range.
1452 -- The catch in the above paragraph is that there is no good way
1453 -- to know whether the round-to-integer operation resulted in
1454 -- overflow. A remedy is to perform a range check in the floating-point
1455 -- domain instead, however:
1456 -- (1) The bounds may not be known at compile time
1457 -- (2) The check must take into account possible rounding.
1458 -- (3) The range of type I may not be exactly representable in F.
1459 -- (4) The end-points I'First - 0.5 and I'Last + 0.5 may or may
1460 -- not be in range, depending on the sign of I'First and I'Last.
1461 -- (5) X may be a NaN, which will fail any comparison
1463 -- The following steps take care of these issues converting X:
1464 -- (1) If either I'First or I'Last is not known at compile time, use
1465 -- I'Base instead of I in the next three steps and perform a
1466 -- regular range check against I'Range after conversion.
1467 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1468 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1469 -- F'Machine (T) and let Lo_OK be (Lo >= I'First). In other words,
1470 -- take one of the closest floating-point numbers to T, and see if
1471 -- it is in range or not.
1472 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1473 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1474 -- F'Rounding (T) and let Hi_OK be (Hi <= I'Last).
1475 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1476 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1478 procedure Apply_Float_Conversion_Check
1480 Target_Typ
: Entity_Id
)
1482 LB
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1483 HB
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1484 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1485 Expr_Type
: constant Entity_Id
:= Base_Type
(Etype
(Ck_Node
));
1486 Target_Base
: constant Entity_Id
:= Implementation_Base_Type
1488 Max_Bound
: constant Uint
:= UI_Expon
1489 (Machine_Radix
(Expr_Type
),
1490 Machine_Mantissa
(Expr_Type
) - 1) - 1;
1491 -- Largest bound, so bound plus or minus half is a machine number of F
1494 Ilast
: Uint
; -- Bounds of integer type
1495 Lo
, Hi
: Ureal
; -- Bounds to check in floating-point domain
1497 Hi_OK
: Boolean; -- True iff Lo resp. Hi belongs to I'Range
1500 Hi_Chk
: Node_Id
; -- Expressions that are False iff check fails
1502 Reason
: RT_Exception_Code
;
1505 if not Compile_Time_Known_Value
(LB
)
1506 or not Compile_Time_Known_Value
(HB
)
1509 -- First check that the value falls in the range of the base
1510 -- type, to prevent overflow during conversion and then
1511 -- perform a regular range check against the (dynamic) bounds.
1513 Par
: constant Node_Id
:= Parent
(Ck_Node
);
1515 pragma Assert
(Target_Base
/= Target_Typ
);
1516 pragma Assert
(Nkind
(Par
) = N_Type_Conversion
);
1518 Temp
: constant Entity_Id
:=
1519 Make_Defining_Identifier
(Loc
,
1520 Chars
=> New_Internal_Name
('T'));
1523 Apply_Float_Conversion_Check
(Ck_Node
, Target_Base
);
1524 Set_Etype
(Temp
, Target_Base
);
1526 Insert_Action
(Parent
(Par
),
1527 Make_Object_Declaration
(Loc
,
1528 Defining_Identifier
=> Temp
,
1529 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
),
1530 Expression
=> New_Copy_Tree
(Par
)),
1531 Suppress
=> All_Checks
);
1534 Make_Raise_Constraint_Error
(Loc
,
1537 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
1538 Right_Opnd
=> New_Occurrence_Of
(Target_Typ
, Loc
)),
1539 Reason
=> CE_Range_Check_Failed
));
1540 Rewrite
(Par
, New_Occurrence_Of
(Temp
, Loc
));
1546 -- Get the bounds of the target type
1548 Ifirst
:= Expr_Value
(LB
);
1549 Ilast
:= Expr_Value
(HB
);
1551 -- Check against lower bound
1553 if abs (Ifirst
) < Max_Bound
then
1554 Lo
:= UR_From_Uint
(Ifirst
) - Ureal_Half
;
1555 Lo_OK
:= (Ifirst
> 0);
1557 Lo
:= Machine
(Expr_Type
, UR_From_Uint
(Ifirst
), Round_Even
, Ck_Node
);
1558 Lo_OK
:= (Lo
>= UR_From_Uint
(Ifirst
));
1563 -- Lo_Chk := (X >= Lo)
1565 Lo_Chk
:= Make_Op_Ge
(Loc
,
1566 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1567 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
1570 -- Lo_Chk := (X > Lo)
1572 Lo_Chk
:= Make_Op_Gt
(Loc
,
1573 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1574 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
1577 -- Check against higher bound
1579 if abs (Ilast
) < Max_Bound
then
1580 Hi
:= UR_From_Uint
(Ilast
) + Ureal_Half
;
1581 Hi_OK
:= (Ilast
< 0);
1583 Hi
:= Machine
(Expr_Type
, UR_From_Uint
(Ilast
), Round_Even
, Ck_Node
);
1584 Hi_OK
:= (Hi
<= UR_From_Uint
(Ilast
));
1589 -- Hi_Chk := (X <= Hi)
1591 Hi_Chk
:= Make_Op_Le
(Loc
,
1592 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1593 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
1596 -- Hi_Chk := (X < Hi)
1598 Hi_Chk
:= Make_Op_Lt
(Loc
,
1599 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1600 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
1603 -- If the bounds of the target type are the same as those of the
1604 -- base type, the check is an overflow check as a range check is
1605 -- not performed in these cases.
1607 if Expr_Value
(Type_Low_Bound
(Target_Base
)) = Ifirst
1608 and then Expr_Value
(Type_High_Bound
(Target_Base
)) = Ilast
1610 Reason
:= CE_Overflow_Check_Failed
;
1612 Reason
:= CE_Range_Check_Failed
;
1615 -- Raise CE if either conditions does not hold
1617 Insert_Action
(Ck_Node
,
1618 Make_Raise_Constraint_Error
(Loc
,
1619 Condition
=> Make_Op_Not
(Loc
, Make_And_Then
(Loc
, Lo_Chk
, Hi_Chk
)),
1621 end Apply_Float_Conversion_Check
;
1623 ------------------------
1624 -- Apply_Length_Check --
1625 ------------------------
1627 procedure Apply_Length_Check
1629 Target_Typ
: Entity_Id
;
1630 Source_Typ
: Entity_Id
:= Empty
)
1633 Apply_Selected_Length_Checks
1634 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
1635 end Apply_Length_Check
;
1637 -----------------------
1638 -- Apply_Range_Check --
1639 -----------------------
1641 procedure Apply_Range_Check
1643 Target_Typ
: Entity_Id
;
1644 Source_Typ
: Entity_Id
:= Empty
)
1647 Apply_Selected_Range_Checks
1648 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
1649 end Apply_Range_Check
;
1651 ------------------------------
1652 -- Apply_Scalar_Range_Check --
1653 ------------------------------
1655 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check
1656 -- flag off if it is already set on.
1658 procedure Apply_Scalar_Range_Check
1660 Target_Typ
: Entity_Id
;
1661 Source_Typ
: Entity_Id
:= Empty
;
1662 Fixed_Int
: Boolean := False)
1664 Parnt
: constant Node_Id
:= Parent
(Expr
);
1666 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
1667 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
1670 Is_Subscr_Ref
: Boolean;
1671 -- Set true if Expr is a subscript
1673 Is_Unconstrained_Subscr_Ref
: Boolean;
1674 -- Set true if Expr is a subscript of an unconstrained array. In this
1675 -- case we do not attempt to do an analysis of the value against the
1676 -- range of the subscript, since we don't know the actual subtype.
1679 -- Set to True if Expr should be regarded as a real value
1680 -- even though the type of Expr might be discrete.
1682 procedure Bad_Value
;
1683 -- Procedure called if value is determined to be out of range
1689 procedure Bad_Value
is
1691 Apply_Compile_Time_Constraint_Error
1692 (Expr
, "value not in range of}?", CE_Range_Check_Failed
,
1697 -- Start of processing for Apply_Scalar_Range_Check
1700 if Inside_A_Generic
then
1703 -- Return if check obviously not needed. Note that we do not check
1704 -- for the expander being inactive, since this routine does not
1705 -- insert any code, but it does generate useful warnings sometimes,
1706 -- which we would like even if we are in semantics only mode.
1708 elsif Target_Typ
= Any_Type
1709 or else not Is_Scalar_Type
(Target_Typ
)
1710 or else Raises_Constraint_Error
(Expr
)
1715 -- Now, see if checks are suppressed
1718 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
1720 if Is_Subscr_Ref
then
1721 Arr
:= Prefix
(Parnt
);
1722 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
1725 if not Do_Range_Check
(Expr
) then
1727 -- Subscript reference. Check for Index_Checks suppressed
1729 if Is_Subscr_Ref
then
1731 -- Check array type and its base type
1733 if Index_Checks_Suppressed
(Arr_Typ
)
1734 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
1738 -- Check array itself if it is an entity name
1740 elsif Is_Entity_Name
(Arr
)
1741 and then Index_Checks_Suppressed
(Entity
(Arr
))
1745 -- Check expression itself if it is an entity name
1747 elsif Is_Entity_Name
(Expr
)
1748 and then Index_Checks_Suppressed
(Entity
(Expr
))
1753 -- All other cases, check for Range_Checks suppressed
1756 -- Check target type and its base type
1758 if Range_Checks_Suppressed
(Target_Typ
)
1759 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
1763 -- Check expression itself if it is an entity name
1765 elsif Is_Entity_Name
(Expr
)
1766 and then Range_Checks_Suppressed
(Entity
(Expr
))
1770 -- If Expr is part of an assignment statement, then check
1771 -- left side of assignment if it is an entity name.
1773 elsif Nkind
(Parnt
) = N_Assignment_Statement
1774 and then Is_Entity_Name
(Name
(Parnt
))
1775 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
1782 -- Do not set range checks if they are killed
1784 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
1785 and then Kill_Range_Check
(Expr
)
1790 -- Do not set range checks for any values from System.Scalar_Values
1791 -- since the whole idea of such values is to avoid checking them!
1793 if Is_Entity_Name
(Expr
)
1794 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
1799 -- Now see if we need a check
1801 if No
(Source_Typ
) then
1802 S_Typ
:= Etype
(Expr
);
1804 S_Typ
:= Source_Typ
;
1807 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
1811 Is_Unconstrained_Subscr_Ref
:=
1812 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
1814 -- Always do a range check if the source type includes infinities
1815 -- and the target type does not include infinities. We do not do
1816 -- this if range checks are killed.
1818 if Is_Floating_Point_Type
(S_Typ
)
1819 and then Has_Infinities
(S_Typ
)
1820 and then not Has_Infinities
(Target_Typ
)
1822 Enable_Range_Check
(Expr
);
1825 -- Return if we know expression is definitely in the range of
1826 -- the target type as determined by Determine_Range. Right now
1827 -- we only do this for discrete types, and not fixed-point or
1828 -- floating-point types.
1830 -- The additional less-precise tests below catch these cases
1832 -- Note: skip this if we are given a source_typ, since the point
1833 -- of supplying a Source_Typ is to stop us looking at the expression.
1834 -- could sharpen this test to be out parameters only ???
1836 if Is_Discrete_Type
(Target_Typ
)
1837 and then Is_Discrete_Type
(Etype
(Expr
))
1838 and then not Is_Unconstrained_Subscr_Ref
1839 and then No
(Source_Typ
)
1842 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1843 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1848 if Compile_Time_Known_Value
(Tlo
)
1849 and then Compile_Time_Known_Value
(Thi
)
1852 Lov
: constant Uint
:= Expr_Value
(Tlo
);
1853 Hiv
: constant Uint
:= Expr_Value
(Thi
);
1856 -- If range is null, we for sure have a constraint error
1857 -- (we don't even need to look at the value involved,
1858 -- since all possible values will raise CE).
1865 -- Otherwise determine range of value
1867 Determine_Range
(Expr
, OK
, Lo
, Hi
);
1871 -- If definitely in range, all OK
1873 if Lo
>= Lov
and then Hi
<= Hiv
then
1876 -- If definitely not in range, warn
1878 elsif Lov
> Hi
or else Hiv
< Lo
then
1882 -- Otherwise we don't know
1894 Is_Floating_Point_Type
(S_Typ
)
1895 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
1897 -- Check if we can determine at compile time whether Expr is in the
1898 -- range of the target type. Note that if S_Typ is within the bounds
1899 -- of Target_Typ then this must be the case. This check is meaningful
1900 -- only if this is not a conversion between integer and real types.
1902 if not Is_Unconstrained_Subscr_Ref
1904 Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
1906 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
1908 Is_In_Range
(Expr
, Target_Typ
, Fixed_Int
, Int_Real
))
1912 elsif Is_Out_Of_Range
(Expr
, Target_Typ
, Fixed_Int
, Int_Real
) then
1916 -- In the floating-point case, we only do range checks if the
1917 -- type is constrained. We definitely do NOT want range checks
1918 -- for unconstrained types, since we want to have infinities
1920 elsif Is_Floating_Point_Type
(S_Typ
) then
1921 if Is_Constrained
(S_Typ
) then
1922 Enable_Range_Check
(Expr
);
1925 -- For all other cases we enable a range check unconditionally
1928 Enable_Range_Check
(Expr
);
1931 end Apply_Scalar_Range_Check
;
1933 ----------------------------------
1934 -- Apply_Selected_Length_Checks --
1935 ----------------------------------
1937 procedure Apply_Selected_Length_Checks
1939 Target_Typ
: Entity_Id
;
1940 Source_Typ
: Entity_Id
;
1941 Do_Static
: Boolean)
1944 R_Result
: Check_Result
;
1947 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1948 Checks_On
: constant Boolean :=
1949 (not Index_Checks_Suppressed
(Target_Typ
))
1951 (not Length_Checks_Suppressed
(Target_Typ
));
1954 if not Expander_Active
then
1959 Selected_Length_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
1961 for J
in 1 .. 2 loop
1962 R_Cno
:= R_Result
(J
);
1963 exit when No
(R_Cno
);
1965 -- A length check may mention an Itype which is attached to a
1966 -- subsequent node. At the top level in a package this can cause
1967 -- an order-of-elaboration problem, so we make sure that the itype
1968 -- is referenced now.
1970 if Ekind
(Current_Scope
) = E_Package
1971 and then Is_Compilation_Unit
(Current_Scope
)
1973 Ensure_Defined
(Target_Typ
, Ck_Node
);
1975 if Present
(Source_Typ
) then
1976 Ensure_Defined
(Source_Typ
, Ck_Node
);
1978 elsif Is_Itype
(Etype
(Ck_Node
)) then
1979 Ensure_Defined
(Etype
(Ck_Node
), Ck_Node
);
1983 -- If the item is a conditional raise of constraint error,
1984 -- then have a look at what check is being performed and
1987 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
1988 and then Present
(Condition
(R_Cno
))
1990 Cond
:= Condition
(R_Cno
);
1992 if not Has_Dynamic_Length_Check
(Ck_Node
)
1995 Insert_Action
(Ck_Node
, R_Cno
);
1997 if not Do_Static
then
1998 Set_Has_Dynamic_Length_Check
(Ck_Node
);
2002 -- Output a warning if the condition is known to be True
2004 if Is_Entity_Name
(Cond
)
2005 and then Entity
(Cond
) = Standard_True
2007 Apply_Compile_Time_Constraint_Error
2008 (Ck_Node
, "wrong length for array of}?",
2009 CE_Length_Check_Failed
,
2013 -- If we were only doing a static check, or if checks are not
2014 -- on, then we want to delete the check, since it is not needed.
2015 -- We do this by replacing the if statement by a null statement
2017 elsif Do_Static
or else not Checks_On
then
2018 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
2022 Install_Static_Check
(R_Cno
, Loc
);
2027 end Apply_Selected_Length_Checks
;
2029 ---------------------------------
2030 -- Apply_Selected_Range_Checks --
2031 ---------------------------------
2033 procedure Apply_Selected_Range_Checks
2035 Target_Typ
: Entity_Id
;
2036 Source_Typ
: Entity_Id
;
2037 Do_Static
: Boolean)
2040 R_Result
: Check_Result
;
2043 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
2044 Checks_On
: constant Boolean :=
2045 (not Index_Checks_Suppressed
(Target_Typ
))
2047 (not Range_Checks_Suppressed
(Target_Typ
));
2050 if not Expander_Active
or else not Checks_On
then
2055 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
2057 for J
in 1 .. 2 loop
2059 R_Cno
:= R_Result
(J
);
2060 exit when No
(R_Cno
);
2062 -- If the item is a conditional raise of constraint error,
2063 -- then have a look at what check is being performed and
2066 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
2067 and then Present
(Condition
(R_Cno
))
2069 Cond
:= Condition
(R_Cno
);
2071 if not Has_Dynamic_Range_Check
(Ck_Node
) then
2072 Insert_Action
(Ck_Node
, R_Cno
);
2074 if not Do_Static
then
2075 Set_Has_Dynamic_Range_Check
(Ck_Node
);
2079 -- Output a warning if the condition is known to be True
2081 if Is_Entity_Name
(Cond
)
2082 and then Entity
(Cond
) = Standard_True
2084 -- Since an N_Range is technically not an expression, we
2085 -- have to set one of the bounds to C_E and then just flag
2086 -- the N_Range. The warning message will point to the
2087 -- lower bound and complain about a range, which seems OK.
2089 if Nkind
(Ck_Node
) = N_Range
then
2090 Apply_Compile_Time_Constraint_Error
2091 (Low_Bound
(Ck_Node
), "static range out of bounds of}?",
2092 CE_Range_Check_Failed
,
2096 Set_Raises_Constraint_Error
(Ck_Node
);
2099 Apply_Compile_Time_Constraint_Error
2100 (Ck_Node
, "static value out of range of}?",
2101 CE_Range_Check_Failed
,
2106 -- If we were only doing a static check, or if checks are not
2107 -- on, then we want to delete the check, since it is not needed.
2108 -- We do this by replacing the if statement by a null statement
2110 elsif Do_Static
or else not Checks_On
then
2111 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
2115 Install_Static_Check
(R_Cno
, Loc
);
2118 end Apply_Selected_Range_Checks
;
2120 -------------------------------
2121 -- Apply_Static_Length_Check --
2122 -------------------------------
2124 procedure Apply_Static_Length_Check
2126 Target_Typ
: Entity_Id
;
2127 Source_Typ
: Entity_Id
:= Empty
)
2130 Apply_Selected_Length_Checks
2131 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
2132 end Apply_Static_Length_Check
;
2134 -------------------------------------
2135 -- Apply_Subscript_Validity_Checks --
2136 -------------------------------------
2138 procedure Apply_Subscript_Validity_Checks
(Expr
: Node_Id
) is
2142 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
2144 -- Loop through subscripts
2146 Sub
:= First
(Expressions
(Expr
));
2147 while Present
(Sub
) loop
2149 -- Check one subscript. Note that we do not worry about
2150 -- enumeration type with holes, since we will convert the
2151 -- value to a Pos value for the subscript, and that convert
2152 -- will do the necessary validity check.
2154 Ensure_Valid
(Sub
, Holes_OK
=> True);
2156 -- Move to next subscript
2160 end Apply_Subscript_Validity_Checks
;
2162 ----------------------------------
2163 -- Apply_Type_Conversion_Checks --
2164 ----------------------------------
2166 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
2167 Target_Type
: constant Entity_Id
:= Etype
(N
);
2168 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
2169 Expr
: constant Node_Id
:= Expression
(N
);
2170 Expr_Type
: constant Entity_Id
:= Etype
(Expr
);
2173 if Inside_A_Generic
then
2176 -- Skip these checks if serious errors detected, there are some nasty
2177 -- situations of incomplete trees that blow things up.
2179 elsif Serious_Errors_Detected
> 0 then
2182 -- Scalar type conversions of the form Target_Type (Expr) require
2183 -- a range check if we cannot be sure that Expr is in the base type
2184 -- of Target_Typ and also that Expr is in the range of Target_Typ.
2185 -- These are not quite the same condition from an implementation
2186 -- point of view, but clearly the second includes the first.
2188 elsif Is_Scalar_Type
(Target_Type
) then
2190 Conv_OK
: constant Boolean := Conversion_OK
(N
);
2191 -- If the Conversion_OK flag on the type conversion is set
2192 -- and no floating point type is involved in the type conversion
2193 -- then fixed point values must be read as integral values.
2195 Float_To_Int
: constant Boolean :=
2196 Is_Floating_Point_Type
(Expr_Type
)
2197 and then Is_Integer_Type
(Target_Type
);
2200 if not Overflow_Checks_Suppressed
(Target_Base
)
2201 and then not In_Subrange_Of
(Expr_Type
, Target_Base
, Conv_OK
)
2202 and then not Float_To_Int
2204 Set_Do_Overflow_Check
(N
);
2207 if not Range_Checks_Suppressed
(Target_Type
)
2208 and then not Range_Checks_Suppressed
(Expr_Type
)
2210 if Float_To_Int
then
2211 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
2213 Apply_Scalar_Range_Check
2214 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
2219 elsif Comes_From_Source
(N
)
2220 and then Is_Record_Type
(Target_Type
)
2221 and then Is_Derived_Type
(Target_Type
)
2222 and then not Is_Tagged_Type
(Target_Type
)
2223 and then not Is_Constrained
(Target_Type
)
2224 and then Present
(Stored_Constraint
(Target_Type
))
2226 -- An unconstrained derived type may have inherited discriminant
2227 -- Build an actual discriminant constraint list using the stored
2228 -- constraint, to verify that the expression of the parent type
2229 -- satisfies the constraints imposed by the (unconstrained!)
2230 -- derived type. This applies to value conversions, not to view
2231 -- conversions of tagged types.
2234 Loc
: constant Source_Ptr
:= Sloc
(N
);
2236 Constraint
: Elmt_Id
;
2237 Discr_Value
: Node_Id
;
2240 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
2241 Old_Constraints
: constant Elist_Id
:=
2242 Discriminant_Constraint
(Expr_Type
);
2245 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
2247 while Present
(Constraint
) loop
2248 Discr_Value
:= Node
(Constraint
);
2250 if Is_Entity_Name
(Discr_Value
)
2251 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
2253 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
2256 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
2258 -- Parent is constrained by new discriminant. Obtain
2259 -- Value of original discriminant in expression. If
2260 -- the new discriminant has been used to constrain more
2261 -- than one of the stored discriminants, this will
2262 -- provide the required consistency check.
2265 Make_Selected_Component
(Loc
,
2267 Duplicate_Subexpr_No_Checks
2268 (Expr
, Name_Req
=> True),
2270 Make_Identifier
(Loc
, Chars
(Discr
))),
2274 -- Discriminant of more remote ancestor ???
2279 -- Derived type definition has an explicit value for
2280 -- this stored discriminant.
2284 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
2288 Next_Elmt
(Constraint
);
2291 -- Use the unconstrained expression type to retrieve the
2292 -- discriminants of the parent, and apply momentarily the
2293 -- discriminant constraint synthesized above.
2295 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
2296 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
2297 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
2300 Make_Raise_Constraint_Error
(Loc
,
2302 Reason
=> CE_Discriminant_Check_Failed
));
2305 -- For arrays, conversions are applied during expansion, to take
2306 -- into accounts changes of representation. The checks become range
2307 -- checks on the base type or length checks on the subtype, depending
2308 -- on whether the target type is unconstrained or constrained.
2313 end Apply_Type_Conversion_Checks
;
2315 ----------------------------------------------
2316 -- Apply_Universal_Integer_Attribute_Checks --
2317 ----------------------------------------------
2319 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
2320 Loc
: constant Source_Ptr
:= Sloc
(N
);
2321 Typ
: constant Entity_Id
:= Etype
(N
);
2324 if Inside_A_Generic
then
2327 -- Nothing to do if checks are suppressed
2329 elsif Range_Checks_Suppressed
(Typ
)
2330 and then Overflow_Checks_Suppressed
(Typ
)
2334 -- Nothing to do if the attribute does not come from source. The
2335 -- internal attributes we generate of this type do not need checks,
2336 -- and furthermore the attempt to check them causes some circular
2337 -- elaboration orders when dealing with packed types.
2339 elsif not Comes_From_Source
(N
) then
2342 -- If the prefix is a selected component that depends on a discriminant
2343 -- the check may improperly expose a discriminant instead of using
2344 -- the bounds of the object itself. Set the type of the attribute to
2345 -- the base type of the context, so that a check will be imposed when
2346 -- needed (e.g. if the node appears as an index).
2348 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
2349 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
2350 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
2352 Set_Etype
(N
, Base_Type
(Typ
));
2354 -- Otherwise, replace the attribute node with a type conversion
2355 -- node whose expression is the attribute, retyped to universal
2356 -- integer, and whose subtype mark is the target type. The call
2357 -- to analyze this conversion will set range and overflow checks
2358 -- as required for proper detection of an out of range value.
2361 Set_Etype
(N
, Universal_Integer
);
2362 Set_Analyzed
(N
, True);
2365 Make_Type_Conversion
(Loc
,
2366 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
2367 Expression
=> Relocate_Node
(N
)));
2369 Analyze_And_Resolve
(N
, Typ
);
2373 end Apply_Universal_Integer_Attribute_Checks
;
2375 -------------------------------
2376 -- Build_Discriminant_Checks --
2377 -------------------------------
2379 function Build_Discriminant_Checks
2381 T_Typ
: Entity_Id
) return Node_Id
2383 Loc
: constant Source_Ptr
:= Sloc
(N
);
2386 Disc_Ent
: Entity_Id
;
2392 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
2394 -- For a fully private type, use the discriminants of the parent type
2396 if Is_Private_Type
(T_Typ
)
2397 and then No
(Full_View
(T_Typ
))
2399 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
2401 Disc_Ent
:= First_Discriminant
(T_Typ
);
2404 while Present
(Disc
) loop
2405 Dval
:= Node
(Disc
);
2407 if Nkind
(Dval
) = N_Identifier
2408 and then Ekind
(Entity
(Dval
)) = E_Discriminant
2410 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
2412 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
2415 -- If we have an Unchecked_Union node, we can infer the discriminants
2418 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
2420 Get_Discriminant_Value
(
2421 First_Discriminant
(T_Typ
),
2423 Stored_Constraint
(T_Typ
)));
2427 Make_Selected_Component
(Loc
,
2429 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
2431 Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
2433 Set_Is_In_Discriminant_Check
(Dref
);
2436 Evolve_Or_Else
(Cond
,
2439 Right_Opnd
=> Dval
));
2442 Next_Discriminant
(Disc_Ent
);
2446 end Build_Discriminant_Checks
;
2452 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
2460 -- Always check if not simple entity
2462 if Nkind
(Nod
) not in N_Has_Entity
2463 or else not Comes_From_Source
(Nod
)
2468 -- Look up tree for short circuit
2475 if K
not in N_Subexpr
then
2478 -- Or/Or Else case, left operand must be equality test
2480 elsif K
= N_Op_Or
or else K
= N_Or_Else
then
2481 exit when N
= Right_Opnd
(P
)
2482 and then Nkind
(Left_Opnd
(P
)) = N_Op_Eq
;
2484 -- And/And then case, left operand must be inequality test. Note that
2485 -- at this stage, the expander will have changed a/=b to not (a=b).
2487 elsif K
= N_Op_And
or else K
= N_And_Then
then
2488 exit when N
= Right_Opnd
(P
)
2489 and then Nkind
(Left_Opnd
(P
)) = N_Op_Not
2490 and then Nkind
(Right_Opnd
(Left_Opnd
(P
))) = N_Op_Eq
;
2496 -- If we fall through the loop, then we have a conditional with an
2497 -- appropriate test as its left operand. So test further.
2501 if Nkind
(L
) = N_Op_Not
then
2502 L
:= Right_Opnd
(L
);
2505 R
:= Right_Opnd
(L
);
2508 -- Left operand of test must match original variable
2510 if Nkind
(L
) not in N_Has_Entity
2511 or else Entity
(L
) /= Entity
(Nod
)
2516 -- Right operand of test mus be key value (zero or null)
2519 when Access_Check
=>
2520 if Nkind
(R
) /= N_Null
then
2524 when Division_Check
=>
2525 if not Compile_Time_Known_Value
(R
)
2526 or else Expr_Value
(R
) /= Uint_0
2532 -- Here we have the optimizable case, warn if not short-circuited
2534 if K
= N_Op_And
or else K
= N_Op_Or
then
2536 when Access_Check
=>
2538 ("Constraint_Error may be raised (access check)?",
2540 when Division_Check
=>
2542 ("Constraint_Error may be raised (zero divide)?",
2546 if K
= N_Op_And
then
2547 Error_Msg_N
("use `AND THEN` instead of AND?", P
);
2549 Error_Msg_N
("use `OR ELSE` instead of OR?", P
);
2552 -- If not short-circuited, we need the ckeck
2556 -- If short-circuited, we can omit the check
2563 -----------------------------------
2564 -- Check_Valid_Lvalue_Subscripts --
2565 -----------------------------------
2567 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
2569 -- Skip this if range checks are suppressed
2571 if Range_Checks_Suppressed
(Etype
(Expr
)) then
2574 -- Only do this check for expressions that come from source. We
2575 -- assume that expander generated assignments explicitly include
2576 -- any necessary checks. Note that this is not just an optimization,
2577 -- it avoids infinite recursions!
2579 elsif not Comes_From_Source
(Expr
) then
2582 -- For a selected component, check the prefix
2584 elsif Nkind
(Expr
) = N_Selected_Component
then
2585 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
2588 -- Case of indexed component
2590 elsif Nkind
(Expr
) = N_Indexed_Component
then
2591 Apply_Subscript_Validity_Checks
(Expr
);
2593 -- Prefix may itself be or contain an indexed component, and
2594 -- these subscripts need checking as well
2596 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
2598 end Check_Valid_Lvalue_Subscripts
;
2600 ----------------------------------
2601 -- Null_Exclusion_Static_Checks --
2602 ----------------------------------
2604 procedure Null_Exclusion_Static_Checks
(N
: Node_Id
) is
2605 K
: constant Node_Kind
:= Nkind
(N
);
2607 Related_Nod
: Node_Id
;
2608 Has_Null_Exclusion
: Boolean := False;
2611 pragma Assert
(K
= N_Parameter_Specification
2612 or else K
= N_Object_Declaration
2613 or else K
= N_Discriminant_Specification
2614 or else K
= N_Component_Declaration
);
2616 Typ
:= Etype
(Defining_Identifier
(N
));
2618 pragma Assert
(Is_Access_Type
(Typ
)
2619 or else (K
= N_Object_Declaration
and then Is_Array_Type
(Typ
)));
2622 when N_Parameter_Specification
=>
2623 Related_Nod
:= Parameter_Type
(N
);
2624 Has_Null_Exclusion
:= Null_Exclusion_Present
(N
);
2626 when N_Object_Declaration
=>
2627 Related_Nod
:= Object_Definition
(N
);
2628 Has_Null_Exclusion
:= Null_Exclusion_Present
(N
);
2630 when N_Discriminant_Specification
=>
2631 Related_Nod
:= Discriminant_Type
(N
);
2632 Has_Null_Exclusion
:= Null_Exclusion_Present
(N
);
2634 when N_Component_Declaration
=>
2635 if Present
(Access_Definition
(Component_Definition
(N
))) then
2636 Related_Nod
:= Component_Definition
(N
);
2637 Has_Null_Exclusion
:=
2638 Null_Exclusion_Present
2639 (Access_Definition
(Component_Definition
(N
)));
2642 Subtype_Indication
(Component_Definition
(N
));
2643 Has_Null_Exclusion
:=
2644 Null_Exclusion_Present
(Component_Definition
(N
));
2648 raise Program_Error
;
2651 -- Enforce legality rule 3.10 (14/1): A null_exclusion is only allowed
2652 -- of the access subtype does not exclude null.
2654 if Has_Null_Exclusion
2655 and then Can_Never_Be_Null
(Typ
)
2657 -- No need to check itypes that have the null-excluding attribute
2658 -- because they were checked at their point of creation
2660 and then not Is_Itype
(Typ
)
2663 ("(Ada 2005) already a null-excluding type", Related_Nod
);
2666 -- Check that null-excluding objects are always initialized
2668 if K
= N_Object_Declaration
2669 and then not Present
(Expression
(N
))
2671 -- Add a an expression that assignates null. This node is needed
2672 -- by Apply_Compile_Time_Constraint_Error, that will replace this
2673 -- node by a Constraint_Error node.
2675 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
2676 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
2678 Apply_Compile_Time_Constraint_Error
2679 (N
=> Expression
(N
),
2680 Msg
=> "(Ada 2005) null-excluding objects must be initialized?",
2681 Reason
=> CE_Null_Not_Allowed
);
2684 -- Check that the null value is not used as a single expression to
2685 -- assignate a value to a null-excluding component, formal or object;
2686 -- otherwise generate a warning message at the sloc of Related_Nod and
2687 -- replace Expression (N) by an N_Contraint_Error node.
2690 Expr
: constant Node_Id
:= Expression
(N
);
2694 and then Nkind
(Expr
) = N_Null
2697 when N_Discriminant_Specification |
2698 N_Component_Declaration
=>
2699 Apply_Compile_Time_Constraint_Error
2701 Msg
=> "(Ada 2005) NULL not allowed in"
2702 & " null-excluding components?",
2703 Reason
=> CE_Null_Not_Allowed
);
2705 when N_Parameter_Specification
=>
2706 Apply_Compile_Time_Constraint_Error
2708 Msg
=> "(Ada 2005) NULL not allowed in"
2709 & " null-excluding formals?",
2710 Reason
=> CE_Null_Not_Allowed
);
2712 when N_Object_Declaration
=>
2713 Apply_Compile_Time_Constraint_Error
2715 Msg
=> "(Ada 2005) NULL not allowed in"
2716 & " null-excluding objects?",
2717 Reason
=> CE_Null_Not_Allowed
);
2724 end Null_Exclusion_Static_Checks
;
2726 ----------------------------------
2727 -- Conditional_Statements_Begin --
2728 ----------------------------------
2730 procedure Conditional_Statements_Begin
is
2732 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
2734 -- If stack overflows, kill all checks, that way we know to
2735 -- simply reset the number of saved checks to zero on return.
2736 -- This should never occur in practice.
2738 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
2741 -- In the normal case, we just make a new stack entry saving
2742 -- the current number of saved checks for a later restore.
2745 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
2747 if Debug_Flag_CC
then
2748 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
2752 end Conditional_Statements_Begin
;
2754 --------------------------------
2755 -- Conditional_Statements_End --
2756 --------------------------------
2758 procedure Conditional_Statements_End
is
2760 pragma Assert
(Saved_Checks_TOS
> 0);
2762 -- If the saved checks stack overflowed, then we killed all
2763 -- checks, so setting the number of saved checks back to
2764 -- zero is correct. This should never occur in practice.
2766 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
2767 Num_Saved_Checks
:= 0;
2769 -- In the normal case, restore the number of saved checks
2770 -- from the top stack entry.
2773 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
2774 if Debug_Flag_CC
then
2775 w
("Conditional_Statements_End: Num_Saved_Checks = ",
2780 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
2781 end Conditional_Statements_End
;
2783 ---------------------
2784 -- Determine_Range --
2785 ---------------------
2787 Cache_Size
: constant := 2 ** 10;
2788 type Cache_Index
is range 0 .. Cache_Size
- 1;
2789 -- Determine size of below cache (power of 2 is more efficient!)
2791 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
2792 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
2793 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
2794 -- The above arrays are used to implement a small direct cache
2795 -- for Determine_Range calls. Because of the way Determine_Range
2796 -- recursively traces subexpressions, and because overflow checking
2797 -- calls the routine on the way up the tree, a quadratic behavior
2798 -- can otherwise be encountered in large expressions. The cache
2799 -- entry for node N is stored in the (N mod Cache_Size) entry, and
2800 -- can be validated by checking the actual node value stored there.
2802 procedure Determine_Range
2808 Typ
: constant Entity_Id
:= Etype
(N
);
2812 -- Lo and Hi bounds of left operand
2816 -- Lo and Hi bounds of right (or only) operand
2819 -- Temp variable used to hold a bound node
2822 -- High bound of base type of expression
2826 -- Refined values for low and high bounds, after tightening
2829 -- Used in lower level calls to indicate if call succeeded
2831 Cindex
: Cache_Index
;
2832 -- Used to search cache
2834 function OK_Operands
return Boolean;
2835 -- Used for binary operators. Determines the ranges of the left and
2836 -- right operands, and if they are both OK, returns True, and puts
2837 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left
2843 function OK_Operands
return Boolean is
2845 Determine_Range
(Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
);
2851 Determine_Range
(Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
);
2855 -- Start of processing for Determine_Range
2858 -- Prevent junk warnings by initializing range variables
2865 -- If the type is not discrete, or is undefined, then we can't
2866 -- do anything about determining the range.
2868 if No
(Typ
) or else not Is_Discrete_Type
(Typ
)
2869 or else Error_Posted
(N
)
2875 -- For all other cases, we can determine the range
2879 -- If value is compile time known, then the possible range is the
2880 -- one value that we know this expression definitely has!
2882 if Compile_Time_Known_Value
(N
) then
2883 Lo
:= Expr_Value
(N
);
2888 -- Return if already in the cache
2890 Cindex
:= Cache_Index
(N
mod Cache_Size
);
2892 if Determine_Range_Cache_N
(Cindex
) = N
then
2893 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
2894 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
2898 -- Otherwise, start by finding the bounds of the type of the
2899 -- expression, the value cannot be outside this range (if it
2900 -- is, then we have an overflow situation, which is a separate
2901 -- check, we are talking here only about the expression value).
2903 -- We use the actual bound unless it is dynamic, in which case
2904 -- use the corresponding base type bound if possible. If we can't
2905 -- get a bound then we figure we can't determine the range (a
2906 -- peculiar case, that perhaps cannot happen, but there is no
2907 -- point in bombing in this optimization circuit.
2909 -- First the low bound
2911 Bound
:= Type_Low_Bound
(Typ
);
2913 if Compile_Time_Known_Value
(Bound
) then
2914 Lo
:= Expr_Value
(Bound
);
2916 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Base_Type
(Typ
))) then
2917 Lo
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
2924 -- Now the high bound
2926 Bound
:= Type_High_Bound
(Typ
);
2928 -- We need the high bound of the base type later on, and this should
2929 -- always be compile time known. Again, it is not clear that this
2930 -- can ever be false, but no point in bombing.
2932 if Compile_Time_Known_Value
(Type_High_Bound
(Base_Type
(Typ
))) then
2933 Hbound
:= Expr_Value
(Type_High_Bound
(Base_Type
(Typ
)));
2941 -- If we have a static subtype, then that may have a tighter bound
2942 -- so use the upper bound of the subtype instead in this case.
2944 if Compile_Time_Known_Value
(Bound
) then
2945 Hi
:= Expr_Value
(Bound
);
2948 -- We may be able to refine this value in certain situations. If
2949 -- refinement is possible, then Lor and Hir are set to possibly
2950 -- tighter bounds, and OK1 is set to True.
2954 -- For unary plus, result is limited by range of operand
2957 Determine_Range
(Right_Opnd
(N
), OK1
, Lor
, Hir
);
2959 -- For unary minus, determine range of operand, and negate it
2962 Determine_Range
(Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
);
2969 -- For binary addition, get range of each operand and do the
2970 -- addition to get the result range.
2974 Lor
:= Lo_Left
+ Lo_Right
;
2975 Hir
:= Hi_Left
+ Hi_Right
;
2978 -- Division is tricky. The only case we consider is where the
2979 -- right operand is a positive constant, and in this case we
2980 -- simply divide the bounds of the left operand
2984 if Lo_Right
= Hi_Right
2985 and then Lo_Right
> 0
2987 Lor
:= Lo_Left
/ Lo_Right
;
2988 Hir
:= Hi_Left
/ Lo_Right
;
2995 -- For binary subtraction, get range of each operand and do
2996 -- the worst case subtraction to get the result range.
2998 when N_Op_Subtract
=>
3000 Lor
:= Lo_Left
- Hi_Right
;
3001 Hir
:= Hi_Left
- Lo_Right
;
3004 -- For MOD, if right operand is a positive constant, then
3005 -- result must be in the allowable range of mod results.
3009 if Lo_Right
= Hi_Right
3010 and then Lo_Right
/= 0
3012 if Lo_Right
> 0 then
3014 Hir
:= Lo_Right
- 1;
3016 else -- Lo_Right < 0
3017 Lor
:= Lo_Right
+ 1;
3026 -- For REM, if right operand is a positive constant, then
3027 -- result must be in the allowable range of mod results.
3031 if Lo_Right
= Hi_Right
3032 and then Lo_Right
/= 0
3035 Dval
: constant Uint
:= (abs Lo_Right
) - 1;
3038 -- The sign of the result depends on the sign of the
3039 -- dividend (but not on the sign of the divisor, hence
3040 -- the abs operation above).
3060 -- Attribute reference cases
3062 when N_Attribute_Reference
=>
3063 case Attribute_Name
(N
) is
3065 -- For Pos/Val attributes, we can refine the range using the
3066 -- possible range of values of the attribute expression
3068 when Name_Pos | Name_Val
=>
3069 Determine_Range
(First
(Expressions
(N
)), OK1
, Lor
, Hir
);
3071 -- For Length attribute, use the bounds of the corresponding
3072 -- index type to refine the range.
3076 Atyp
: Entity_Id
:= Etype
(Prefix
(N
));
3084 if Is_Access_Type
(Atyp
) then
3085 Atyp
:= Designated_Type
(Atyp
);
3088 -- For string literal, we know exact value
3090 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
3092 Lo
:= String_Literal_Length
(Atyp
);
3093 Hi
:= String_Literal_Length
(Atyp
);
3097 -- Otherwise check for expression given
3099 if No
(Expressions
(N
)) then
3103 UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
3106 Indx
:= First_Index
(Atyp
);
3107 for J
in 2 .. Inum
loop
3108 Indx
:= Next_Index
(Indx
);
3112 (Type_Low_Bound
(Etype
(Indx
)), OK1
, LL
, LU
);
3116 (Type_High_Bound
(Etype
(Indx
)), OK1
, UL
, UU
);
3120 -- The maximum value for Length is the biggest
3121 -- possible gap between the values of the bounds.
3122 -- But of course, this value cannot be negative.
3124 Hir
:= UI_Max
(Uint_0
, UU
- LL
);
3126 -- For constrained arrays, the minimum value for
3127 -- Length is taken from the actual value of the
3128 -- bounds, since the index will be exactly of
3131 if Is_Constrained
(Atyp
) then
3132 Lor
:= UI_Max
(Uint_0
, UL
- LU
);
3134 -- For an unconstrained array, the minimum value
3135 -- for length is always zero.
3144 -- No special handling for other attributes
3145 -- Probably more opportunities exist here ???
3152 -- For type conversion from one discrete type to another, we
3153 -- can refine the range using the converted value.
3155 when N_Type_Conversion
=>
3156 Determine_Range
(Expression
(N
), OK1
, Lor
, Hir
);
3158 -- Nothing special to do for all other expression kinds
3166 -- At this stage, if OK1 is true, then we know that the actual
3167 -- result of the computed expression is in the range Lor .. Hir.
3168 -- We can use this to restrict the possible range of results.
3172 -- If the refined value of the low bound is greater than the
3173 -- type high bound, then reset it to the more restrictive
3174 -- value. However, we do NOT do this for the case of a modular
3175 -- type where the possible upper bound on the value is above the
3176 -- base type high bound, because that means the result could wrap.
3179 and then not (Is_Modular_Integer_Type
(Typ
)
3180 and then Hir
> Hbound
)
3185 -- Similarly, if the refined value of the high bound is less
3186 -- than the value so far, then reset it to the more restrictive
3187 -- value. Again, we do not do this if the refined low bound is
3188 -- negative for a modular type, since this would wrap.
3191 and then not (Is_Modular_Integer_Type
(Typ
)
3192 and then Lor
< Uint_0
)
3198 -- Set cache entry for future call and we are all done
3200 Determine_Range_Cache_N
(Cindex
) := N
;
3201 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
3202 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
3205 -- If any exception occurs, it means that we have some bug in the compiler
3206 -- possibly triggered by a previous error, or by some unforseen peculiar
3207 -- occurrence. However, this is only an optimization attempt, so there is
3208 -- really no point in crashing the compiler. Instead we just decide, too
3209 -- bad, we can't figure out a range in this case after all.
3214 -- Debug flag K disables this behavior (useful for debugging)
3216 if Debug_Flag_K
then
3224 end Determine_Range
;
3226 ------------------------------------
3227 -- Discriminant_Checks_Suppressed --
3228 ------------------------------------
3230 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
3233 if Is_Unchecked_Union
(E
) then
3235 elsif Checks_May_Be_Suppressed
(E
) then
3236 return Is_Check_Suppressed
(E
, Discriminant_Check
);
3240 return Scope_Suppress
(Discriminant_Check
);
3241 end Discriminant_Checks_Suppressed
;
3243 --------------------------------
3244 -- Division_Checks_Suppressed --
3245 --------------------------------
3247 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
3249 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3250 return Is_Check_Suppressed
(E
, Division_Check
);
3252 return Scope_Suppress
(Division_Check
);
3254 end Division_Checks_Suppressed
;
3256 -----------------------------------
3257 -- Elaboration_Checks_Suppressed --
3258 -----------------------------------
3260 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
3263 if Kill_Elaboration_Checks
(E
) then
3265 elsif Checks_May_Be_Suppressed
(E
) then
3266 return Is_Check_Suppressed
(E
, Elaboration_Check
);
3270 return Scope_Suppress
(Elaboration_Check
);
3271 end Elaboration_Checks_Suppressed
;
3273 ---------------------------
3274 -- Enable_Overflow_Check --
3275 ---------------------------
3277 procedure Enable_Overflow_Check
(N
: Node_Id
) is
3278 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
3287 if Debug_Flag_CC
then
3288 w
("Enable_Overflow_Check for node ", Int
(N
));
3289 Write_Str
(" Source location = ");
3294 -- Nothing to do if the range of the result is known OK. We skip
3295 -- this for conversions, since the caller already did the check,
3296 -- and in any case the condition for deleting the check for a
3297 -- type conversion is different in any case.
3299 if Nkind
(N
) /= N_Type_Conversion
then
3300 Determine_Range
(N
, OK
, Lo
, Hi
);
3302 -- Note in the test below that we assume that if a bound of the
3303 -- range is equal to that of the type. That's not quite accurate
3304 -- but we do this for the following reasons:
3306 -- a) The way that Determine_Range works, it will typically report
3307 -- the bounds of the value as being equal to the bounds of the
3308 -- type, because it either can't tell anything more precise, or
3309 -- does not think it is worth the effort to be more precise.
3311 -- b) It is very unusual to have a situation in which this would
3312 -- generate an unnecessary overflow check (an example would be
3313 -- a subtype with a range 0 .. Integer'Last - 1 to which the
3314 -- literal value one is added.
3316 -- c) The alternative is a lot of special casing in this routine
3317 -- which would partially duplicate Determine_Range processing.
3320 and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
3321 and then Hi
< Expr_Value
(Type_High_Bound
(Typ
))
3323 if Debug_Flag_CC
then
3324 w
("No overflow check required");
3331 -- If not in optimizing mode, set flag and we are done. We are also
3332 -- done (and just set the flag) if the type is not a discrete type,
3333 -- since it is not worth the effort to eliminate checks for other
3334 -- than discrete types. In addition, we take this same path if we
3335 -- have stored the maximum number of checks possible already (a
3336 -- very unlikely situation, but we do not want to blow up!)
3338 if Optimization_Level
= 0
3339 or else not Is_Discrete_Type
(Etype
(N
))
3340 or else Num_Saved_Checks
= Saved_Checks
'Last
3342 Set_Do_Overflow_Check
(N
, True);
3344 if Debug_Flag_CC
then
3345 w
("Optimization off");
3351 -- Otherwise evaluate and check the expression
3356 Target_Type
=> Empty
,
3362 if Debug_Flag_CC
then
3363 w
("Called Find_Check");
3367 w
(" Check_Num = ", Chk
);
3368 w
(" Ent = ", Int
(Ent
));
3369 Write_Str
(" Ofs = ");
3374 -- If check is not of form to optimize, then set flag and we are done
3377 Set_Do_Overflow_Check
(N
, True);
3381 -- If check is already performed, then return without setting flag
3384 if Debug_Flag_CC
then
3385 w
("Check suppressed!");
3391 -- Here we will make a new entry for the new check
3393 Set_Do_Overflow_Check
(N
, True);
3394 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
3395 Saved_Checks
(Num_Saved_Checks
) :=
3400 Target_Type
=> Empty
);
3402 if Debug_Flag_CC
then
3403 w
("Make new entry, check number = ", Num_Saved_Checks
);
3404 w
(" Entity = ", Int
(Ent
));
3405 Write_Str
(" Offset = ");
3407 w
(" Check_Type = O");
3408 w
(" Target_Type = Empty");
3411 -- If we get an exception, then something went wrong, probably because
3412 -- of an error in the structure of the tree due to an incorrect program.
3413 -- Or it may be a bug in the optimization circuit. In either case the
3414 -- safest thing is simply to set the check flag unconditionally.
3418 Set_Do_Overflow_Check
(N
, True);
3420 if Debug_Flag_CC
then
3421 w
(" exception occurred, overflow flag set");
3425 end Enable_Overflow_Check
;
3427 ------------------------
3428 -- Enable_Range_Check --
3429 ------------------------
3431 procedure Enable_Range_Check
(N
: Node_Id
) is
3440 -- Return if unchecked type conversion with range check killed.
3441 -- In this case we never set the flag (that's what Kill_Range_Check
3444 if Nkind
(N
) = N_Unchecked_Type_Conversion
3445 and then Kill_Range_Check
(N
)
3450 -- Debug trace output
3452 if Debug_Flag_CC
then
3453 w
("Enable_Range_Check for node ", Int
(N
));
3454 Write_Str
(" Source location = ");
3459 -- If not in optimizing mode, set flag and we are done. We are also
3460 -- done (and just set the flag) if the type is not a discrete type,
3461 -- since it is not worth the effort to eliminate checks for other
3462 -- than discrete types. In addition, we take this same path if we
3463 -- have stored the maximum number of checks possible already (a
3464 -- very unlikely situation, but we do not want to blow up!)
3466 if Optimization_Level
= 0
3467 or else No
(Etype
(N
))
3468 or else not Is_Discrete_Type
(Etype
(N
))
3469 or else Num_Saved_Checks
= Saved_Checks
'Last
3471 Set_Do_Range_Check
(N
, True);
3473 if Debug_Flag_CC
then
3474 w
("Optimization off");
3480 -- Otherwise find out the target type
3484 -- For assignment, use left side subtype
3486 if Nkind
(P
) = N_Assignment_Statement
3487 and then Expression
(P
) = N
3489 Ttyp
:= Etype
(Name
(P
));
3491 -- For indexed component, use subscript subtype
3493 elsif Nkind
(P
) = N_Indexed_Component
then
3500 Atyp
:= Etype
(Prefix
(P
));
3502 if Is_Access_Type
(Atyp
) then
3503 Atyp
:= Designated_Type
(Atyp
);
3505 -- If the prefix is an access to an unconstrained array,
3506 -- perform check unconditionally: it depends on the bounds
3507 -- of an object and we cannot currently recognize whether
3508 -- the test may be redundant.
3510 if not Is_Constrained
(Atyp
) then
3511 Set_Do_Range_Check
(N
, True);
3515 -- Ditto if the prefix is an explicit dereference whose
3516 -- designated type is unconstrained.
3518 elsif Nkind
(Prefix
(P
)) = N_Explicit_Dereference
3519 and then not Is_Constrained
(Atyp
)
3521 Set_Do_Range_Check
(N
, True);
3525 Indx
:= First_Index
(Atyp
);
3526 Subs
:= First
(Expressions
(P
));
3529 Ttyp
:= Etype
(Indx
);
3538 -- For now, ignore all other cases, they are not so interesting
3541 if Debug_Flag_CC
then
3542 w
(" target type not found, flag set");
3545 Set_Do_Range_Check
(N
, True);
3549 -- Evaluate and check the expression
3554 Target_Type
=> Ttyp
,
3560 if Debug_Flag_CC
then
3561 w
("Called Find_Check");
3562 w
("Target_Typ = ", Int
(Ttyp
));
3566 w
(" Check_Num = ", Chk
);
3567 w
(" Ent = ", Int
(Ent
));
3568 Write_Str
(" Ofs = ");
3573 -- If check is not of form to optimize, then set flag and we are done
3576 if Debug_Flag_CC
then
3577 w
(" expression not of optimizable type, flag set");
3580 Set_Do_Range_Check
(N
, True);
3584 -- If check is already performed, then return without setting flag
3587 if Debug_Flag_CC
then
3588 w
("Check suppressed!");
3594 -- Here we will make a new entry for the new check
3596 Set_Do_Range_Check
(N
, True);
3597 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
3598 Saved_Checks
(Num_Saved_Checks
) :=
3603 Target_Type
=> Ttyp
);
3605 if Debug_Flag_CC
then
3606 w
("Make new entry, check number = ", Num_Saved_Checks
);
3607 w
(" Entity = ", Int
(Ent
));
3608 Write_Str
(" Offset = ");
3610 w
(" Check_Type = R");
3611 w
(" Target_Type = ", Int
(Ttyp
));
3615 -- If we get an exception, then something went wrong, probably because
3616 -- of an error in the structure of the tree due to an incorrect program.
3617 -- Or it may be a bug in the optimization circuit. In either case the
3618 -- safest thing is simply to set the check flag unconditionally.
3622 Set_Do_Range_Check
(N
, True);
3624 if Debug_Flag_CC
then
3625 w
(" exception occurred, range flag set");
3629 end Enable_Range_Check
;
3635 procedure Ensure_Valid
(Expr
: Node_Id
; Holes_OK
: Boolean := False) is
3636 Typ
: constant Entity_Id
:= Etype
(Expr
);
3639 -- Ignore call if we are not doing any validity checking
3641 if not Validity_Checks_On
then
3644 -- Ignore call if range checks suppressed on entity in question
3646 elsif Is_Entity_Name
(Expr
)
3647 and then Range_Checks_Suppressed
(Entity
(Expr
))
3651 -- No check required if expression is from the expander, we assume
3652 -- the expander will generate whatever checks are needed. Note that
3653 -- this is not just an optimization, it avoids infinite recursions!
3655 -- Unchecked conversions must be checked, unless they are initialized
3656 -- scalar values, as in a component assignment in an init proc.
3658 -- In addition, we force a check if Force_Validity_Checks is set
3660 elsif not Comes_From_Source
(Expr
)
3661 and then not Force_Validity_Checks
3662 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
3663 or else Kill_Range_Check
(Expr
))
3667 -- No check required if expression is known to have valid value
3669 elsif Expr_Known_Valid
(Expr
) then
3672 -- No check required if checks off
3674 elsif Range_Checks_Suppressed
(Typ
) then
3677 -- Ignore case of enumeration with holes where the flag is set not
3678 -- to worry about holes, since no special validity check is needed
3680 elsif Is_Enumeration_Type
(Typ
)
3681 and then Has_Non_Standard_Rep
(Typ
)
3686 -- No check required on the left-hand side of an assignment
3688 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
3689 and then Expr
= Name
(Parent
(Expr
))
3693 -- An annoying special case. If this is an out parameter of a scalar
3694 -- type, then the value is not going to be accessed, therefore it is
3695 -- inappropriate to do any validity check at the call site.
3698 -- Only need to worry about scalar types
3700 if Is_Scalar_Type
(Typ
) then
3710 -- Find actual argument (which may be a parameter association)
3711 -- and the parent of the actual argument (the call statement)
3716 if Nkind
(P
) = N_Parameter_Association
then
3721 -- Only need to worry if we are argument of a procedure
3722 -- call since functions don't have out parameters. If this
3723 -- is an indirect or dispatching call, get signature from
3724 -- the subprogram type.
3726 if Nkind
(P
) = N_Procedure_Call_Statement
then
3727 L
:= Parameter_Associations
(P
);
3729 if Is_Entity_Name
(Name
(P
)) then
3730 E
:= Entity
(Name
(P
));
3732 pragma Assert
(Nkind
(Name
(P
)) = N_Explicit_Dereference
);
3733 E
:= Etype
(Name
(P
));
3736 -- Only need to worry if there are indeed actuals, and
3737 -- if this could be a procedure call, otherwise we cannot
3738 -- get a match (either we are not an argument, or the
3739 -- mode of the formal is not OUT). This test also filters
3740 -- out the generic case.
3742 if Is_Non_Empty_List
(L
)
3743 and then Is_Subprogram
(E
)
3745 -- This is the loop through parameters, looking to
3746 -- see if there is an OUT parameter for which we are
3749 F
:= First_Formal
(E
);
3752 while Present
(F
) loop
3753 if Ekind
(F
) = E_Out_Parameter
and then A
= N
then
3766 -- If we fall through, a validity check is required. Note that it would
3767 -- not be good to set Do_Range_Check, even in contexts where this is
3768 -- permissible, since this flag causes checking against the target type,
3769 -- not the source type in contexts such as assignments
3771 Insert_Valid_Check
(Expr
);
3774 ----------------------
3775 -- Expr_Known_Valid --
3776 ----------------------
3778 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
3779 Typ
: constant Entity_Id
:= Etype
(Expr
);
3782 -- Non-scalar types are always considered valid, since they never
3783 -- give rise to the issues of erroneous or bounded error behavior
3784 -- that are the concern. In formal reference manual terms the
3785 -- notion of validity only applies to scalar types. Note that
3786 -- even when packed arrays are represented using modular types,
3787 -- they are still arrays semantically, so they are also always
3788 -- valid (in particular, the unused bits can be random rubbish
3789 -- without affecting the validity of the array value).
3791 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Type
(Typ
) then
3794 -- If no validity checking, then everything is considered valid
3796 elsif not Validity_Checks_On
then
3799 -- Floating-point types are considered valid unless floating-point
3800 -- validity checks have been specifically turned on.
3802 elsif Is_Floating_Point_Type
(Typ
)
3803 and then not Validity_Check_Floating_Point
3807 -- If the expression is the value of an object that is known to
3808 -- be valid, then clearly the expression value itself is valid.
3810 elsif Is_Entity_Name
(Expr
)
3811 and then Is_Known_Valid
(Entity
(Expr
))
3815 -- If the type is one for which all values are known valid, then
3816 -- we are sure that the value is valid except in the slightly odd
3817 -- case where the expression is a reference to a variable whose size
3818 -- has been explicitly set to a value greater than the object size.
3820 elsif Is_Known_Valid
(Typ
) then
3821 if Is_Entity_Name
(Expr
)
3822 and then Ekind
(Entity
(Expr
)) = E_Variable
3823 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
3830 -- Integer and character literals always have valid values, where
3831 -- appropriate these will be range checked in any case.
3833 elsif Nkind
(Expr
) = N_Integer_Literal
3835 Nkind
(Expr
) = N_Character_Literal
3839 -- If we have a type conversion or a qualification of a known valid
3840 -- value, then the result will always be valid.
3842 elsif Nkind
(Expr
) = N_Type_Conversion
3844 Nkind
(Expr
) = N_Qualified_Expression
3846 return Expr_Known_Valid
(Expression
(Expr
));
3848 -- The result of any function call or operator is always considered
3849 -- valid, since we assume the necessary checks are done by the call.
3850 -- For operators on floating-point operations, we must also check
3851 -- when the operation is the right-hand side of an assignment, or
3852 -- is an actual in a call.
3855 Nkind
(Expr
) in N_Binary_Op
or else Nkind
(Expr
) in N_Unary_Op
3857 if Is_Floating_Point_Type
(Typ
)
3858 and then Validity_Check_Floating_Point
3860 (Nkind
(Parent
(Expr
)) = N_Assignment_Statement
3861 or else Nkind
(Parent
(Expr
)) = N_Function_Call
3862 or else Nkind
(Parent
(Expr
)) = N_Parameter_Association
)
3869 elsif Nkind
(Expr
) = N_Function_Call
then
3872 -- For all other cases, we do not know the expression is valid
3877 end Expr_Known_Valid
;
3883 procedure Find_Check
3885 Check_Type
: Character;
3886 Target_Type
: Entity_Id
;
3887 Entry_OK
: out Boolean;
3888 Check_Num
: out Nat
;
3889 Ent
: out Entity_Id
;
3892 function Within_Range_Of
3893 (Target_Type
: Entity_Id
;
3894 Check_Type
: Entity_Id
) return Boolean;
3895 -- Given a requirement for checking a range against Target_Type, and
3896 -- and a range Check_Type against which a check has already been made,
3897 -- determines if the check against check type is sufficient to ensure
3898 -- that no check against Target_Type is required.
3900 ---------------------
3901 -- Within_Range_Of --
3902 ---------------------
3904 function Within_Range_Of
3905 (Target_Type
: Entity_Id
;
3906 Check_Type
: Entity_Id
) return Boolean
3909 if Target_Type
= Check_Type
then
3914 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
3915 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
3916 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
3917 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
3921 or else (Compile_Time_Known_Value
(Tlo
)
3923 Compile_Time_Known_Value
(Clo
)
3925 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
3928 or else (Compile_Time_Known_Value
(Thi
)
3930 Compile_Time_Known_Value
(Chi
)
3932 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
3940 end Within_Range_Of
;
3942 -- Start of processing for Find_Check
3945 -- Establish default, to avoid warnings from GCC
3949 -- Case of expression is simple entity reference
3951 if Is_Entity_Name
(Expr
) then
3952 Ent
:= Entity
(Expr
);
3955 -- Case of expression is entity + known constant
3957 elsif Nkind
(Expr
) = N_Op_Add
3958 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3959 and then Is_Entity_Name
(Left_Opnd
(Expr
))
3961 Ent
:= Entity
(Left_Opnd
(Expr
));
3962 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
3964 -- Case of expression is entity - known constant
3966 elsif Nkind
(Expr
) = N_Op_Subtract
3967 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3968 and then Is_Entity_Name
(Left_Opnd
(Expr
))
3970 Ent
:= Entity
(Left_Opnd
(Expr
));
3971 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
3973 -- Any other expression is not of the right form
3982 -- Come here with expression of appropriate form, check if
3983 -- entity is an appropriate one for our purposes.
3985 if (Ekind
(Ent
) = E_Variable
3987 Ekind
(Ent
) = E_Constant
3989 Ekind
(Ent
) = E_Loop_Parameter
3991 Ekind
(Ent
) = E_In_Parameter
)
3992 and then not Is_Library_Level_Entity
(Ent
)
4000 -- See if there is matching check already
4002 for J
in reverse 1 .. Num_Saved_Checks
loop
4004 SC
: Saved_Check
renames Saved_Checks
(J
);
4007 if SC
.Killed
= False
4008 and then SC
.Entity
= Ent
4009 and then SC
.Offset
= Ofs
4010 and then SC
.Check_Type
= Check_Type
4011 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
4019 -- If we fall through entry was not found
4025 ---------------------------------
4026 -- Generate_Discriminant_Check --
4027 ---------------------------------
4029 -- Note: the code for this procedure is derived from the
4030 -- emit_discriminant_check routine a-trans.c v1.659.
4032 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
4033 Loc
: constant Source_Ptr
:= Sloc
(N
);
4034 Pref
: constant Node_Id
:= Prefix
(N
);
4035 Sel
: constant Node_Id
:= Selector_Name
(N
);
4037 Orig_Comp
: constant Entity_Id
:=
4038 Original_Record_Component
(Entity
(Sel
));
4039 -- The original component to be checked
4041 Discr_Fct
: constant Entity_Id
:=
4042 Discriminant_Checking_Func
(Orig_Comp
);
4043 -- The discriminant checking function
4046 -- One discriminant to be checked in the type
4048 Real_Discr
: Entity_Id
;
4049 -- Actual discriminant in the call
4051 Pref_Type
: Entity_Id
;
4052 -- Type of relevant prefix (ignoring private/access stuff)
4055 -- List of arguments for function call
4058 -- Keep track of the formal corresponding to the actual we build
4059 -- for each discriminant, in order to be able to perform the
4060 -- necessary type conversions.
4063 -- Selected component reference for checking function argument
4066 Pref_Type
:= Etype
(Pref
);
4068 -- Force evaluation of the prefix, so that it does not get evaluated
4069 -- twice (once for the check, once for the actual reference). Such a
4070 -- double evaluation is always a potential source of inefficiency,
4071 -- and is functionally incorrect in the volatile case, or when the
4072 -- prefix may have side-effects. An entity or a component of an
4073 -- entity requires no evaluation.
4075 if Is_Entity_Name
(Pref
) then
4076 if Treat_As_Volatile
(Entity
(Pref
)) then
4077 Force_Evaluation
(Pref
, Name_Req
=> True);
4080 elsif Treat_As_Volatile
(Etype
(Pref
)) then
4081 Force_Evaluation
(Pref
, Name_Req
=> True);
4083 elsif Nkind
(Pref
) = N_Selected_Component
4084 and then Is_Entity_Name
(Prefix
(Pref
))
4089 Force_Evaluation
(Pref
, Name_Req
=> True);
4092 -- For a tagged type, use the scope of the original component to
4093 -- obtain the type, because ???
4095 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
4096 Pref_Type
:= Scope
(Orig_Comp
);
4098 -- For an untagged derived type, use the discriminants of the
4099 -- parent which have been renamed in the derivation, possibly
4100 -- by a one-to-many discriminant constraint.
4101 -- For non-tagged type, initially get the Etype of the prefix
4104 if Is_Derived_Type
(Pref_Type
)
4105 and then Number_Discriminants
(Pref_Type
) /=
4106 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
4108 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
4112 -- We definitely should have a checking function, This routine should
4113 -- not be called if no discriminant checking function is present.
4115 pragma Assert
(Present
(Discr_Fct
));
4117 -- Create the list of the actual parameters for the call. This list
4118 -- is the list of the discriminant fields of the record expression to
4119 -- be discriminant checked.
4122 Formal
:= First_Formal
(Discr_Fct
);
4123 Discr
:= First_Discriminant
(Pref_Type
);
4124 while Present
(Discr
) loop
4126 -- If we have a corresponding discriminant field, and a parent
4127 -- subtype is present, then we want to use the corresponding
4128 -- discriminant since this is the one with the useful value.
4130 if Present
(Corresponding_Discriminant
(Discr
))
4131 and then Ekind
(Pref_Type
) = E_Record_Type
4132 and then Present
(Parent_Subtype
(Pref_Type
))
4134 Real_Discr
:= Corresponding_Discriminant
(Discr
);
4136 Real_Discr
:= Discr
;
4139 -- Construct the reference to the discriminant
4142 Make_Selected_Component
(Loc
,
4144 Unchecked_Convert_To
(Pref_Type
,
4145 Duplicate_Subexpr
(Pref
)),
4146 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
4148 -- Manually analyze and resolve this selected component. We really
4149 -- want it just as it appears above, and do not want the expander
4150 -- playing discriminal games etc with this reference. Then we
4151 -- append the argument to the list we are gathering.
4153 Set_Etype
(Scomp
, Etype
(Real_Discr
));
4154 Set_Analyzed
(Scomp
, True);
4155 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
4157 Next_Formal_With_Extras
(Formal
);
4158 Next_Discriminant
(Discr
);
4161 -- Now build and insert the call
4164 Make_Raise_Constraint_Error
(Loc
,
4166 Make_Function_Call
(Loc
,
4167 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
4168 Parameter_Associations
=> Args
),
4169 Reason
=> CE_Discriminant_Check_Failed
));
4170 end Generate_Discriminant_Check
;
4172 ---------------------------
4173 -- Generate_Index_Checks --
4174 ---------------------------
4176 procedure Generate_Index_Checks
(N
: Node_Id
) is
4177 Loc
: constant Source_Ptr
:= Sloc
(N
);
4178 A
: constant Node_Id
:= Prefix
(N
);
4184 Sub
:= First
(Expressions
(N
));
4186 while Present
(Sub
) loop
4187 if Do_Range_Check
(Sub
) then
4188 Set_Do_Range_Check
(Sub
, False);
4190 -- Force evaluation except for the case of a simple name of
4191 -- a non-volatile entity.
4193 if not Is_Entity_Name
(Sub
)
4194 or else Treat_As_Volatile
(Entity
(Sub
))
4196 Force_Evaluation
(Sub
);
4199 -- Generate a raise of constraint error with the appropriate
4200 -- reason and a condition of the form:
4202 -- Base_Type(Sub) not in array'range (subscript)
4204 -- Note that the reason we generate the conversion to the
4205 -- base type here is that we definitely want the range check
4206 -- to take place, even if it looks like the subtype is OK.
4207 -- Optimization considerations that allow us to omit the
4208 -- check have already been taken into account in the setting
4209 -- of the Do_Range_Check flag earlier on.
4214 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
4218 Make_Raise_Constraint_Error
(Loc
,
4222 Convert_To
(Base_Type
(Etype
(Sub
)),
4223 Duplicate_Subexpr_Move_Checks
(Sub
)),
4225 Make_Attribute_Reference
(Loc
,
4226 Prefix
=> Duplicate_Subexpr_Move_Checks
(A
),
4227 Attribute_Name
=> Name_Range
,
4228 Expressions
=> Num
)),
4229 Reason
=> CE_Index_Check_Failed
));
4235 end Generate_Index_Checks
;
4237 --------------------------
4238 -- Generate_Range_Check --
4239 --------------------------
4241 procedure Generate_Range_Check
4243 Target_Type
: Entity_Id
;
4244 Reason
: RT_Exception_Code
)
4246 Loc
: constant Source_Ptr
:= Sloc
(N
);
4247 Source_Type
: constant Entity_Id
:= Etype
(N
);
4248 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
4249 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
4252 -- First special case, if the source type is already within the
4253 -- range of the target type, then no check is needed (probably we
4254 -- should have stopped Do_Range_Check from being set in the first
4255 -- place, but better late than later in preventing junk code!
4257 -- We do NOT apply this if the source node is a literal, since in
4258 -- this case the literal has already been labeled as having the
4259 -- subtype of the target.
4261 if In_Subrange_Of
(Source_Type
, Target_Type
)
4263 (Nkind
(N
) = N_Integer_Literal
4265 Nkind
(N
) = N_Real_Literal
4267 Nkind
(N
) = N_Character_Literal
4270 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
4275 -- We need a check, so force evaluation of the node, so that it does
4276 -- not get evaluated twice (once for the check, once for the actual
4277 -- reference). Such a double evaluation is always a potential source
4278 -- of inefficiency, and is functionally incorrect in the volatile case.
4280 if not Is_Entity_Name
(N
)
4281 or else Treat_As_Volatile
(Entity
(N
))
4283 Force_Evaluation
(N
);
4286 -- The easiest case is when Source_Base_Type and Target_Base_Type
4287 -- are the same since in this case we can simply do a direct
4288 -- check of the value of N against the bounds of Target_Type.
4290 -- [constraint_error when N not in Target_Type]
4292 -- Note: this is by far the most common case, for example all cases of
4293 -- checks on the RHS of assignments are in this category, but not all
4294 -- cases are like this. Notably conversions can involve two types.
4296 if Source_Base_Type
= Target_Base_Type
then
4298 Make_Raise_Constraint_Error
(Loc
,
4301 Left_Opnd
=> Duplicate_Subexpr
(N
),
4302 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
4305 -- Next test for the case where the target type is within the bounds
4306 -- of the base type of the source type, since in this case we can
4307 -- simply convert these bounds to the base type of T to do the test.
4309 -- [constraint_error when N not in
4310 -- Source_Base_Type (Target_Type'First)
4312 -- Source_Base_Type(Target_Type'Last))]
4314 -- The conversions will always work and need no check
4316 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
4318 Make_Raise_Constraint_Error
(Loc
,
4321 Left_Opnd
=> Duplicate_Subexpr
(N
),
4326 Convert_To
(Source_Base_Type
,
4327 Make_Attribute_Reference
(Loc
,
4329 New_Occurrence_Of
(Target_Type
, Loc
),
4330 Attribute_Name
=> Name_First
)),
4333 Convert_To
(Source_Base_Type
,
4334 Make_Attribute_Reference
(Loc
,
4336 New_Occurrence_Of
(Target_Type
, Loc
),
4337 Attribute_Name
=> Name_Last
)))),
4340 -- Note that at this stage we now that the Target_Base_Type is
4341 -- not in the range of the Source_Base_Type (since even the
4342 -- Target_Type itself is not in this range). It could still be
4343 -- the case that the Source_Type is in range of the target base
4344 -- type, since we have not checked that case.
4346 -- If that is the case, we can freely convert the source to the
4347 -- target, and then test the target result against the bounds.
4349 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
4351 -- We make a temporary to hold the value of the converted
4352 -- value (converted to the base type), and then we will
4353 -- do the test against this temporary.
4355 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
4356 -- [constraint_error when Tnn not in Target_Type]
4358 -- Then the conversion itself is replaced by an occurrence of Tnn
4361 Tnn
: constant Entity_Id
:=
4362 Make_Defining_Identifier
(Loc
,
4363 Chars
=> New_Internal_Name
('T'));
4366 Insert_Actions
(N
, New_List
(
4367 Make_Object_Declaration
(Loc
,
4368 Defining_Identifier
=> Tnn
,
4369 Object_Definition
=>
4370 New_Occurrence_Of
(Target_Base_Type
, Loc
),
4371 Constant_Present
=> True,
4373 Make_Type_Conversion
(Loc
,
4374 Subtype_Mark
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
4375 Expression
=> Duplicate_Subexpr
(N
))),
4377 Make_Raise_Constraint_Error
(Loc
,
4380 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
4381 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
4383 Reason
=> Reason
)));
4385 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
4388 -- At this stage, we know that we have two scalar types, which are
4389 -- directly convertible, and where neither scalar type has a base
4390 -- range that is in the range of the other scalar type.
4392 -- The only way this can happen is with a signed and unsigned type.
4393 -- So test for these two cases:
4396 -- Case of the source is unsigned and the target is signed
4398 if Is_Unsigned_Type
(Source_Base_Type
)
4399 and then not Is_Unsigned_Type
(Target_Base_Type
)
4401 -- If the source is unsigned and the target is signed, then we
4402 -- know that the source is not shorter than the target (otherwise
4403 -- the source base type would be in the target base type range).
4405 -- In other words, the unsigned type is either the same size
4406 -- as the target, or it is larger. It cannot be smaller.
4409 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
4411 -- We only need to check the low bound if the low bound of the
4412 -- target type is non-negative. If the low bound of the target
4413 -- type is negative, then we know that we will fit fine.
4415 -- If the high bound of the target type is negative, then we
4416 -- know we have a constraint error, since we can't possibly
4417 -- have a negative source.
4419 -- With these two checks out of the way, we can do the check
4420 -- using the source type safely
4422 -- This is definitely the most annoying case!
4424 -- [constraint_error
4425 -- when (Target_Type'First >= 0
4427 -- N < Source_Base_Type (Target_Type'First))
4428 -- or else Target_Type'Last < 0
4429 -- or else N > Source_Base_Type (Target_Type'Last)];
4431 -- We turn off all checks since we know that the conversions
4432 -- will work fine, given the guards for negative values.
4435 Make_Raise_Constraint_Error
(Loc
,
4441 Left_Opnd
=> Make_Op_Ge
(Loc
,
4443 Make_Attribute_Reference
(Loc
,
4445 New_Occurrence_Of
(Target_Type
, Loc
),
4446 Attribute_Name
=> Name_First
),
4447 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
4451 Left_Opnd
=> Duplicate_Subexpr
(N
),
4453 Convert_To
(Source_Base_Type
,
4454 Make_Attribute_Reference
(Loc
,
4456 New_Occurrence_Of
(Target_Type
, Loc
),
4457 Attribute_Name
=> Name_First
)))),
4462 Make_Attribute_Reference
(Loc
,
4463 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
4464 Attribute_Name
=> Name_Last
),
4465 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
4469 Left_Opnd
=> Duplicate_Subexpr
(N
),
4471 Convert_To
(Source_Base_Type
,
4472 Make_Attribute_Reference
(Loc
,
4473 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
4474 Attribute_Name
=> Name_Last
)))),
4477 Suppress
=> All_Checks
);
4479 -- Only remaining possibility is that the source is signed and
4480 -- the target is unsigned
4483 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
4484 and then Is_Unsigned_Type
(Target_Base_Type
));
4486 -- If the source is signed and the target is unsigned, then
4487 -- we know that the target is not shorter than the source
4488 -- (otherwise the target base type would be in the source
4489 -- base type range).
4491 -- In other words, the unsigned type is either the same size
4492 -- as the target, or it is larger. It cannot be smaller.
4494 -- Clearly we have an error if the source value is negative
4495 -- since no unsigned type can have negative values. If the
4496 -- source type is non-negative, then the check can be done
4497 -- using the target type.
4499 -- Tnn : constant Target_Base_Type (N) := Target_Type;
4501 -- [constraint_error
4502 -- when N < 0 or else Tnn not in Target_Type];
4504 -- We turn off all checks for the conversion of N to the
4505 -- target base type, since we generate the explicit check
4506 -- to ensure that the value is non-negative
4509 Tnn
: constant Entity_Id
:=
4510 Make_Defining_Identifier
(Loc
,
4511 Chars
=> New_Internal_Name
('T'));
4514 Insert_Actions
(N
, New_List
(
4515 Make_Object_Declaration
(Loc
,
4516 Defining_Identifier
=> Tnn
,
4517 Object_Definition
=>
4518 New_Occurrence_Of
(Target_Base_Type
, Loc
),
4519 Constant_Present
=> True,
4521 Make_Type_Conversion
(Loc
,
4523 New_Occurrence_Of
(Target_Base_Type
, Loc
),
4524 Expression
=> Duplicate_Subexpr
(N
))),
4526 Make_Raise_Constraint_Error
(Loc
,
4531 Left_Opnd
=> Duplicate_Subexpr
(N
),
4532 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
4536 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
4538 New_Occurrence_Of
(Target_Type
, Loc
))),
4541 Suppress
=> All_Checks
);
4543 -- Set the Etype explicitly, because Insert_Actions may
4544 -- have placed the declaration in the freeze list for an
4545 -- enclosing construct, and thus it is not analyzed yet.
4547 Set_Etype
(Tnn
, Target_Base_Type
);
4548 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
4552 end Generate_Range_Check
;
4554 ---------------------
4555 -- Get_Discriminal --
4556 ---------------------
4558 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
4559 Loc
: constant Source_Ptr
:= Sloc
(E
);
4564 -- The entity E is the type of a private component of the protected
4565 -- type, or the type of a renaming of that component within a protected
4566 -- operation of that type.
4570 if Ekind
(Sc
) /= E_Protected_Type
then
4573 if Ekind
(Sc
) /= E_Protected_Type
then
4578 D
:= First_Discriminant
(Sc
);
4581 and then Chars
(D
) /= Chars
(Bound
)
4583 Next_Discriminant
(D
);
4586 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
4587 end Get_Discriminal
;
4593 function Guard_Access
4596 Ck_Node
: Node_Id
) return Node_Id
4599 if Nkind
(Cond
) = N_Or_Else
then
4600 Set_Paren_Count
(Cond
, 1);
4603 if Nkind
(Ck_Node
) = N_Allocator
then
4610 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
4611 Right_Opnd
=> Make_Null
(Loc
)),
4612 Right_Opnd
=> Cond
);
4616 -----------------------------
4617 -- Index_Checks_Suppressed --
4618 -----------------------------
4620 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4622 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4623 return Is_Check_Suppressed
(E
, Index_Check
);
4625 return Scope_Suppress
(Index_Check
);
4627 end Index_Checks_Suppressed
;
4633 procedure Initialize
is
4635 for J
in Determine_Range_Cache_N
'Range loop
4636 Determine_Range_Cache_N
(J
) := Empty
;
4640 -------------------------
4641 -- Insert_Range_Checks --
4642 -------------------------
4644 procedure Insert_Range_Checks
4645 (Checks
: Check_Result
;
4647 Suppress_Typ
: Entity_Id
;
4648 Static_Sloc
: Source_Ptr
:= No_Location
;
4649 Flag_Node
: Node_Id
:= Empty
;
4650 Do_Before
: Boolean := False)
4652 Internal_Flag_Node
: Node_Id
:= Flag_Node
;
4653 Internal_Static_Sloc
: Source_Ptr
:= Static_Sloc
;
4655 Check_Node
: Node_Id
;
4656 Checks_On
: constant Boolean :=
4657 (not Index_Checks_Suppressed
(Suppress_Typ
))
4659 (not Range_Checks_Suppressed
(Suppress_Typ
));
4662 -- For now we just return if Checks_On is false, however this should
4663 -- be enhanced to check for an always True value in the condition
4664 -- and to generate a compilation warning???
4666 if not Expander_Active
or else not Checks_On
then
4670 if Static_Sloc
= No_Location
then
4671 Internal_Static_Sloc
:= Sloc
(Node
);
4674 if No
(Flag_Node
) then
4675 Internal_Flag_Node
:= Node
;
4678 for J
in 1 .. 2 loop
4679 exit when No
(Checks
(J
));
4681 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
4682 and then Present
(Condition
(Checks
(J
)))
4684 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
4685 Check_Node
:= Checks
(J
);
4686 Mark_Rewrite_Insertion
(Check_Node
);
4689 Insert_Before_And_Analyze
(Node
, Check_Node
);
4691 Insert_After_And_Analyze
(Node
, Check_Node
);
4694 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
4699 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
4700 Reason
=> CE_Range_Check_Failed
);
4701 Mark_Rewrite_Insertion
(Check_Node
);
4704 Insert_Before_And_Analyze
(Node
, Check_Node
);
4706 Insert_After_And_Analyze
(Node
, Check_Node
);
4710 end Insert_Range_Checks
;
4712 ------------------------
4713 -- Insert_Valid_Check --
4714 ------------------------
4716 procedure Insert_Valid_Check
(Expr
: Node_Id
) is
4717 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
4721 -- Do not insert if checks off, or if not checking validity
4723 if Range_Checks_Suppressed
(Etype
(Expr
))
4724 or else (not Validity_Checks_On
)
4729 -- If we have a checked conversion, then validity check applies to
4730 -- the expression inside the conversion, not the result, since if
4731 -- the expression inside is valid, then so is the conversion result.
4734 while Nkind
(Exp
) = N_Type_Conversion
loop
4735 Exp
:= Expression
(Exp
);
4738 -- Insert the validity check. Note that we do this with validity
4739 -- checks turned off, to avoid recursion, we do not want validity
4740 -- checks on the validity checking code itself!
4742 Validity_Checks_On
:= False;
4745 Make_Raise_Constraint_Error
(Loc
,
4749 Make_Attribute_Reference
(Loc
,
4751 Duplicate_Subexpr_No_Checks
(Exp
, Name_Req
=> True),
4752 Attribute_Name
=> Name_Valid
)),
4753 Reason
=> CE_Invalid_Data
),
4754 Suppress
=> All_Checks
);
4756 -- If the expression is a a reference to an element of a bit-packed
4757 -- array, it is rewritten as a renaming declaration. If the expression
4758 -- is an actual in a call, it has not been expanded, waiting for the
4759 -- proper point at which to do it. The same happens with renamings, so
4760 -- that we have to force the expansion now. This non-local complication
4761 -- is due to code in exp_ch2,adb, exp_ch4.adb and exp_ch6.adb.
4763 if Is_Entity_Name
(Exp
)
4764 and then Nkind
(Parent
(Entity
(Exp
))) = N_Object_Renaming_Declaration
4767 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
4769 if Nkind
(Old_Exp
) = N_Indexed_Component
4770 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
4772 Expand_Packed_Element_Reference
(Old_Exp
);
4777 Validity_Checks_On
:= True;
4778 end Insert_Valid_Check
;
4780 ----------------------------------
4781 -- Install_Null_Excluding_Check --
4782 ----------------------------------
4784 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
4785 Loc
: constant Source_Ptr
:= Sloc
(N
);
4786 Etyp
: constant Entity_Id
:= Etype
(N
);
4789 pragma Assert
(Is_Access_Type
(Etyp
));
4791 -- Don't need access check if:
4792 -- 1) we are analyzing a generic
4793 -- 2) it is known to be non-null
4794 -- 3) the check was suppressed on the type
4795 -- 4) This is an attribute reference that returns an access type.
4798 or else Access_Checks_Suppressed
(Etyp
)
4801 elsif Nkind
(N
) = N_Attribute_Reference
4803 (Attribute_Name
(N
) = Name_Access
4805 Attribute_Name
(N
) = Name_Unchecked_Access
4807 Attribute_Name
(N
) = Name_Unrestricted_Access
)
4810 -- Otherwise install access check
4814 Make_Raise_Constraint_Error
(Loc
,
4817 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
4818 Right_Opnd
=> Make_Null
(Loc
)),
4819 Reason
=> CE_Access_Check_Failed
));
4821 end Install_Null_Excluding_Check
;
4823 --------------------------
4824 -- Install_Static_Check --
4825 --------------------------
4827 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
4828 Stat
: constant Boolean := Is_Static_Expression
(R_Cno
);
4829 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
4833 Make_Raise_Constraint_Error
(Loc
,
4834 Reason
=> CE_Range_Check_Failed
));
4835 Set_Analyzed
(R_Cno
);
4836 Set_Etype
(R_Cno
, Typ
);
4837 Set_Raises_Constraint_Error
(R_Cno
);
4838 Set_Is_Static_Expression
(R_Cno
, Stat
);
4839 end Install_Static_Check
;
4841 ---------------------
4842 -- Kill_All_Checks --
4843 ---------------------
4845 procedure Kill_All_Checks
is
4847 if Debug_Flag_CC
then
4848 w
("Kill_All_Checks");
4851 -- We reset the number of saved checks to zero, and also modify
4852 -- all stack entries for statement ranges to indicate that the
4853 -- number of checks at each level is now zero.
4855 Num_Saved_Checks
:= 0;
4857 for J
in 1 .. Saved_Checks_TOS
loop
4858 Saved_Checks_Stack
(J
) := 0;
4860 end Kill_All_Checks
;
4866 procedure Kill_Checks
(V
: Entity_Id
) is
4868 if Debug_Flag_CC
then
4869 w
("Kill_Checks for entity", Int
(V
));
4872 for J
in 1 .. Num_Saved_Checks
loop
4873 if Saved_Checks
(J
).Entity
= V
then
4874 if Debug_Flag_CC
then
4875 w
(" Checks killed for saved check ", J
);
4878 Saved_Checks
(J
).Killed
:= True;
4883 ------------------------------
4884 -- Length_Checks_Suppressed --
4885 ------------------------------
4887 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4889 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4890 return Is_Check_Suppressed
(E
, Length_Check
);
4892 return Scope_Suppress
(Length_Check
);
4894 end Length_Checks_Suppressed
;
4896 --------------------------------
4897 -- Overflow_Checks_Suppressed --
4898 --------------------------------
4900 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4902 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4903 return Is_Check_Suppressed
(E
, Overflow_Check
);
4905 return Scope_Suppress
(Overflow_Check
);
4907 end Overflow_Checks_Suppressed
;
4913 function Range_Check
4915 Target_Typ
: Entity_Id
;
4916 Source_Typ
: Entity_Id
:= Empty
;
4917 Warn_Node
: Node_Id
:= Empty
) return Check_Result
4920 return Selected_Range_Checks
4921 (Ck_Node
, Target_Typ
, Source_Typ
, Warn_Node
);
4924 -----------------------------
4925 -- Range_Checks_Suppressed --
4926 -----------------------------
4928 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4932 -- Note: for now we always suppress range checks on Vax float types,
4933 -- since Gigi does not know how to generate these checks.
4935 if Vax_Float
(E
) then
4937 elsif Kill_Range_Checks
(E
) then
4939 elsif Checks_May_Be_Suppressed
(E
) then
4940 return Is_Check_Suppressed
(E
, Range_Check
);
4944 return Scope_Suppress
(Range_Check
);
4945 end Range_Checks_Suppressed
;
4951 procedure Remove_Checks
(Expr
: Node_Id
) is
4952 Discard
: Traverse_Result
;
4953 pragma Warnings
(Off
, Discard
);
4955 function Process
(N
: Node_Id
) return Traverse_Result
;
4956 -- Process a single node during the traversal
4958 function Traverse
is new Traverse_Func
(Process
);
4959 -- The traversal function itself
4965 function Process
(N
: Node_Id
) return Traverse_Result
is
4967 if Nkind
(N
) not in N_Subexpr
then
4971 Set_Do_Range_Check
(N
, False);
4975 Discard
:= Traverse
(Left_Opnd
(N
));
4978 when N_Attribute_Reference
=>
4979 Set_Do_Overflow_Check
(N
, False);
4981 when N_Function_Call
=>
4982 Set_Do_Tag_Check
(N
, False);
4985 Set_Do_Overflow_Check
(N
, False);
4989 Set_Do_Division_Check
(N
, False);
4992 Set_Do_Length_Check
(N
, False);
4995 Set_Do_Division_Check
(N
, False);
4998 Set_Do_Length_Check
(N
, False);
5001 Set_Do_Division_Check
(N
, False);
5004 Set_Do_Length_Check
(N
, False);
5011 Discard
:= Traverse
(Left_Opnd
(N
));
5014 when N_Selected_Component
=>
5015 Set_Do_Discriminant_Check
(N
, False);
5017 when N_Type_Conversion
=>
5018 Set_Do_Length_Check
(N
, False);
5019 Set_Do_Tag_Check
(N
, False);
5020 Set_Do_Overflow_Check
(N
, False);
5029 -- Start of processing for Remove_Checks
5032 Discard
:= Traverse
(Expr
);
5035 ----------------------------
5036 -- Selected_Length_Checks --
5037 ----------------------------
5039 function Selected_Length_Checks
5041 Target_Typ
: Entity_Id
;
5042 Source_Typ
: Entity_Id
;
5043 Warn_Node
: Node_Id
) return Check_Result
5045 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
5048 Expr_Actual
: Node_Id
;
5050 Cond
: Node_Id
:= Empty
;
5051 Do_Access
: Boolean := False;
5052 Wnode
: Node_Id
:= Warn_Node
;
5053 Ret_Result
: Check_Result
:= (Empty
, Empty
);
5054 Num_Checks
: Natural := 0;
5056 procedure Add_Check
(N
: Node_Id
);
5057 -- Adds the action given to Ret_Result if N is non-Empty
5059 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
5060 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
5061 -- Comments required ???
5063 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
5064 -- True for equal literals and for nodes that denote the same constant
5065 -- entity, even if its value is not a static constant. This includes the
5066 -- case of a discriminal reference within an init proc. Removes some
5067 -- obviously superfluous checks.
5069 function Length_E_Cond
5070 (Exptyp
: Entity_Id
;
5072 Indx
: Nat
) return Node_Id
;
5073 -- Returns expression to compute:
5074 -- Typ'Length /= Exptyp'Length
5076 function Length_N_Cond
5079 Indx
: Nat
) return Node_Id
;
5080 -- Returns expression to compute:
5081 -- Typ'Length /= Expr'Length
5087 procedure Add_Check
(N
: Node_Id
) is
5091 -- For now, ignore attempt to place more than 2 checks ???
5093 if Num_Checks
= 2 then
5097 pragma Assert
(Num_Checks
<= 1);
5098 Num_Checks
:= Num_Checks
+ 1;
5099 Ret_Result
(Num_Checks
) := N
;
5107 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
5108 Pt
: constant Entity_Id
:= Scope
(Scope
(E
));
5110 E1
: Entity_Id
:= E
;
5113 if Ekind
(Scope
(E
)) = E_Record_Type
5114 and then Has_Discriminants
(Scope
(E
))
5116 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
5119 Insert_Action
(Ck_Node
, N
);
5120 E1
:= Defining_Identifier
(N
);
5124 if Ekind
(E1
) = E_String_Literal_Subtype
then
5126 Make_Integer_Literal
(Loc
,
5127 Intval
=> String_Literal_Length
(E1
));
5129 elsif Ekind
(Pt
) = E_Protected_Type
5130 and then Has_Discriminants
(Pt
)
5131 and then Has_Completion
(Pt
)
5132 and then not Inside_Init_Proc
5135 -- If the type whose length is needed is a private component
5136 -- constrained by a discriminant, we must expand the 'Length
5137 -- attribute into an explicit computation, using the discriminal
5138 -- of the current protected operation. This is because the actual
5139 -- type of the prival is constructed after the protected opera-
5140 -- tion has been fully expanded.
5143 Indx_Type
: Node_Id
;
5146 Do_Expand
: Boolean := False;
5149 Indx_Type
:= First_Index
(E
);
5151 for J
in 1 .. Indx
- 1 loop
5152 Next_Index
(Indx_Type
);
5155 Get_Index_Bounds
(Indx_Type
, Lo
, Hi
);
5157 if Nkind
(Lo
) = N_Identifier
5158 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
5160 Lo
:= Get_Discriminal
(E
, Lo
);
5164 if Nkind
(Hi
) = N_Identifier
5165 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
5167 Hi
:= Get_Discriminal
(E
, Hi
);
5172 if not Is_Entity_Name
(Lo
) then
5173 Lo
:= Duplicate_Subexpr_No_Checks
(Lo
);
5176 if not Is_Entity_Name
(Hi
) then
5177 Lo
:= Duplicate_Subexpr_No_Checks
(Hi
);
5183 Make_Op_Subtract
(Loc
,
5187 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
5192 Make_Attribute_Reference
(Loc
,
5193 Attribute_Name
=> Name_Length
,
5195 New_Occurrence_Of
(E1
, Loc
));
5198 Set_Expressions
(N
, New_List
(
5199 Make_Integer_Literal
(Loc
, Indx
)));
5208 Make_Attribute_Reference
(Loc
,
5209 Attribute_Name
=> Name_Length
,
5211 New_Occurrence_Of
(E1
, Loc
));
5214 Set_Expressions
(N
, New_List
(
5215 Make_Integer_Literal
(Loc
, Indx
)));
5227 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
5230 Make_Attribute_Reference
(Loc
,
5231 Attribute_Name
=> Name_Length
,
5233 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
5234 Expressions
=> New_List
(
5235 Make_Integer_Literal
(Loc
, Indx
)));
5243 function Length_E_Cond
5244 (Exptyp
: Entity_Id
;
5246 Indx
: Nat
) return Node_Id
5251 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
5252 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
5260 function Length_N_Cond
5263 Indx
: Nat
) return Node_Id
5268 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
5269 Right_Opnd
=> Get_N_Length
(Expr
, Indx
));
5273 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
5276 (Nkind
(L
) = N_Integer_Literal
5277 and then Nkind
(R
) = N_Integer_Literal
5278 and then Intval
(L
) = Intval
(R
))
5282 and then Ekind
(Entity
(L
)) = E_Constant
5283 and then ((Is_Entity_Name
(R
)
5284 and then Entity
(L
) = Entity
(R
))
5286 (Nkind
(R
) = N_Type_Conversion
5287 and then Is_Entity_Name
(Expression
(R
))
5288 and then Entity
(L
) = Entity
(Expression
(R
)))))
5292 and then Ekind
(Entity
(R
)) = E_Constant
5293 and then Nkind
(L
) = N_Type_Conversion
5294 and then Is_Entity_Name
(Expression
(L
))
5295 and then Entity
(R
) = Entity
(Expression
(L
)))
5299 and then Is_Entity_Name
(R
)
5300 and then Entity
(L
) = Entity
(R
)
5301 and then Ekind
(Entity
(L
)) = E_In_Parameter
5302 and then Inside_Init_Proc
);
5305 -- Start of processing for Selected_Length_Checks
5308 if not Expander_Active
then
5312 if Target_Typ
= Any_Type
5313 or else Target_Typ
= Any_Composite
5314 or else Raises_Constraint_Error
(Ck_Node
)
5323 T_Typ
:= Target_Typ
;
5325 if No
(Source_Typ
) then
5326 S_Typ
:= Etype
(Ck_Node
);
5328 S_Typ
:= Source_Typ
;
5331 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
5335 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
5336 S_Typ
:= Designated_Type
(S_Typ
);
5337 T_Typ
:= Designated_Type
(T_Typ
);
5340 -- A simple optimization
5342 if Nkind
(Ck_Node
) = N_Null
then
5347 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
5348 if Is_Constrained
(T_Typ
) then
5350 -- The checking code to be generated will freeze the
5351 -- corresponding array type. However, we must freeze the
5352 -- type now, so that the freeze node does not appear within
5353 -- the generated condional expression, but ahead of it.
5355 Freeze_Before
(Ck_Node
, T_Typ
);
5357 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
5358 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
5360 if Is_Access_Type
(Exptyp
) then
5361 Exptyp
:= Designated_Type
(Exptyp
);
5364 -- String_Literal case. This needs to be handled specially be-
5365 -- cause no index types are available for string literals. The
5366 -- condition is simply:
5368 -- T_Typ'Length = string-literal-length
5370 if Nkind
(Expr_Actual
) = N_String_Literal
5371 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
5375 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
5377 Make_Integer_Literal
(Loc
,
5379 String_Literal_Length
(Etype
(Expr_Actual
))));
5381 -- General array case. Here we have a usable actual subtype for
5382 -- the expression, and the condition is built from the two types
5385 -- T_Typ'Length /= Exptyp'Length or else
5386 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
5387 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
5390 elsif Is_Constrained
(Exptyp
) then
5392 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
5406 -- At the library level, we need to ensure that the
5407 -- type of the object is elaborated before the check
5408 -- itself is emitted. This is only done if the object
5409 -- is in the current compilation unit, otherwise the
5410 -- type is frozen and elaborated in its unit.
5412 if Is_Itype
(Exptyp
)
5414 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
5416 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
5417 and then In_Open_Scopes
(Scope
(Exptyp
))
5419 Ref_Node
:= Make_Itype_Reference
(Sloc
(Ck_Node
));
5420 Set_Itype
(Ref_Node
, Exptyp
);
5421 Insert_Action
(Ck_Node
, Ref_Node
);
5424 L_Index
:= First_Index
(T_Typ
);
5425 R_Index
:= First_Index
(Exptyp
);
5427 for Indx
in 1 .. Ndims
loop
5428 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
5430 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
5432 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
5433 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
5435 -- Deal with compile time length check. Note that we
5436 -- skip this in the access case, because the access
5437 -- value may be null, so we cannot know statically.
5440 and then Compile_Time_Known_Value
(L_Low
)
5441 and then Compile_Time_Known_Value
(L_High
)
5442 and then Compile_Time_Known_Value
(R_Low
)
5443 and then Compile_Time_Known_Value
(R_High
)
5445 if Expr_Value
(L_High
) >= Expr_Value
(L_Low
) then
5446 L_Length
:= Expr_Value
(L_High
) -
5447 Expr_Value
(L_Low
) + 1;
5449 L_Length
:= UI_From_Int
(0);
5452 if Expr_Value
(R_High
) >= Expr_Value
(R_Low
) then
5453 R_Length
:= Expr_Value
(R_High
) -
5454 Expr_Value
(R_Low
) + 1;
5456 R_Length
:= UI_From_Int
(0);
5459 if L_Length
> R_Length
then
5461 (Compile_Time_Constraint_Error
5462 (Wnode
, "too few elements for}?", T_Typ
));
5464 elsif L_Length
< R_Length
then
5466 (Compile_Time_Constraint_Error
5467 (Wnode
, "too many elements for}?", T_Typ
));
5470 -- The comparison for an individual index subtype
5471 -- is omitted if the corresponding index subtypes
5472 -- statically match, since the result is known to
5473 -- be true. Note that this test is worth while even
5474 -- though we do static evaluation, because non-static
5475 -- subtypes can statically match.
5478 Subtypes_Statically_Match
5479 (Etype
(L_Index
), Etype
(R_Index
))
5482 (Same_Bounds
(L_Low
, R_Low
)
5483 and then Same_Bounds
(L_High
, R_High
))
5486 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
5495 -- Handle cases where we do not get a usable actual subtype that
5496 -- is constrained. This happens for example in the function call
5497 -- and explicit dereference cases. In these cases, we have to get
5498 -- the length or range from the expression itself, making sure we
5499 -- do not evaluate it more than once.
5501 -- Here Ck_Node is the original expression, or more properly the
5502 -- result of applying Duplicate_Expr to the original tree,
5503 -- forcing the result to be a name.
5507 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
5510 -- Build the condition for the explicit dereference case
5512 for Indx
in 1 .. Ndims
loop
5514 (Cond
, Length_N_Cond
(Ck_Node
, T_Typ
, Indx
));
5521 -- Construct the test and insert into the tree
5523 if Present
(Cond
) then
5525 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
5529 (Make_Raise_Constraint_Error
(Loc
,
5531 Reason
=> CE_Length_Check_Failed
));
5535 end Selected_Length_Checks
;
5537 ---------------------------
5538 -- Selected_Range_Checks --
5539 ---------------------------
5541 function Selected_Range_Checks
5543 Target_Typ
: Entity_Id
;
5544 Source_Typ
: Entity_Id
;
5545 Warn_Node
: Node_Id
) return Check_Result
5547 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
5550 Expr_Actual
: Node_Id
;
5552 Cond
: Node_Id
:= Empty
;
5553 Do_Access
: Boolean := False;
5554 Wnode
: Node_Id
:= Warn_Node
;
5555 Ret_Result
: Check_Result
:= (Empty
, Empty
);
5556 Num_Checks
: Integer := 0;
5558 procedure Add_Check
(N
: Node_Id
);
5559 -- Adds the action given to Ret_Result if N is non-Empty
5561 function Discrete_Range_Cond
5563 Typ
: Entity_Id
) return Node_Id
;
5564 -- Returns expression to compute:
5565 -- Low_Bound (Expr) < Typ'First
5567 -- High_Bound (Expr) > Typ'Last
5569 function Discrete_Expr_Cond
5571 Typ
: Entity_Id
) return Node_Id
;
5572 -- Returns expression to compute:
5577 function Get_E_First_Or_Last
5580 Nam
: Name_Id
) return Node_Id
;
5581 -- Returns expression to compute:
5582 -- E'First or E'Last
5584 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
5585 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
5586 -- Returns expression to compute:
5587 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
5589 function Range_E_Cond
5590 (Exptyp
: Entity_Id
;
5594 -- Returns expression to compute:
5595 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
5597 function Range_Equal_E_Cond
5598 (Exptyp
: Entity_Id
;
5600 Indx
: Nat
) return Node_Id
;
5601 -- Returns expression to compute:
5602 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
5604 function Range_N_Cond
5607 Indx
: Nat
) return Node_Id
;
5608 -- Return expression to compute:
5609 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
5615 procedure Add_Check
(N
: Node_Id
) is
5619 -- For now, ignore attempt to place more than 2 checks ???
5621 if Num_Checks
= 2 then
5625 pragma Assert
(Num_Checks
<= 1);
5626 Num_Checks
:= Num_Checks
+ 1;
5627 Ret_Result
(Num_Checks
) := N
;
5631 -------------------------
5632 -- Discrete_Expr_Cond --
5633 -------------------------
5635 function Discrete_Expr_Cond
5637 Typ
: Entity_Id
) return Node_Id
5645 Convert_To
(Base_Type
(Typ
),
5646 Duplicate_Subexpr_No_Checks
(Expr
)),
5648 Convert_To
(Base_Type
(Typ
),
5649 Get_E_First_Or_Last
(Typ
, 0, Name_First
))),
5654 Convert_To
(Base_Type
(Typ
),
5655 Duplicate_Subexpr_No_Checks
(Expr
)),
5659 Get_E_First_Or_Last
(Typ
, 0, Name_Last
))));
5660 end Discrete_Expr_Cond
;
5662 -------------------------
5663 -- Discrete_Range_Cond --
5664 -------------------------
5666 function Discrete_Range_Cond
5668 Typ
: Entity_Id
) return Node_Id
5670 LB
: Node_Id
:= Low_Bound
(Expr
);
5671 HB
: Node_Id
:= High_Bound
(Expr
);
5673 Left_Opnd
: Node_Id
;
5674 Right_Opnd
: Node_Id
;
5677 if Nkind
(LB
) = N_Identifier
5678 and then Ekind
(Entity
(LB
)) = E_Discriminant
then
5679 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
5682 if Nkind
(HB
) = N_Identifier
5683 and then Ekind
(Entity
(HB
)) = E_Discriminant
then
5684 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
5691 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
5695 (Base_Type
(Typ
), Get_E_First_Or_Last
(Typ
, 0, Name_First
)));
5697 if Base_Type
(Typ
) = Typ
then
5700 elsif Compile_Time_Known_Value
(High_Bound
(Scalar_Range
(Typ
)))
5702 Compile_Time_Known_Value
(High_Bound
(Scalar_Range
5705 if Is_Floating_Point_Type
(Typ
) then
5706 if Expr_Value_R
(High_Bound
(Scalar_Range
(Typ
))) =
5707 Expr_Value_R
(High_Bound
(Scalar_Range
(Base_Type
(Typ
))))
5713 if Expr_Value
(High_Bound
(Scalar_Range
(Typ
))) =
5714 Expr_Value
(High_Bound
(Scalar_Range
(Base_Type
(Typ
))))
5725 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
5730 Get_E_First_Or_Last
(Typ
, 0, Name_Last
)));
5732 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
5733 end Discrete_Range_Cond
;
5735 -------------------------
5736 -- Get_E_First_Or_Last --
5737 -------------------------
5739 function Get_E_First_Or_Last
5742 Nam
: Name_Id
) return Node_Id
5750 if Is_Array_Type
(E
) then
5751 N
:= First_Index
(E
);
5753 for J
in 2 .. Indx
loop
5758 N
:= Scalar_Range
(E
);
5761 if Nkind
(N
) = N_Subtype_Indication
then
5762 LB
:= Low_Bound
(Range_Expression
(Constraint
(N
)));
5763 HB
:= High_Bound
(Range_Expression
(Constraint
(N
)));
5765 elsif Is_Entity_Name
(N
) then
5766 LB
:= Type_Low_Bound
(Etype
(N
));
5767 HB
:= Type_High_Bound
(Etype
(N
));
5770 LB
:= Low_Bound
(N
);
5771 HB
:= High_Bound
(N
);
5774 if Nam
= Name_First
then
5780 if Nkind
(Bound
) = N_Identifier
5781 and then Ekind
(Entity
(Bound
)) = E_Discriminant
5783 -- If this is a task discriminant, and we are the body, we must
5784 -- retrieve the corresponding body discriminal. This is another
5785 -- consequence of the early creation of discriminals, and the
5786 -- need to generate constraint checks before their declarations
5787 -- are made visible.
5789 if Is_Concurrent_Record_Type
(Scope
(Entity
(Bound
))) then
5791 Tsk
: constant Entity_Id
:=
5792 Corresponding_Concurrent_Type
5793 (Scope
(Entity
(Bound
)));
5797 if In_Open_Scopes
(Tsk
)
5798 and then Has_Completion
(Tsk
)
5800 -- Find discriminant of original task, and use its
5801 -- current discriminal, which is the renaming within
5804 Disc
:= First_Discriminant
(Tsk
);
5805 while Present
(Disc
) loop
5806 if Chars
(Disc
) = Chars
(Entity
(Bound
)) then
5807 Set_Scope
(Discriminal
(Disc
), Tsk
);
5808 return New_Occurrence_Of
(Discriminal
(Disc
), Loc
);
5811 Next_Discriminant
(Disc
);
5814 -- That loop should always succeed in finding a matching
5815 -- entry and returning. Fatal error if not.
5817 raise Program_Error
;
5821 New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
5825 return New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
5828 elsif Nkind
(Bound
) = N_Identifier
5829 and then Ekind
(Entity
(Bound
)) = E_In_Parameter
5830 and then not Inside_Init_Proc
5832 return Get_Discriminal
(E
, Bound
);
5834 elsif Nkind
(Bound
) = N_Integer_Literal
then
5835 return Make_Integer_Literal
(Loc
, Intval
(Bound
));
5837 -- Case of a bound that has been rewritten to an
5838 -- N_Raise_Constraint_Error node because it is an out-of-range
5839 -- value. We may not call Duplicate_Subexpr on this node because
5840 -- an N_Raise_Constraint_Error is not side effect free, and we may
5841 -- not assume that we are in the proper context to remove side
5842 -- effects on it at the point of reference.
5844 elsif Nkind
(Bound
) = N_Raise_Constraint_Error
then
5845 return New_Copy_Tree
(Bound
);
5848 return Duplicate_Subexpr_No_Checks
(Bound
);
5850 end Get_E_First_Or_Last
;
5856 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
5859 Make_Attribute_Reference
(Loc
,
5860 Attribute_Name
=> Name_First
,
5862 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
5863 Expressions
=> New_List
(
5864 Make_Integer_Literal
(Loc
, Indx
)));
5871 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
5874 Make_Attribute_Reference
(Loc
,
5875 Attribute_Name
=> Name_Last
,
5877 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
5878 Expressions
=> New_List
(
5879 Make_Integer_Literal
(Loc
, Indx
)));
5886 function Range_E_Cond
5887 (Exptyp
: Entity_Id
;
5889 Indx
: Nat
) return Node_Id
5896 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_First
),
5897 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_First
)),
5901 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_Last
),
5902 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_Last
)));
5906 ------------------------
5907 -- Range_Equal_E_Cond --
5908 ------------------------
5910 function Range_Equal_E_Cond
5911 (Exptyp
: Entity_Id
;
5913 Indx
: Nat
) return Node_Id
5920 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_First
),
5921 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_First
)),
5924 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_Last
),
5925 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_Last
)));
5926 end Range_Equal_E_Cond
;
5932 function Range_N_Cond
5935 Indx
: Nat
) return Node_Id
5942 Left_Opnd
=> Get_N_First
(Expr
, Indx
),
5943 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_First
)),
5947 Left_Opnd
=> Get_N_Last
(Expr
, Indx
),
5948 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_Last
)));
5951 -- Start of processing for Selected_Range_Checks
5954 if not Expander_Active
then
5958 if Target_Typ
= Any_Type
5959 or else Target_Typ
= Any_Composite
5960 or else Raises_Constraint_Error
(Ck_Node
)
5969 T_Typ
:= Target_Typ
;
5971 if No
(Source_Typ
) then
5972 S_Typ
:= Etype
(Ck_Node
);
5974 S_Typ
:= Source_Typ
;
5977 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
5981 -- The order of evaluating T_Typ before S_Typ seems to be critical
5982 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
5983 -- in, and since Node can be an N_Range node, it might be invalid.
5984 -- Should there be an assert check somewhere for taking the Etype of
5985 -- an N_Range node ???
5987 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
5988 S_Typ
:= Designated_Type
(S_Typ
);
5989 T_Typ
:= Designated_Type
(T_Typ
);
5992 -- A simple optimization
5994 if Nkind
(Ck_Node
) = N_Null
then
5999 -- For an N_Range Node, check for a null range and then if not
6000 -- null generate a range check action.
6002 if Nkind
(Ck_Node
) = N_Range
then
6004 -- There's no point in checking a range against itself
6006 if Ck_Node
= Scalar_Range
(T_Typ
) then
6011 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
6012 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
6013 LB
: constant Node_Id
:= Low_Bound
(Ck_Node
);
6014 HB
: constant Node_Id
:= High_Bound
(Ck_Node
);
6015 Null_Range
: Boolean;
6017 Out_Of_Range_L
: Boolean;
6018 Out_Of_Range_H
: Boolean;
6021 -- Check for case where everything is static and we can
6022 -- do the check at compile time. This is skipped if we
6023 -- have an access type, since the access value may be null.
6025 -- ??? This code can be improved since you only need to know
6026 -- that the two respective bounds (LB & T_LB or HB & T_HB)
6027 -- are known at compile time to emit pertinent messages.
6029 if Compile_Time_Known_Value
(LB
)
6030 and then Compile_Time_Known_Value
(HB
)
6031 and then Compile_Time_Known_Value
(T_LB
)
6032 and then Compile_Time_Known_Value
(T_HB
)
6033 and then not Do_Access
6035 -- Floating-point case
6037 if Is_Floating_Point_Type
(S_Typ
) then
6038 Null_Range
:= Expr_Value_R
(HB
) < Expr_Value_R
(LB
);
6040 (Expr_Value_R
(LB
) < Expr_Value_R
(T_LB
))
6042 (Expr_Value_R
(LB
) > Expr_Value_R
(T_HB
));
6045 (Expr_Value_R
(HB
) > Expr_Value_R
(T_HB
))
6047 (Expr_Value_R
(HB
) < Expr_Value_R
(T_LB
));
6049 -- Fixed or discrete type case
6052 Null_Range
:= Expr_Value
(HB
) < Expr_Value
(LB
);
6054 (Expr_Value
(LB
) < Expr_Value
(T_LB
))
6056 (Expr_Value
(LB
) > Expr_Value
(T_HB
));
6059 (Expr_Value
(HB
) > Expr_Value
(T_HB
))
6061 (Expr_Value
(HB
) < Expr_Value
(T_LB
));
6064 if not Null_Range
then
6065 if Out_Of_Range_L
then
6066 if No
(Warn_Node
) then
6068 (Compile_Time_Constraint_Error
6069 (Low_Bound
(Ck_Node
),
6070 "static value out of range of}?", T_Typ
));
6074 (Compile_Time_Constraint_Error
6076 "static range out of bounds of}?", T_Typ
));
6080 if Out_Of_Range_H
then
6081 if No
(Warn_Node
) then
6083 (Compile_Time_Constraint_Error
6084 (High_Bound
(Ck_Node
),
6085 "static value out of range of}?", T_Typ
));
6089 (Compile_Time_Constraint_Error
6091 "static range out of bounds of}?", T_Typ
));
6099 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
6100 HB
: Node_Id
:= High_Bound
(Ck_Node
);
6104 -- If either bound is a discriminant and we are within
6105 -- the record declaration, it is a use of the discriminant
6106 -- in a constraint of a component, and nothing can be
6107 -- checked here. The check will be emitted within the
6108 -- init proc. Before then, the discriminal has no real
6111 if Nkind
(LB
) = N_Identifier
6112 and then Ekind
(Entity
(LB
)) = E_Discriminant
6114 if Current_Scope
= Scope
(Entity
(LB
)) then
6118 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
6122 if Nkind
(HB
) = N_Identifier
6123 and then Ekind
(Entity
(HB
)) = E_Discriminant
6125 if Current_Scope
= Scope
(Entity
(HB
)) then
6129 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
6133 Cond
:= Discrete_Range_Cond
(Ck_Node
, T_Typ
);
6134 Set_Paren_Count
(Cond
, 1);
6140 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(HB
),
6141 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(LB
)),
6142 Right_Opnd
=> Cond
);
6148 elsif Is_Scalar_Type
(S_Typ
) then
6150 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
6151 -- except the above simply sets a flag in the node and lets
6152 -- gigi generate the check base on the Etype of the expression.
6153 -- Sometimes, however we want to do a dynamic check against an
6154 -- arbitrary target type, so we do that here.
6156 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
6157 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
6159 -- For literals, we can tell if the constraint error will be
6160 -- raised at compile time, so we never need a dynamic check, but
6161 -- if the exception will be raised, then post the usual warning,
6162 -- and replace the literal with a raise constraint error
6163 -- expression. As usual, skip this for access types
6165 elsif Compile_Time_Known_Value
(Ck_Node
)
6166 and then not Do_Access
6169 LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
6170 UB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
6172 Out_Of_Range
: Boolean;
6173 Static_Bounds
: constant Boolean :=
6174 Compile_Time_Known_Value
(LB
)
6175 and Compile_Time_Known_Value
(UB
);
6178 -- Following range tests should use Sem_Eval routine ???
6180 if Static_Bounds
then
6181 if Is_Floating_Point_Type
(S_Typ
) then
6183 (Expr_Value_R
(Ck_Node
) < Expr_Value_R
(LB
))
6185 (Expr_Value_R
(Ck_Node
) > Expr_Value_R
(UB
));
6187 else -- fixed or discrete type
6189 Expr_Value
(Ck_Node
) < Expr_Value
(LB
)
6191 Expr_Value
(Ck_Node
) > Expr_Value
(UB
);
6194 -- Bounds of the type are static and the literal is
6195 -- out of range so make a warning message.
6197 if Out_Of_Range
then
6198 if No
(Warn_Node
) then
6200 (Compile_Time_Constraint_Error
6202 "static value out of range of}?", T_Typ
));
6206 (Compile_Time_Constraint_Error
6208 "static value out of range of}?", T_Typ
));
6213 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
6217 -- Here for the case of a non-static expression, we need a runtime
6218 -- check unless the source type range is guaranteed to be in the
6219 -- range of the target type.
6222 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
6223 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
6228 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
6229 if Is_Constrained
(T_Typ
) then
6231 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
6232 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
6234 if Is_Access_Type
(Exptyp
) then
6235 Exptyp
:= Designated_Type
(Exptyp
);
6238 -- String_Literal case. This needs to be handled specially be-
6239 -- cause no index types are available for string literals. The
6240 -- condition is simply:
6242 -- T_Typ'Length = string-literal-length
6244 if Nkind
(Expr_Actual
) = N_String_Literal
then
6247 -- General array case. Here we have a usable actual subtype for
6248 -- the expression, and the condition is built from the two types
6250 -- T_Typ'First < Exptyp'First or else
6251 -- T_Typ'Last > Exptyp'Last or else
6252 -- T_Typ'First(1) < Exptyp'First(1) or else
6253 -- T_Typ'Last(1) > Exptyp'Last(1) or else
6256 elsif Is_Constrained
(Exptyp
) then
6258 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
6268 L_Index
:= First_Index
(T_Typ
);
6269 R_Index
:= First_Index
(Exptyp
);
6271 for Indx
in 1 .. Ndims
loop
6272 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
6274 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
6276 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
6277 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
6279 -- Deal with compile time length check. Note that we
6280 -- skip this in the access case, because the access
6281 -- value may be null, so we cannot know statically.
6284 Subtypes_Statically_Match
6285 (Etype
(L_Index
), Etype
(R_Index
))
6287 -- If the target type is constrained then we
6288 -- have to check for exact equality of bounds
6289 -- (required for qualified expressions).
6291 if Is_Constrained
(T_Typ
) then
6294 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
6298 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
6309 -- Handle cases where we do not get a usable actual subtype that
6310 -- is constrained. This happens for example in the function call
6311 -- and explicit dereference cases. In these cases, we have to get
6312 -- the length or range from the expression itself, making sure we
6313 -- do not evaluate it more than once.
6315 -- Here Ck_Node is the original expression, or more properly the
6316 -- result of applying Duplicate_Expr to the original tree,
6317 -- forcing the result to be a name.
6321 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
6324 -- Build the condition for the explicit dereference case
6326 for Indx
in 1 .. Ndims
loop
6328 (Cond
, Range_N_Cond
(Ck_Node
, T_Typ
, Indx
));
6335 -- Generate an Action to check that the bounds of the
6336 -- source value are within the constraints imposed by the
6337 -- target type for a conversion to an unconstrained type.
6340 if Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
then
6342 Opnd_Index
: Node_Id
;
6343 Targ_Index
: Node_Id
;
6347 := First_Index
(Get_Actual_Subtype
(Ck_Node
));
6348 Targ_Index
:= First_Index
(T_Typ
);
6350 while Opnd_Index
/= Empty
loop
6351 if Nkind
(Opnd_Index
) = N_Range
then
6353 (Low_Bound
(Opnd_Index
), Etype
(Targ_Index
))
6356 (High_Bound
(Opnd_Index
), Etype
(Targ_Index
))
6360 -- If null range, no check needed
6363 Compile_Time_Known_Value
(High_Bound
(Opnd_Index
))
6365 Compile_Time_Known_Value
(Low_Bound
(Opnd_Index
))
6367 Expr_Value
(High_Bound
(Opnd_Index
)) <
6368 Expr_Value
(Low_Bound
(Opnd_Index
))
6372 elsif Is_Out_Of_Range
6373 (Low_Bound
(Opnd_Index
), Etype
(Targ_Index
))
6376 (High_Bound
(Opnd_Index
), Etype
(Targ_Index
))
6379 (Compile_Time_Constraint_Error
6380 (Wnode
, "value out of range of}?", T_Typ
));
6386 (Opnd_Index
, Etype
(Targ_Index
)));
6390 Next_Index
(Opnd_Index
);
6391 Next_Index
(Targ_Index
);
6398 -- Construct the test and insert into the tree
6400 if Present
(Cond
) then
6402 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
6406 (Make_Raise_Constraint_Error
(Loc
,
6408 Reason
=> CE_Range_Check_Failed
));
6412 end Selected_Range_Checks
;
6414 -------------------------------
6415 -- Storage_Checks_Suppressed --
6416 -------------------------------
6418 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6420 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6421 return Is_Check_Suppressed
(E
, Storage_Check
);
6423 return Scope_Suppress
(Storage_Check
);
6425 end Storage_Checks_Suppressed
;
6427 ---------------------------
6428 -- Tag_Checks_Suppressed --
6429 ---------------------------
6431 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6434 if Kill_Tag_Checks
(E
) then
6436 elsif Checks_May_Be_Suppressed
(E
) then
6437 return Is_Check_Suppressed
(E
, Tag_Check
);
6441 return Scope_Suppress
(Tag_Check
);
6442 end Tag_Checks_Suppressed
;