1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 -- We do not need checks if we are not generating code (i.e. the
386 -- expander is not active). This is not just an optimization, there
387 -- are cases (e.g. with pragma Debug) where generating the checks
388 -- can cause real trouble).
390 if not Expander_Active
then
394 -- No check if short circuiting makes check unnecessary
396 if not Check_Needed
(P
, Access_Check
) then
400 -- Otherwise go ahead and install the check
402 Install_Null_Excluding_Check
(P
);
403 end Apply_Access_Check
;
405 -------------------------------
406 -- Apply_Accessibility_Check --
407 -------------------------------
409 procedure Apply_Accessibility_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
410 Loc
: constant Source_Ptr
:= Sloc
(N
);
411 Param_Ent
: constant Entity_Id
:= Param_Entity
(N
);
412 Param_Level
: Node_Id
;
413 Type_Level
: Node_Id
;
416 if Inside_A_Generic
then
419 -- Only apply the run-time check if the access parameter
420 -- has an associated extra access level parameter and
421 -- when the level of the type is less deep than the level
422 -- of the access parameter.
424 elsif Present
(Param_Ent
)
425 and then Present
(Extra_Accessibility
(Param_Ent
))
426 and then UI_Gt
(Object_Access_Level
(N
),
427 Type_Access_Level
(Typ
))
428 and then not Accessibility_Checks_Suppressed
(Param_Ent
)
429 and then not Accessibility_Checks_Suppressed
(Typ
)
432 New_Occurrence_Of
(Extra_Accessibility
(Param_Ent
), Loc
);
435 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
));
437 -- Raise Program_Error if the accessibility level of the the access
438 -- parameter is deeper than the level of the target access type.
441 Make_Raise_Program_Error
(Loc
,
444 Left_Opnd
=> Param_Level
,
445 Right_Opnd
=> Type_Level
),
446 Reason
=> PE_Accessibility_Check_Failed
));
448 Analyze_And_Resolve
(N
);
450 end Apply_Accessibility_Check
;
452 ---------------------------
453 -- Apply_Alignment_Check --
454 ---------------------------
456 procedure Apply_Alignment_Check
(E
: Entity_Id
; N
: Node_Id
) is
457 AC
: constant Node_Id
:= Address_Clause
(E
);
458 Typ
: constant Entity_Id
:= Etype
(E
);
462 Alignment_Required
: constant Boolean := Maximum_Alignment
> 1;
463 -- Constant to show whether target requires alignment checks
466 -- See if check needed. Note that we never need a check if the
467 -- maximum alignment is one, since the check will always succeed
470 or else not Check_Address_Alignment
(AC
)
471 or else not Alignment_Required
477 Expr
:= Expression
(AC
);
479 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
480 Expr
:= Expression
(Expr
);
482 elsif Nkind
(Expr
) = N_Function_Call
483 and then Is_Entity_Name
(Name
(Expr
))
484 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
486 Expr
:= First
(Parameter_Associations
(Expr
));
488 if Nkind
(Expr
) = N_Parameter_Association
then
489 Expr
:= Explicit_Actual_Parameter
(Expr
);
493 -- Here Expr is the address value. See if we know that the
494 -- value is unacceptable at compile time.
496 if Compile_Time_Known_Value
(Expr
)
497 and then (Known_Alignment
(E
) or else Known_Alignment
(Typ
))
500 AL
: Uint
:= Alignment
(Typ
);
503 -- The object alignment might be more restrictive than the
506 if Known_Alignment
(E
) then
510 if Expr_Value
(Expr
) mod AL
/= 0 then
512 Make_Raise_Program_Error
(Loc
,
513 Reason
=> PE_Misaligned_Address_Value
));
515 ("?specified address for& not " &
516 "consistent with alignment ('R'M 13.3(27))", Expr
, E
);
520 -- Here we do not know if the value is acceptable, generate
521 -- code to raise PE if alignment is inappropriate.
524 -- Skip generation of this code if we don't want elab code
526 if not Restriction_Active
(No_Elaboration_Code
) then
527 Insert_After_And_Analyze
(N
,
528 Make_Raise_Program_Error
(Loc
,
535 (RTE
(RE_Integer_Address
),
536 Duplicate_Subexpr_No_Checks
(Expr
)),
538 Make_Attribute_Reference
(Loc
,
539 Prefix
=> New_Occurrence_Of
(E
, Loc
),
540 Attribute_Name
=> Name_Alignment
)),
541 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
542 Reason
=> PE_Misaligned_Address_Value
),
543 Suppress
=> All_Checks
);
550 when RE_Not_Available
=>
552 end Apply_Alignment_Check
;
554 -------------------------------------
555 -- Apply_Arithmetic_Overflow_Check --
556 -------------------------------------
558 -- This routine is called only if the type is an integer type, and
559 -- a software arithmetic overflow check must be performed for op
560 -- (add, subtract, multiply). The check is performed only if
561 -- Software_Overflow_Checking is enabled and Do_Overflow_Check
562 -- is set. In this case we expand the operation into a more complex
563 -- sequence of tests that ensures that overflow is properly caught.
565 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
566 Loc
: constant Source_Ptr
:= Sloc
(N
);
567 Typ
: constant Entity_Id
:= Etype
(N
);
568 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
569 Siz
: constant Int
:= UI_To_Int
(Esize
(Rtyp
));
570 Dsiz
: constant Int
:= Siz
* 2;
577 -- Skip this if overflow checks are done in back end, or the overflow
578 -- flag is not set anyway, or we are not doing code expansion.
580 if Backend_Overflow_Checks_On_Target
581 or else not Do_Overflow_Check
(N
)
582 or else not Expander_Active
587 -- Otherwise, we generate the full general code for front end overflow
588 -- detection, which works by doing arithmetic in a larger type:
594 -- Typ (Checktyp (x) op Checktyp (y));
596 -- where Typ is the type of the original expression, and Checktyp is
597 -- an integer type of sufficient length to hold the largest possible
600 -- In the case where check type exceeds the size of Long_Long_Integer,
601 -- we use a different approach, expanding to:
603 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
605 -- where xxx is Add, Multiply or Subtract as appropriate
607 -- Find check type if one exists
609 if Dsiz
<= Standard_Integer_Size
then
610 Ctyp
:= Standard_Integer
;
612 elsif Dsiz
<= Standard_Long_Long_Integer_Size
then
613 Ctyp
:= Standard_Long_Long_Integer
;
615 -- No check type exists, use runtime call
618 if Nkind
(N
) = N_Op_Add
then
619 Cent
:= RE_Add_With_Ovflo_Check
;
621 elsif Nkind
(N
) = N_Op_Multiply
then
622 Cent
:= RE_Multiply_With_Ovflo_Check
;
625 pragma Assert
(Nkind
(N
) = N_Op_Subtract
);
626 Cent
:= RE_Subtract_With_Ovflo_Check
;
631 Make_Function_Call
(Loc
,
632 Name
=> New_Reference_To
(RTE
(Cent
), Loc
),
633 Parameter_Associations
=> New_List
(
634 OK_Convert_To
(RTE
(RE_Integer_64
), Left_Opnd
(N
)),
635 OK_Convert_To
(RTE
(RE_Integer_64
), Right_Opnd
(N
))))));
637 Analyze_And_Resolve
(N
, Typ
);
641 -- If we fall through, we have the case where we do the arithmetic in
642 -- the next higher type and get the check by conversion. In these cases
643 -- Ctyp is set to the type to be used as the check type.
645 Opnod
:= Relocate_Node
(N
);
647 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
650 Set_Etype
(Opnd
, Ctyp
);
651 Set_Analyzed
(Opnd
, True);
652 Set_Left_Opnd
(Opnod
, Opnd
);
654 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
657 Set_Etype
(Opnd
, Ctyp
);
658 Set_Analyzed
(Opnd
, True);
659 Set_Right_Opnd
(Opnod
, Opnd
);
661 -- The type of the operation changes to the base type of the check
662 -- type, and we reset the overflow check indication, since clearly
663 -- no overflow is possible now that we are using a double length
664 -- type. We also set the Analyzed flag to avoid a recursive attempt
665 -- to expand the node.
667 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
668 Set_Do_Overflow_Check
(Opnod
, False);
669 Set_Analyzed
(Opnod
, True);
671 -- Now build the outer conversion
673 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
675 Set_Etype
(Opnd
, Typ
);
677 -- In the discrete type case, we directly generate the range check
678 -- for the outer operand. This range check will implement the required
681 if Is_Discrete_Type
(Typ
) then
683 Generate_Range_Check
(Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
685 -- For other types, we enable overflow checking on the conversion,
686 -- after setting the node as analyzed to prevent recursive attempts
687 -- to expand the conversion node.
690 Set_Analyzed
(Opnd
, True);
691 Enable_Overflow_Check
(Opnd
);
696 when RE_Not_Available
=>
698 end Apply_Arithmetic_Overflow_Check
;
700 ----------------------------
701 -- Apply_Array_Size_Check --
702 ----------------------------
704 -- The situation is as follows. In GNAT 3 (GCC 2.x), the size in bits
705 -- is computed in 32 bits without an overflow check. That's a real
706 -- problem for Ada. So what we do in GNAT 3 is to approximate the
707 -- size of an array by manually multiplying the element size by the
708 -- number of elements, and comparing that against the allowed limits.
710 -- In GNAT 5, the size in byte is still computed in 32 bits without
711 -- an overflow check in the dynamic case, but the size in bits is
712 -- computed in 64 bits. We assume that's good enough, and we do not
713 -- bother to generate any front end test.
715 procedure Apply_Array_Size_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
716 Loc
: constant Source_Ptr
:= Sloc
(N
);
717 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
718 Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
730 Static
: Boolean := True;
731 -- Set false if any index subtye bound is non-static
733 Umark
: constant Uintp
.Save_Mark
:= Uintp
.Mark
;
734 -- We can throw away all the Uint computations here, since they are
735 -- done only to generate boolean test results.
738 -- Size to check against
740 function Is_Address_Or_Import
(Decl
: Node_Id
) return Boolean;
741 -- Determines if Decl is an address clause or Import/Interface pragma
742 -- that references the defining identifier of the current declaration.
744 --------------------------
745 -- Is_Address_Or_Import --
746 --------------------------
748 function Is_Address_Or_Import
(Decl
: Node_Id
) return Boolean is
750 if Nkind
(Decl
) = N_At_Clause
then
751 return Chars
(Identifier
(Decl
)) = Chars
(Ent
);
753 elsif Nkind
(Decl
) = N_Attribute_Definition_Clause
then
755 Chars
(Decl
) = Name_Address
757 Nkind
(Name
(Decl
)) = N_Identifier
759 Chars
(Name
(Decl
)) = Chars
(Ent
);
761 elsif Nkind
(Decl
) = N_Pragma
then
762 if (Chars
(Decl
) = Name_Import
764 Chars
(Decl
) = Name_Interface
)
765 and then Present
(Pragma_Argument_Associations
(Decl
))
768 F
: constant Node_Id
:=
769 First
(Pragma_Argument_Associations
(Decl
));
777 Nkind
(Expression
(Next
(F
))) = N_Identifier
779 Chars
(Expression
(Next
(F
))) = Chars
(Ent
);
789 end Is_Address_Or_Import
;
791 -- Start of processing for Apply_Array_Size_Check
794 -- Do size check on local arrays. We only need this in the GCC 2
795 -- case, since in GCC 3, we expect the back end to properly handle
796 -- things. This routine can be removed when we baseline GNAT 3.
798 if Opt
.GCC_Version
>= 3 then
802 -- No need for a check if not expanding
804 if not Expander_Active
then
808 -- No need for a check if checks are suppressed
810 if Storage_Checks_Suppressed
(Typ
) then
814 -- It is pointless to insert this check inside an init proc, because
815 -- that's too late, we have already built the object to be the right
816 -- size, and if it's too large, too bad!
818 if Inside_Init_Proc
then
822 -- Look head for pragma interface/import or address clause applying
823 -- to this entity. If found, we suppress the check entirely. For now
824 -- we only look ahead 20 declarations to stop this becoming too slow
825 -- Note that eventually this whole routine gets moved to gigi.
828 for Ctr
in 1 .. 20 loop
832 if Is_Address_Or_Import
(Decl
) then
837 -- First step is to calculate the maximum number of elements. For
838 -- this calculation, we use the actual size of the subtype if it is
839 -- static, and if a bound of a subtype is non-static, we go to the
840 -- bound of the base type.
843 Indx
:= First_Index
(Typ
);
844 while Present
(Indx
) loop
845 Xtyp
:= Etype
(Indx
);
846 Lo
:= Type_Low_Bound
(Xtyp
);
847 Hi
:= Type_High_Bound
(Xtyp
);
849 -- If any bound raises constraint error, we will never get this
850 -- far, so there is no need to generate any kind of check.
852 if Raises_Constraint_Error
(Lo
)
854 Raises_Constraint_Error
(Hi
)
856 Uintp
.Release
(Umark
);
860 -- Otherwise get bounds values
862 if Is_Static_Expression
(Lo
) then
863 Lob
:= Expr_Value
(Lo
);
865 Lob
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Xtyp
)));
869 if Is_Static_Expression
(Hi
) then
870 Hib
:= Expr_Value
(Hi
);
872 Hib
:= Expr_Value
(Type_High_Bound
(Base_Type
(Xtyp
)));
876 Siz
:= Siz
* UI_Max
(Hib
- Lob
+ 1, Uint_0
);
880 -- Compute the limit against which we want to check. For subprograms,
881 -- where the array will go on the stack, we use 8*2**24, which (in
882 -- bits) is the size of a 16 megabyte array.
884 if Is_Subprogram
(Scope
(Ent
)) then
885 Check_Siz
:= Uint_2
** 27;
887 Check_Siz
:= Uint_2
** 31;
890 -- If we have all static bounds and Siz is too large, then we know
891 -- we know we have a storage error right now, so generate message
893 if Static
and then Siz
>= Check_Siz
then
895 Make_Raise_Storage_Error
(Loc
,
896 Reason
=> SE_Object_Too_Large
));
897 Error_Msg_N
("?Storage_Error will be raised at run-time", N
);
898 Uintp
.Release
(Umark
);
902 -- Case of component size known at compile time. If the array
903 -- size is definitely in range, then we do not need a check.
905 if Known_Esize
(Ctyp
)
906 and then Siz
* Esize
(Ctyp
) < Check_Siz
908 Uintp
.Release
(Umark
);
912 -- Here if a dynamic check is required
914 -- What we do is to build an expression for the size of the array,
915 -- which is computed as the 'Size of the array component, times
916 -- the size of each dimension.
918 Uintp
.Release
(Umark
);
921 Make_Attribute_Reference
(Loc
,
922 Prefix
=> New_Occurrence_Of
(Ctyp
, Loc
),
923 Attribute_Name
=> Name_Size
);
925 Indx
:= First_Index
(Typ
);
926 for J
in 1 .. Number_Dimensions
(Typ
) loop
927 if Sloc
(Etype
(Indx
)) = Sloc
(N
) then
928 Ensure_Defined
(Etype
(Indx
), N
);
932 Make_Op_Multiply
(Loc
,
935 Make_Attribute_Reference
(Loc
,
936 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
937 Attribute_Name
=> Name_Length
,
938 Expressions
=> New_List
(
939 Make_Integer_Literal
(Loc
, J
))));
946 Make_Raise_Storage_Error
(Loc
,
951 Make_Integer_Literal
(Loc
,
952 Intval
=> Check_Siz
)),
953 Reason
=> SE_Object_Too_Large
);
955 Set_Size_Check_Code
(Defining_Identifier
(N
), Code
);
956 Insert_Action
(N
, Code
, Suppress
=> All_Checks
);
957 end Apply_Array_Size_Check
;
959 ----------------------------
960 -- Apply_Constraint_Check --
961 ----------------------------
963 procedure Apply_Constraint_Check
966 No_Sliding
: Boolean := False)
968 Desig_Typ
: Entity_Id
;
971 if Inside_A_Generic
then
974 elsif Is_Scalar_Type
(Typ
) then
975 Apply_Scalar_Range_Check
(N
, Typ
);
977 elsif Is_Array_Type
(Typ
) then
979 -- A useful optimization: an aggregate with only an others clause
980 -- always has the right bounds.
982 if Nkind
(N
) = N_Aggregate
983 and then No
(Expressions
(N
))
985 (First
(Choices
(First
(Component_Associations
(N
)))))
991 if Is_Constrained
(Typ
) then
992 Apply_Length_Check
(N
, Typ
);
995 Apply_Range_Check
(N
, Typ
);
998 Apply_Range_Check
(N
, Typ
);
1001 elsif (Is_Record_Type
(Typ
)
1002 or else Is_Private_Type
(Typ
))
1003 and then Has_Discriminants
(Base_Type
(Typ
))
1004 and then Is_Constrained
(Typ
)
1006 Apply_Discriminant_Check
(N
, Typ
);
1008 elsif Is_Access_Type
(Typ
) then
1010 Desig_Typ
:= Designated_Type
(Typ
);
1012 -- No checks necessary if expression statically null
1014 if Nkind
(N
) = N_Null
then
1017 -- No sliding possible on access to arrays
1019 elsif Is_Array_Type
(Desig_Typ
) then
1020 if Is_Constrained
(Desig_Typ
) then
1021 Apply_Length_Check
(N
, Typ
);
1024 Apply_Range_Check
(N
, Typ
);
1026 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
1027 and then Is_Constrained
(Desig_Typ
)
1029 Apply_Discriminant_Check
(N
, Typ
);
1032 if Can_Never_Be_Null
(Typ
)
1033 and then not Can_Never_Be_Null
(Etype
(N
))
1035 Install_Null_Excluding_Check
(N
);
1038 end Apply_Constraint_Check
;
1040 ------------------------------
1041 -- Apply_Discriminant_Check --
1042 ------------------------------
1044 procedure Apply_Discriminant_Check
1047 Lhs
: Node_Id
:= Empty
)
1049 Loc
: constant Source_Ptr
:= Sloc
(N
);
1050 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1051 S_Typ
: Entity_Id
:= Etype
(N
);
1055 function Is_Aliased_Unconstrained_Component
return Boolean;
1056 -- It is possible for an aliased component to have a nominal
1057 -- unconstrained subtype (through instantiation). If this is a
1058 -- discriminated component assigned in the expansion of an aggregate
1059 -- in an initialization, the check must be suppressed. This unusual
1060 -- situation requires a predicate of its own (see 7503-008).
1062 ----------------------------------------
1063 -- Is_Aliased_Unconstrained_Component --
1064 ----------------------------------------
1066 function Is_Aliased_Unconstrained_Component
return Boolean is
1071 if Nkind
(Lhs
) /= N_Selected_Component
then
1074 Comp
:= Entity
(Selector_Name
(Lhs
));
1075 Pref
:= Prefix
(Lhs
);
1078 if Ekind
(Comp
) /= E_Component
1079 or else not Is_Aliased
(Comp
)
1084 return not Comes_From_Source
(Pref
)
1085 and then In_Instance
1086 and then not Is_Constrained
(Etype
(Comp
));
1087 end Is_Aliased_Unconstrained_Component
;
1089 -- Start of processing for Apply_Discriminant_Check
1093 T_Typ
:= Designated_Type
(Typ
);
1098 -- Nothing to do if discriminant checks are suppressed or else no code
1099 -- is to be generated
1101 if not Expander_Active
1102 or else Discriminant_Checks_Suppressed
(T_Typ
)
1107 -- No discriminant checks necessary for an access when expression
1108 -- is statically Null. This is not only an optimization, this is
1109 -- fundamental because otherwise discriminant checks may be generated
1110 -- in init procs for types containing an access to a not-yet-frozen
1111 -- record, causing a deadly forward reference.
1113 -- Also, if the expression is of an access type whose designated
1114 -- type is incomplete, then the access value must be null and
1115 -- we suppress the check.
1117 if Nkind
(N
) = N_Null
then
1120 elsif Is_Access_Type
(S_Typ
) then
1121 S_Typ
:= Designated_Type
(S_Typ
);
1123 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1128 -- If an assignment target is present, then we need to generate
1129 -- the actual subtype if the target is a parameter or aliased
1130 -- object with an unconstrained nominal subtype.
1133 and then (Present
(Param_Entity
(Lhs
))
1134 or else (not Is_Constrained
(T_Typ
)
1135 and then Is_Aliased_View
(Lhs
)
1136 and then not Is_Aliased_Unconstrained_Component
))
1138 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1141 -- Nothing to do if the type is unconstrained (this is the case
1142 -- where the actual subtype in the RM sense of N is unconstrained
1143 -- and no check is required).
1145 if not Is_Constrained
(T_Typ
) then
1148 -- Ada 2005: nothing to do if the type is one for which there is a
1149 -- partial view that is constrained.
1151 elsif Ada_Version
>= Ada_05
1152 and then Has_Constrained_Partial_View
(Base_Type
(T_Typ
))
1157 -- Nothing to do if the type is an Unchecked_Union
1159 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
1163 -- Suppress checks if the subtypes are the same.
1164 -- the check must be preserved in an assignment to a formal, because
1165 -- the constraint is given by the actual.
1167 if Nkind
(Original_Node
(N
)) /= N_Allocator
1169 or else not Is_Entity_Name
(Lhs
)
1170 or else No
(Param_Entity
(Lhs
)))
1173 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1174 and then not Is_Aliased_View
(Lhs
)
1179 -- We can also eliminate checks on allocators with a subtype mark
1180 -- that coincides with the context type. The context type may be a
1181 -- subtype without a constraint (common case, a generic actual).
1183 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1184 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1187 Alloc_Typ
: constant Entity_Id
:=
1188 Entity
(Expression
(Original_Node
(N
)));
1191 if Alloc_Typ
= T_Typ
1192 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1193 and then Is_Entity_Name
(
1194 Subtype_Indication
(Parent
(T_Typ
)))
1195 and then Alloc_Typ
= Base_Type
(T_Typ
))
1203 -- See if we have a case where the types are both constrained, and
1204 -- all the constraints are constants. In this case, we can do the
1205 -- check successfully at compile time.
1207 -- We skip this check for the case where the node is a rewritten`
1208 -- allocator, because it already carries the context subtype, and
1209 -- extracting the discriminants from the aggregate is messy.
1211 if Is_Constrained
(S_Typ
)
1212 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1222 -- S_Typ may not have discriminants in the case where it is a
1223 -- private type completed by a default discriminated type. In
1224 -- that case, we need to get the constraints from the
1225 -- underlying_type. If the underlying type is unconstrained (i.e.
1226 -- has no default discriminants) no check is needed.
1228 if Has_Discriminants
(S_Typ
) then
1229 Discr
:= First_Discriminant
(S_Typ
);
1230 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1233 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1236 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1242 -- A further optimization: if T_Typ is derived from S_Typ
1243 -- without imposing a constraint, no check is needed.
1245 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1246 N_Full_Type_Declaration
1249 Type_Def
: constant Node_Id
:=
1251 (Original_Node
(Parent
(T_Typ
)));
1253 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1254 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1255 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1263 DconT
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
1265 while Present
(Discr
) loop
1266 ItemS
:= Node
(DconS
);
1267 ItemT
:= Node
(DconT
);
1270 not Is_OK_Static_Expression
(ItemS
)
1272 not Is_OK_Static_Expression
(ItemT
);
1274 if Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1275 if Do_Access
then -- needs run-time check.
1278 Apply_Compile_Time_Constraint_Error
1279 (N
, "incorrect value for discriminant&?",
1280 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1287 Next_Discriminant
(Discr
);
1296 -- Here we need a discriminant check. First build the expression
1297 -- for the comparisons of the discriminants:
1299 -- (n.disc1 /= typ.disc1) or else
1300 -- (n.disc2 /= typ.disc2) or else
1302 -- (n.discn /= typ.discn)
1304 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1306 -- If Lhs is set and is a parameter, then the condition is
1307 -- guarded by: lhs'constrained and then (condition built above)
1309 if Present
(Param_Entity
(Lhs
)) then
1313 Make_Attribute_Reference
(Loc
,
1314 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1315 Attribute_Name
=> Name_Constrained
),
1316 Right_Opnd
=> Cond
);
1320 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1324 Make_Raise_Constraint_Error
(Loc
,
1326 Reason
=> CE_Discriminant_Check_Failed
));
1327 end Apply_Discriminant_Check
;
1329 ------------------------
1330 -- Apply_Divide_Check --
1331 ------------------------
1333 procedure Apply_Divide_Check
(N
: Node_Id
) is
1334 Loc
: constant Source_Ptr
:= Sloc
(N
);
1335 Typ
: constant Entity_Id
:= Etype
(N
);
1336 Left
: constant Node_Id
:= Left_Opnd
(N
);
1337 Right
: constant Node_Id
:= Right_Opnd
(N
);
1349 and then not Backend_Divide_Checks_On_Target
1350 and then Check_Needed
(Right
, Division_Check
)
1352 Determine_Range
(Right
, ROK
, Rlo
, Rhi
);
1354 -- See if division by zero possible, and if so generate test. This
1355 -- part of the test is not controlled by the -gnato switch.
1357 if Do_Division_Check
(N
) then
1358 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1360 Make_Raise_Constraint_Error
(Loc
,
1363 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1364 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1365 Reason
=> CE_Divide_By_Zero
));
1369 -- Test for extremely annoying case of xxx'First divided by -1
1371 if Do_Overflow_Check
(N
) then
1372 if Nkind
(N
) = N_Op_Divide
1373 and then Is_Signed_Integer_Type
(Typ
)
1375 Determine_Range
(Left
, LOK
, Llo
, Lhi
);
1376 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1378 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1380 ((not LOK
) or else (Llo
= LLB
))
1383 Make_Raise_Constraint_Error
(Loc
,
1389 Duplicate_Subexpr_Move_Checks
(Left
),
1390 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1394 Duplicate_Subexpr
(Right
),
1396 Make_Integer_Literal
(Loc
, -1))),
1397 Reason
=> CE_Overflow_Check_Failed
));
1402 end Apply_Divide_Check
;
1404 ----------------------------------
1405 -- Apply_Float_Conversion_Check --
1406 ----------------------------------
1408 -- Let F and I be the source and target types of the conversion.
1409 -- The Ada standard specifies that a floating-point value X is rounded
1410 -- to the nearest integer, with halfway cases being rounded away from
1411 -- zero. The rounded value of X is checked against I'Range.
1413 -- The catch in the above paragraph is that there is no good way
1414 -- to know whether the round-to-integer operation resulted in
1415 -- overflow. A remedy is to perform a range check in the floating-point
1416 -- domain instead, however:
1417 -- (1) The bounds may not be known at compile time
1418 -- (2) The check must take into account possible rounding.
1419 -- (3) The range of type I may not be exactly representable in F.
1420 -- (4) The end-points I'First - 0.5 and I'Last + 0.5 may or may
1421 -- not be in range, depending on the sign of I'First and I'Last.
1422 -- (5) X may be a NaN, which will fail any comparison
1424 -- The following steps take care of these issues converting X:
1425 -- (1) If either I'First or I'Last is not known at compile time, use
1426 -- I'Base instead of I in the next three steps and perform a
1427 -- regular range check against I'Range after conversion.
1428 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1429 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1430 -- F'Machine (T) and let Lo_OK be (Lo >= I'First). In other words,
1431 -- take one of the closest floating-point numbers to T, and see if
1432 -- it is in range or not.
1433 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1434 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1435 -- F'Rounding (T) and let Hi_OK be (Hi <= I'Last).
1436 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1437 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1439 procedure Apply_Float_Conversion_Check
1441 Target_Typ
: Entity_Id
)
1443 LB
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1444 HB
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1445 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1446 Expr_Type
: constant Entity_Id
:= Base_Type
(Etype
(Ck_Node
));
1447 Target_Base
: constant Entity_Id
:= Implementation_Base_Type
1449 Max_Bound
: constant Uint
:= UI_Expon
1450 (Machine_Radix
(Expr_Type
),
1451 Machine_Mantissa
(Expr_Type
) - 1) - 1;
1452 -- Largest bound, so bound plus or minus half is a machine number of F
1455 Ilast
: Uint
; -- Bounds of integer type
1456 Lo
, Hi
: Ureal
; -- Bounds to check in floating-point domain
1458 Hi_OK
: Boolean; -- True iff Lo resp. Hi belongs to I'Range
1461 Hi_Chk
: Node_Id
; -- Expressions that are False iff check fails
1463 Reason
: RT_Exception_Code
;
1466 if not Compile_Time_Known_Value
(LB
)
1467 or not Compile_Time_Known_Value
(HB
)
1470 -- First check that the value falls in the range of the base
1471 -- type, to prevent overflow during conversion and then
1472 -- perform a regular range check against the (dynamic) bounds.
1474 Par
: constant Node_Id
:= Parent
(Ck_Node
);
1476 pragma Assert
(Target_Base
/= Target_Typ
);
1477 pragma Assert
(Nkind
(Par
) = N_Type_Conversion
);
1479 Temp
: constant Entity_Id
:=
1480 Make_Defining_Identifier
(Loc
,
1481 Chars
=> New_Internal_Name
('T'));
1484 Apply_Float_Conversion_Check
(Ck_Node
, Target_Base
);
1485 Set_Etype
(Temp
, Target_Base
);
1487 Insert_Action
(Parent
(Par
),
1488 Make_Object_Declaration
(Loc
,
1489 Defining_Identifier
=> Temp
,
1490 Object_Definition
=> New_Occurrence_Of
(Target_Typ
, Loc
),
1491 Expression
=> New_Copy_Tree
(Par
)),
1492 Suppress
=> All_Checks
);
1495 Make_Raise_Constraint_Error
(Loc
,
1498 Left_Opnd
=> New_Occurrence_Of
(Temp
, Loc
),
1499 Right_Opnd
=> New_Occurrence_Of
(Target_Typ
, Loc
)),
1500 Reason
=> CE_Range_Check_Failed
));
1501 Rewrite
(Par
, New_Occurrence_Of
(Temp
, Loc
));
1507 -- Get the bounds of the target type
1509 Ifirst
:= Expr_Value
(LB
);
1510 Ilast
:= Expr_Value
(HB
);
1512 -- Check against lower bound
1514 if abs (Ifirst
) < Max_Bound
then
1515 Lo
:= UR_From_Uint
(Ifirst
) - Ureal_Half
;
1516 Lo_OK
:= (Ifirst
> 0);
1518 Lo
:= Machine
(Expr_Type
, UR_From_Uint
(Ifirst
), Round_Even
, Ck_Node
);
1519 Lo_OK
:= (Lo
>= UR_From_Uint
(Ifirst
));
1524 -- Lo_Chk := (X >= Lo)
1526 Lo_Chk
:= Make_Op_Ge
(Loc
,
1527 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1528 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
1531 -- Lo_Chk := (X > Lo)
1533 Lo_Chk
:= Make_Op_Gt
(Loc
,
1534 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1535 Right_Opnd
=> Make_Real_Literal
(Loc
, Lo
));
1538 -- Check against higher bound
1540 if abs (Ilast
) < Max_Bound
then
1541 Hi
:= UR_From_Uint
(Ilast
) + Ureal_Half
;
1542 Hi_OK
:= (Ilast
< 0);
1544 Hi
:= Machine
(Expr_Type
, UR_From_Uint
(Ilast
), Round_Even
, Ck_Node
);
1545 Hi_OK
:= (Hi
<= UR_From_Uint
(Ilast
));
1550 -- Hi_Chk := (X <= Hi)
1552 Hi_Chk
:= Make_Op_Le
(Loc
,
1553 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1554 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
1557 -- Hi_Chk := (X < Hi)
1559 Hi_Chk
:= Make_Op_Lt
(Loc
,
1560 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
1561 Right_Opnd
=> Make_Real_Literal
(Loc
, Hi
));
1564 -- If the bounds of the target type are the same as those of the
1565 -- base type, the check is an overflow check as a range check is
1566 -- not performed in these cases.
1568 if Expr_Value
(Type_Low_Bound
(Target_Base
)) = Ifirst
1569 and then Expr_Value
(Type_High_Bound
(Target_Base
)) = Ilast
1571 Reason
:= CE_Overflow_Check_Failed
;
1573 Reason
:= CE_Range_Check_Failed
;
1576 -- Raise CE if either conditions does not hold
1578 Insert_Action
(Ck_Node
,
1579 Make_Raise_Constraint_Error
(Loc
,
1580 Condition
=> Make_Op_Not
(Loc
, Make_And_Then
(Loc
, Lo_Chk
, Hi_Chk
)),
1582 end Apply_Float_Conversion_Check
;
1584 ------------------------
1585 -- Apply_Length_Check --
1586 ------------------------
1588 procedure Apply_Length_Check
1590 Target_Typ
: Entity_Id
;
1591 Source_Typ
: Entity_Id
:= Empty
)
1594 Apply_Selected_Length_Checks
1595 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
1596 end Apply_Length_Check
;
1598 -----------------------
1599 -- Apply_Range_Check --
1600 -----------------------
1602 procedure Apply_Range_Check
1604 Target_Typ
: Entity_Id
;
1605 Source_Typ
: Entity_Id
:= Empty
)
1608 Apply_Selected_Range_Checks
1609 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
1610 end Apply_Range_Check
;
1612 ------------------------------
1613 -- Apply_Scalar_Range_Check --
1614 ------------------------------
1616 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check
1617 -- flag off if it is already set on.
1619 procedure Apply_Scalar_Range_Check
1621 Target_Typ
: Entity_Id
;
1622 Source_Typ
: Entity_Id
:= Empty
;
1623 Fixed_Int
: Boolean := False)
1625 Parnt
: constant Node_Id
:= Parent
(Expr
);
1627 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
1628 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
1631 Is_Subscr_Ref
: Boolean;
1632 -- Set true if Expr is a subscript
1634 Is_Unconstrained_Subscr_Ref
: Boolean;
1635 -- Set true if Expr is a subscript of an unconstrained array. In this
1636 -- case we do not attempt to do an analysis of the value against the
1637 -- range of the subscript, since we don't know the actual subtype.
1640 -- Set to True if Expr should be regarded as a real value
1641 -- even though the type of Expr might be discrete.
1643 procedure Bad_Value
;
1644 -- Procedure called if value is determined to be out of range
1650 procedure Bad_Value
is
1652 Apply_Compile_Time_Constraint_Error
1653 (Expr
, "value not in range of}?", CE_Range_Check_Failed
,
1658 -- Start of processing for Apply_Scalar_Range_Check
1661 if Inside_A_Generic
then
1664 -- Return if check obviously not needed. Note that we do not check
1665 -- for the expander being inactive, since this routine does not
1666 -- insert any code, but it does generate useful warnings sometimes,
1667 -- which we would like even if we are in semantics only mode.
1669 elsif Target_Typ
= Any_Type
1670 or else not Is_Scalar_Type
(Target_Typ
)
1671 or else Raises_Constraint_Error
(Expr
)
1676 -- Now, see if checks are suppressed
1679 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
1681 if Is_Subscr_Ref
then
1682 Arr
:= Prefix
(Parnt
);
1683 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
1686 if not Do_Range_Check
(Expr
) then
1688 -- Subscript reference. Check for Index_Checks suppressed
1690 if Is_Subscr_Ref
then
1692 -- Check array type and its base type
1694 if Index_Checks_Suppressed
(Arr_Typ
)
1695 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
1699 -- Check array itself if it is an entity name
1701 elsif Is_Entity_Name
(Arr
)
1702 and then Index_Checks_Suppressed
(Entity
(Arr
))
1706 -- Check expression itself if it is an entity name
1708 elsif Is_Entity_Name
(Expr
)
1709 and then Index_Checks_Suppressed
(Entity
(Expr
))
1714 -- All other cases, check for Range_Checks suppressed
1717 -- Check target type and its base type
1719 if Range_Checks_Suppressed
(Target_Typ
)
1720 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
1724 -- Check expression itself if it is an entity name
1726 elsif Is_Entity_Name
(Expr
)
1727 and then Range_Checks_Suppressed
(Entity
(Expr
))
1731 -- If Expr is part of an assignment statement, then check
1732 -- left side of assignment if it is an entity name.
1734 elsif Nkind
(Parnt
) = N_Assignment_Statement
1735 and then Is_Entity_Name
(Name
(Parnt
))
1736 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
1743 -- Do not set range checks if they are killed
1745 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
1746 and then Kill_Range_Check
(Expr
)
1751 -- Do not set range checks for any values from System.Scalar_Values
1752 -- since the whole idea of such values is to avoid checking them!
1754 if Is_Entity_Name
(Expr
)
1755 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
1760 -- Now see if we need a check
1762 if No
(Source_Typ
) then
1763 S_Typ
:= Etype
(Expr
);
1765 S_Typ
:= Source_Typ
;
1768 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
1772 Is_Unconstrained_Subscr_Ref
:=
1773 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
1775 -- Always do a range check if the source type includes infinities
1776 -- and the target type does not include infinities. We do not do
1777 -- this if range checks are killed.
1779 if Is_Floating_Point_Type
(S_Typ
)
1780 and then Has_Infinities
(S_Typ
)
1781 and then not Has_Infinities
(Target_Typ
)
1783 Enable_Range_Check
(Expr
);
1786 -- Return if we know expression is definitely in the range of
1787 -- the target type as determined by Determine_Range. Right now
1788 -- we only do this for discrete types, and not fixed-point or
1789 -- floating-point types.
1791 -- The additional less-precise tests below catch these cases
1793 -- Note: skip this if we are given a source_typ, since the point
1794 -- of supplying a Source_Typ is to stop us looking at the expression.
1795 -- could sharpen this test to be out parameters only ???
1797 if Is_Discrete_Type
(Target_Typ
)
1798 and then Is_Discrete_Type
(Etype
(Expr
))
1799 and then not Is_Unconstrained_Subscr_Ref
1800 and then No
(Source_Typ
)
1803 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1804 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1809 if Compile_Time_Known_Value
(Tlo
)
1810 and then Compile_Time_Known_Value
(Thi
)
1813 Lov
: constant Uint
:= Expr_Value
(Tlo
);
1814 Hiv
: constant Uint
:= Expr_Value
(Thi
);
1817 -- If range is null, we for sure have a constraint error
1818 -- (we don't even need to look at the value involved,
1819 -- since all possible values will raise CE).
1826 -- Otherwise determine range of value
1828 Determine_Range
(Expr
, OK
, Lo
, Hi
);
1832 -- If definitely in range, all OK
1834 if Lo
>= Lov
and then Hi
<= Hiv
then
1837 -- If definitely not in range, warn
1839 elsif Lov
> Hi
or else Hiv
< Lo
then
1843 -- Otherwise we don't know
1855 Is_Floating_Point_Type
(S_Typ
)
1856 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
1858 -- Check if we can determine at compile time whether Expr is in the
1859 -- range of the target type. Note that if S_Typ is within the bounds
1860 -- of Target_Typ then this must be the case. This check is meaningful
1861 -- only if this is not a conversion between integer and real types.
1863 if not Is_Unconstrained_Subscr_Ref
1865 Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
1867 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
1869 Is_In_Range
(Expr
, Target_Typ
, Fixed_Int
, Int_Real
))
1873 elsif Is_Out_Of_Range
(Expr
, Target_Typ
, Fixed_Int
, Int_Real
) then
1877 -- In the floating-point case, we only do range checks if the
1878 -- type is constrained. We definitely do NOT want range checks
1879 -- for unconstrained types, since we want to have infinities
1881 elsif Is_Floating_Point_Type
(S_Typ
) then
1882 if Is_Constrained
(S_Typ
) then
1883 Enable_Range_Check
(Expr
);
1886 -- For all other cases we enable a range check unconditionally
1889 Enable_Range_Check
(Expr
);
1892 end Apply_Scalar_Range_Check
;
1894 ----------------------------------
1895 -- Apply_Selected_Length_Checks --
1896 ----------------------------------
1898 procedure Apply_Selected_Length_Checks
1900 Target_Typ
: Entity_Id
;
1901 Source_Typ
: Entity_Id
;
1902 Do_Static
: Boolean)
1905 R_Result
: Check_Result
;
1908 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1909 Checks_On
: constant Boolean :=
1910 (not Index_Checks_Suppressed
(Target_Typ
))
1912 (not Length_Checks_Suppressed
(Target_Typ
));
1915 if not Expander_Active
then
1920 Selected_Length_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
1922 for J
in 1 .. 2 loop
1923 R_Cno
:= R_Result
(J
);
1924 exit when No
(R_Cno
);
1926 -- A length check may mention an Itype which is attached to a
1927 -- subsequent node. At the top level in a package this can cause
1928 -- an order-of-elaboration problem, so we make sure that the itype
1929 -- is referenced now.
1931 if Ekind
(Current_Scope
) = E_Package
1932 and then Is_Compilation_Unit
(Current_Scope
)
1934 Ensure_Defined
(Target_Typ
, Ck_Node
);
1936 if Present
(Source_Typ
) then
1937 Ensure_Defined
(Source_Typ
, Ck_Node
);
1939 elsif Is_Itype
(Etype
(Ck_Node
)) then
1940 Ensure_Defined
(Etype
(Ck_Node
), Ck_Node
);
1944 -- If the item is a conditional raise of constraint error,
1945 -- then have a look at what check is being performed and
1948 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
1949 and then Present
(Condition
(R_Cno
))
1951 Cond
:= Condition
(R_Cno
);
1953 if not Has_Dynamic_Length_Check
(Ck_Node
)
1956 Insert_Action
(Ck_Node
, R_Cno
);
1958 if not Do_Static
then
1959 Set_Has_Dynamic_Length_Check
(Ck_Node
);
1963 -- Output a warning if the condition is known to be True
1965 if Is_Entity_Name
(Cond
)
1966 and then Entity
(Cond
) = Standard_True
1968 Apply_Compile_Time_Constraint_Error
1969 (Ck_Node
, "wrong length for array of}?",
1970 CE_Length_Check_Failed
,
1974 -- If we were only doing a static check, or if checks are not
1975 -- on, then we want to delete the check, since it is not needed.
1976 -- We do this by replacing the if statement by a null statement
1978 elsif Do_Static
or else not Checks_On
then
1979 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
1983 Install_Static_Check
(R_Cno
, Loc
);
1988 end Apply_Selected_Length_Checks
;
1990 ---------------------------------
1991 -- Apply_Selected_Range_Checks --
1992 ---------------------------------
1994 procedure Apply_Selected_Range_Checks
1996 Target_Typ
: Entity_Id
;
1997 Source_Typ
: Entity_Id
;
1998 Do_Static
: Boolean)
2001 R_Result
: Check_Result
;
2004 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
2005 Checks_On
: constant Boolean :=
2006 (not Index_Checks_Suppressed
(Target_Typ
))
2008 (not Range_Checks_Suppressed
(Target_Typ
));
2011 if not Expander_Active
or else not Checks_On
then
2016 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
2018 for J
in 1 .. 2 loop
2020 R_Cno
:= R_Result
(J
);
2021 exit when No
(R_Cno
);
2023 -- If the item is a conditional raise of constraint error,
2024 -- then have a look at what check is being performed and
2027 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
2028 and then Present
(Condition
(R_Cno
))
2030 Cond
:= Condition
(R_Cno
);
2032 if not Has_Dynamic_Range_Check
(Ck_Node
) then
2033 Insert_Action
(Ck_Node
, R_Cno
);
2035 if not Do_Static
then
2036 Set_Has_Dynamic_Range_Check
(Ck_Node
);
2040 -- Output a warning if the condition is known to be True
2042 if Is_Entity_Name
(Cond
)
2043 and then Entity
(Cond
) = Standard_True
2045 -- Since an N_Range is technically not an expression, we
2046 -- have to set one of the bounds to C_E and then just flag
2047 -- the N_Range. The warning message will point to the
2048 -- lower bound and complain about a range, which seems OK.
2050 if Nkind
(Ck_Node
) = N_Range
then
2051 Apply_Compile_Time_Constraint_Error
2052 (Low_Bound
(Ck_Node
), "static range out of bounds of}?",
2053 CE_Range_Check_Failed
,
2057 Set_Raises_Constraint_Error
(Ck_Node
);
2060 Apply_Compile_Time_Constraint_Error
2061 (Ck_Node
, "static value out of range of}?",
2062 CE_Range_Check_Failed
,
2067 -- If we were only doing a static check, or if checks are not
2068 -- on, then we want to delete the check, since it is not needed.
2069 -- We do this by replacing the if statement by a null statement
2071 elsif Do_Static
or else not Checks_On
then
2072 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
2076 Install_Static_Check
(R_Cno
, Loc
);
2079 end Apply_Selected_Range_Checks
;
2081 -------------------------------
2082 -- Apply_Static_Length_Check --
2083 -------------------------------
2085 procedure Apply_Static_Length_Check
2087 Target_Typ
: Entity_Id
;
2088 Source_Typ
: Entity_Id
:= Empty
)
2091 Apply_Selected_Length_Checks
2092 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
2093 end Apply_Static_Length_Check
;
2095 -------------------------------------
2096 -- Apply_Subscript_Validity_Checks --
2097 -------------------------------------
2099 procedure Apply_Subscript_Validity_Checks
(Expr
: Node_Id
) is
2103 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
2105 -- Loop through subscripts
2107 Sub
:= First
(Expressions
(Expr
));
2108 while Present
(Sub
) loop
2110 -- Check one subscript. Note that we do not worry about
2111 -- enumeration type with holes, since we will convert the
2112 -- value to a Pos value for the subscript, and that convert
2113 -- will do the necessary validity check.
2115 Ensure_Valid
(Sub
, Holes_OK
=> True);
2117 -- Move to next subscript
2121 end Apply_Subscript_Validity_Checks
;
2123 ----------------------------------
2124 -- Apply_Type_Conversion_Checks --
2125 ----------------------------------
2127 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
2128 Target_Type
: constant Entity_Id
:= Etype
(N
);
2129 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
2130 Expr
: constant Node_Id
:= Expression
(N
);
2131 Expr_Type
: constant Entity_Id
:= Etype
(Expr
);
2134 if Inside_A_Generic
then
2137 -- Skip these checks if serious errors detected, there are some nasty
2138 -- situations of incomplete trees that blow things up.
2140 elsif Serious_Errors_Detected
> 0 then
2143 -- Scalar type conversions of the form Target_Type (Expr) require
2144 -- a range check if we cannot be sure that Expr is in the base type
2145 -- of Target_Typ and also that Expr is in the range of Target_Typ.
2146 -- These are not quite the same condition from an implementation
2147 -- point of view, but clearly the second includes the first.
2149 elsif Is_Scalar_Type
(Target_Type
) then
2151 Conv_OK
: constant Boolean := Conversion_OK
(N
);
2152 -- If the Conversion_OK flag on the type conversion is set
2153 -- and no floating point type is involved in the type conversion
2154 -- then fixed point values must be read as integral values.
2156 Float_To_Int
: constant Boolean :=
2157 Is_Floating_Point_Type
(Expr_Type
)
2158 and then Is_Integer_Type
(Target_Type
);
2161 if not Overflow_Checks_Suppressed
(Target_Base
)
2162 and then not In_Subrange_Of
(Expr_Type
, Target_Base
, Conv_OK
)
2163 and then not Float_To_Int
2165 Set_Do_Overflow_Check
(N
);
2168 if not Range_Checks_Suppressed
(Target_Type
)
2169 and then not Range_Checks_Suppressed
(Expr_Type
)
2171 if Float_To_Int
then
2172 Apply_Float_Conversion_Check
(Expr
, Target_Type
);
2174 Apply_Scalar_Range_Check
2175 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
2180 elsif Comes_From_Source
(N
)
2181 and then Is_Record_Type
(Target_Type
)
2182 and then Is_Derived_Type
(Target_Type
)
2183 and then not Is_Tagged_Type
(Target_Type
)
2184 and then not Is_Constrained
(Target_Type
)
2185 and then Present
(Stored_Constraint
(Target_Type
))
2187 -- An unconstrained derived type may have inherited discriminant
2188 -- Build an actual discriminant constraint list using the stored
2189 -- constraint, to verify that the expression of the parent type
2190 -- satisfies the constraints imposed by the (unconstrained!)
2191 -- derived type. This applies to value conversions, not to view
2192 -- conversions of tagged types.
2195 Loc
: constant Source_Ptr
:= Sloc
(N
);
2197 Constraint
: Elmt_Id
;
2198 Discr_Value
: Node_Id
;
2201 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
2202 Old_Constraints
: constant Elist_Id
:=
2203 Discriminant_Constraint
(Expr_Type
);
2206 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
2208 while Present
(Constraint
) loop
2209 Discr_Value
:= Node
(Constraint
);
2211 if Is_Entity_Name
(Discr_Value
)
2212 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
2214 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
2217 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
2219 -- Parent is constrained by new discriminant. Obtain
2220 -- Value of original discriminant in expression. If
2221 -- the new discriminant has been used to constrain more
2222 -- than one of the stored discriminants, this will
2223 -- provide the required consistency check.
2226 Make_Selected_Component
(Loc
,
2228 Duplicate_Subexpr_No_Checks
2229 (Expr
, Name_Req
=> True),
2231 Make_Identifier
(Loc
, Chars
(Discr
))),
2235 -- Discriminant of more remote ancestor ???
2240 -- Derived type definition has an explicit value for
2241 -- this stored discriminant.
2245 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
2249 Next_Elmt
(Constraint
);
2252 -- Use the unconstrained expression type to retrieve the
2253 -- discriminants of the parent, and apply momentarily the
2254 -- discriminant constraint synthesized above.
2256 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
2257 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
2258 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
2261 Make_Raise_Constraint_Error
(Loc
,
2263 Reason
=> CE_Discriminant_Check_Failed
));
2266 -- For arrays, conversions are applied during expansion, to take
2267 -- into accounts changes of representation. The checks become range
2268 -- checks on the base type or length checks on the subtype, depending
2269 -- on whether the target type is unconstrained or constrained.
2274 end Apply_Type_Conversion_Checks
;
2276 ----------------------------------------------
2277 -- Apply_Universal_Integer_Attribute_Checks --
2278 ----------------------------------------------
2280 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
2281 Loc
: constant Source_Ptr
:= Sloc
(N
);
2282 Typ
: constant Entity_Id
:= Etype
(N
);
2285 if Inside_A_Generic
then
2288 -- Nothing to do if checks are suppressed
2290 elsif Range_Checks_Suppressed
(Typ
)
2291 and then Overflow_Checks_Suppressed
(Typ
)
2295 -- Nothing to do if the attribute does not come from source. The
2296 -- internal attributes we generate of this type do not need checks,
2297 -- and furthermore the attempt to check them causes some circular
2298 -- elaboration orders when dealing with packed types.
2300 elsif not Comes_From_Source
(N
) then
2303 -- If the prefix is a selected component that depends on a discriminant
2304 -- the check may improperly expose a discriminant instead of using
2305 -- the bounds of the object itself. Set the type of the attribute to
2306 -- the base type of the context, so that a check will be imposed when
2307 -- needed (e.g. if the node appears as an index).
2309 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
2310 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
2311 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
2313 Set_Etype
(N
, Base_Type
(Typ
));
2315 -- Otherwise, replace the attribute node with a type conversion
2316 -- node whose expression is the attribute, retyped to universal
2317 -- integer, and whose subtype mark is the target type. The call
2318 -- to analyze this conversion will set range and overflow checks
2319 -- as required for proper detection of an out of range value.
2322 Set_Etype
(N
, Universal_Integer
);
2323 Set_Analyzed
(N
, True);
2326 Make_Type_Conversion
(Loc
,
2327 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
2328 Expression
=> Relocate_Node
(N
)));
2330 Analyze_And_Resolve
(N
, Typ
);
2334 end Apply_Universal_Integer_Attribute_Checks
;
2336 -------------------------------
2337 -- Build_Discriminant_Checks --
2338 -------------------------------
2340 function Build_Discriminant_Checks
2342 T_Typ
: Entity_Id
) return Node_Id
2344 Loc
: constant Source_Ptr
:= Sloc
(N
);
2347 Disc_Ent
: Entity_Id
;
2351 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
;
2353 ----------------------------------
2354 -- Aggregate_Discriminant_Value --
2355 ----------------------------------
2357 function Aggregate_Discriminant_Val
(Disc
: Entity_Id
) return Node_Id
is
2361 -- The aggregate has been normalized with named associations. We
2362 -- use the Chars field to locate the discriminant to take into
2363 -- account discriminants in derived types, which carry the same
2364 -- name as those in the parent.
2366 Assoc
:= First
(Component_Associations
(N
));
2367 while Present
(Assoc
) loop
2368 if Chars
(First
(Choices
(Assoc
))) = Chars
(Disc
) then
2369 return Expression
(Assoc
);
2375 -- Discriminant must have been found in the loop above
2377 raise Program_Error
;
2378 end Aggregate_Discriminant_Val
;
2380 -- Start of processing for Build_Discriminant_Checks
2383 -- Loop through discriminants evolving the condition
2386 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
2388 -- For a fully private type, use the discriminants of the parent type
2390 if Is_Private_Type
(T_Typ
)
2391 and then No
(Full_View
(T_Typ
))
2393 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
2395 Disc_Ent
:= First_Discriminant
(T_Typ
);
2398 while Present
(Disc
) loop
2399 Dval
:= Node
(Disc
);
2401 if Nkind
(Dval
) = N_Identifier
2402 and then Ekind
(Entity
(Dval
)) = E_Discriminant
2404 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
2406 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
2409 -- If we have an Unchecked_Union node, we can infer the discriminants
2412 if Is_Unchecked_Union
(Base_Type
(T_Typ
)) then
2414 Get_Discriminant_Value
(
2415 First_Discriminant
(T_Typ
),
2417 Stored_Constraint
(T_Typ
)));
2419 elsif Nkind
(N
) = N_Aggregate
then
2421 Duplicate_Subexpr_No_Checks
2422 (Aggregate_Discriminant_Val
(Disc_Ent
));
2426 Make_Selected_Component
(Loc
,
2428 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
2430 Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
2432 Set_Is_In_Discriminant_Check
(Dref
);
2435 Evolve_Or_Else
(Cond
,
2438 Right_Opnd
=> Dval
));
2441 Next_Discriminant
(Disc_Ent
);
2445 end Build_Discriminant_Checks
;
2451 function Check_Needed
(Nod
: Node_Id
; Check
: Check_Type
) return Boolean is
2459 -- Always check if not simple entity
2461 if Nkind
(Nod
) not in N_Has_Entity
2462 or else not Comes_From_Source
(Nod
)
2467 -- Look up tree for short circuit
2474 if K
not in N_Subexpr
then
2477 -- Or/Or Else case, left operand must be equality test
2479 elsif K
= N_Op_Or
or else K
= N_Or_Else
then
2480 exit when N
= Right_Opnd
(P
)
2481 and then Nkind
(Left_Opnd
(P
)) = N_Op_Eq
;
2483 -- And/And then case, left operand must be inequality test
2485 elsif K
= N_Op_And
or else K
= N_And_Then
then
2486 exit when N
= Right_Opnd
(P
)
2487 and then Nkind
(Left_Opnd
(P
)) = N_Op_Ne
;
2493 -- If we fall through the loop, then we have a conditional with an
2494 -- appropriate test as its left operand. So test further.
2498 if Nkind
(L
) = N_Op_Not
then
2499 L
:= Right_Opnd
(L
);
2502 R
:= Right_Opnd
(L
);
2505 -- Left operand of test must match original variable
2507 if Nkind
(L
) not in N_Has_Entity
2508 or else Entity
(L
) /= Entity
(Nod
)
2513 -- Right operand of test mus be key value (zero or null)
2516 when Access_Check
=>
2517 if Nkind
(R
) /= N_Null
then
2521 when Division_Check
=>
2522 if not Compile_Time_Known_Value
(R
)
2523 or else Expr_Value
(R
) /= Uint_0
2529 -- Here we have the optimizable case, warn if not short-circuited
2531 if K
= N_Op_And
or else K
= N_Op_Or
then
2533 when Access_Check
=>
2535 ("Constraint_Error may be raised (access check)?",
2537 when Division_Check
=>
2539 ("Constraint_Error may be raised (zero divide)?",
2543 if K
= N_Op_And
then
2544 Error_Msg_N
("use `AND THEN` instead of AND?", P
);
2546 Error_Msg_N
("use `OR ELSE` instead of OR?", P
);
2549 -- If not short-circuited, we need the ckeck
2553 -- If short-circuited, we can omit the check
2560 -----------------------------------
2561 -- Check_Valid_Lvalue_Subscripts --
2562 -----------------------------------
2564 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
2566 -- Skip this if range checks are suppressed
2568 if Range_Checks_Suppressed
(Etype
(Expr
)) then
2571 -- Only do this check for expressions that come from source. We
2572 -- assume that expander generated assignments explicitly include
2573 -- any necessary checks. Note that this is not just an optimization,
2574 -- it avoids infinite recursions!
2576 elsif not Comes_From_Source
(Expr
) then
2579 -- For a selected component, check the prefix
2581 elsif Nkind
(Expr
) = N_Selected_Component
then
2582 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
2585 -- Case of indexed component
2587 elsif Nkind
(Expr
) = N_Indexed_Component
then
2588 Apply_Subscript_Validity_Checks
(Expr
);
2590 -- Prefix may itself be or contain an indexed component, and
2591 -- these subscripts need checking as well
2593 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
2595 end Check_Valid_Lvalue_Subscripts
;
2597 ----------------------------------
2598 -- Null_Exclusion_Static_Checks --
2599 ----------------------------------
2601 procedure Null_Exclusion_Static_Checks
(N
: Node_Id
) is
2602 K
: constant Node_Kind
:= Nkind
(N
);
2604 Related_Nod
: Node_Id
;
2605 Has_Null_Exclusion
: Boolean := False;
2608 pragma Assert
(K
= N_Parameter_Specification
2609 or else K
= N_Object_Declaration
2610 or else K
= N_Discriminant_Specification
2611 or else K
= N_Component_Declaration
);
2613 Typ
:= Etype
(Defining_Identifier
(N
));
2615 pragma Assert
(Is_Access_Type
(Typ
)
2616 or else (K
= N_Object_Declaration
and then Is_Array_Type
(Typ
)));
2619 when N_Parameter_Specification
=>
2620 Related_Nod
:= Parameter_Type
(N
);
2621 Has_Null_Exclusion
:= Null_Exclusion_Present
(N
);
2623 when N_Object_Declaration
=>
2624 Related_Nod
:= Object_Definition
(N
);
2625 Has_Null_Exclusion
:= Null_Exclusion_Present
(N
);
2627 when N_Discriminant_Specification
=>
2628 Related_Nod
:= Discriminant_Type
(N
);
2629 Has_Null_Exclusion
:= Null_Exclusion_Present
(N
);
2631 when N_Component_Declaration
=>
2632 if Present
(Access_Definition
(Component_Definition
(N
))) then
2633 Related_Nod
:= Component_Definition
(N
);
2634 Has_Null_Exclusion
:=
2635 Null_Exclusion_Present
2636 (Access_Definition
(Component_Definition
(N
)));
2639 Subtype_Indication
(Component_Definition
(N
));
2640 Has_Null_Exclusion
:=
2641 Null_Exclusion_Present
(Component_Definition
(N
));
2645 raise Program_Error
;
2648 -- Enforce legality rule 3.10 (14/1): A null_exclusion is only allowed
2649 -- of the access subtype does not exclude null.
2651 if Has_Null_Exclusion
2652 and then Can_Never_Be_Null
(Typ
)
2654 -- No need to check itypes that have the null-excluding attribute
2655 -- because they were checked at their point of creation
2657 and then not Is_Itype
(Typ
)
2660 ("(Ada 2005) already a null-excluding type", Related_Nod
);
2663 -- Check that null-excluding objects are always initialized
2665 if K
= N_Object_Declaration
2666 and then No
(Expression
(N
))
2668 -- Add a an expression that assignates null. This node is needed
2669 -- by Apply_Compile_Time_Constraint_Error, that will replace this
2670 -- node by a Constraint_Error node.
2672 Set_Expression
(N
, Make_Null
(Sloc
(N
)));
2673 Set_Etype
(Expression
(N
), Etype
(Defining_Identifier
(N
)));
2675 Apply_Compile_Time_Constraint_Error
2676 (N
=> Expression
(N
),
2677 Msg
=> "(Ada 2005) null-excluding objects must be initialized?",
2678 Reason
=> CE_Null_Not_Allowed
);
2681 -- Check that the null value is not used as a single expression to
2682 -- assignate a value to a null-excluding component, formal or object;
2683 -- otherwise generate a warning message at the sloc of Related_Nod and
2684 -- replace Expression (N) by an N_Contraint_Error node.
2687 Expr
: constant Node_Id
:= Expression
(N
);
2691 and then Nkind
(Expr
) = N_Null
2694 when N_Discriminant_Specification |
2695 N_Component_Declaration
=>
2696 Apply_Compile_Time_Constraint_Error
2698 Msg
=> "(Ada 2005) NULL not allowed in"
2699 & " null-excluding components?",
2700 Reason
=> CE_Null_Not_Allowed
);
2702 when N_Parameter_Specification
=>
2703 Apply_Compile_Time_Constraint_Error
2705 Msg
=> "(Ada 2005) NULL not allowed in"
2706 & " null-excluding formals?",
2707 Reason
=> CE_Null_Not_Allowed
);
2709 when N_Object_Declaration
=>
2710 Apply_Compile_Time_Constraint_Error
2712 Msg
=> "(Ada 2005) NULL not allowed in"
2713 & " null-excluding objects?",
2714 Reason
=> CE_Null_Not_Allowed
);
2721 end Null_Exclusion_Static_Checks
;
2723 ----------------------------------
2724 -- Conditional_Statements_Begin --
2725 ----------------------------------
2727 procedure Conditional_Statements_Begin
is
2729 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
2731 -- If stack overflows, kill all checks, that way we know to
2732 -- simply reset the number of saved checks to zero on return.
2733 -- This should never occur in practice.
2735 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
2738 -- In the normal case, we just make a new stack entry saving
2739 -- the current number of saved checks for a later restore.
2742 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
2744 if Debug_Flag_CC
then
2745 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
2749 end Conditional_Statements_Begin
;
2751 --------------------------------
2752 -- Conditional_Statements_End --
2753 --------------------------------
2755 procedure Conditional_Statements_End
is
2757 pragma Assert
(Saved_Checks_TOS
> 0);
2759 -- If the saved checks stack overflowed, then we killed all
2760 -- checks, so setting the number of saved checks back to
2761 -- zero is correct. This should never occur in practice.
2763 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
2764 Num_Saved_Checks
:= 0;
2766 -- In the normal case, restore the number of saved checks
2767 -- from the top stack entry.
2770 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
2771 if Debug_Flag_CC
then
2772 w
("Conditional_Statements_End: Num_Saved_Checks = ",
2777 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
2778 end Conditional_Statements_End
;
2780 ---------------------
2781 -- Determine_Range --
2782 ---------------------
2784 Cache_Size
: constant := 2 ** 10;
2785 type Cache_Index
is range 0 .. Cache_Size
- 1;
2786 -- Determine size of below cache (power of 2 is more efficient!)
2788 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
2789 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
2790 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
2791 -- The above arrays are used to implement a small direct cache
2792 -- for Determine_Range calls. Because of the way Determine_Range
2793 -- recursively traces subexpressions, and because overflow checking
2794 -- calls the routine on the way up the tree, a quadratic behavior
2795 -- can otherwise be encountered in large expressions. The cache
2796 -- entry for node N is stored in the (N mod Cache_Size) entry, and
2797 -- can be validated by checking the actual node value stored there.
2799 procedure Determine_Range
2805 Typ
: constant Entity_Id
:= Etype
(N
);
2809 -- Lo and Hi bounds of left operand
2813 -- Lo and Hi bounds of right (or only) operand
2816 -- Temp variable used to hold a bound node
2819 -- High bound of base type of expression
2823 -- Refined values for low and high bounds, after tightening
2826 -- Used in lower level calls to indicate if call succeeded
2828 Cindex
: Cache_Index
;
2829 -- Used to search cache
2831 function OK_Operands
return Boolean;
2832 -- Used for binary operators. Determines the ranges of the left and
2833 -- right operands, and if they are both OK, returns True, and puts
2834 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left
2840 function OK_Operands
return Boolean is
2842 Determine_Range
(Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
);
2848 Determine_Range
(Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
);
2852 -- Start of processing for Determine_Range
2855 -- Prevent junk warnings by initializing range variables
2862 -- If the type is not discrete, or is undefined, then we can't
2863 -- do anything about determining the range.
2865 if No
(Typ
) or else not Is_Discrete_Type
(Typ
)
2866 or else Error_Posted
(N
)
2872 -- For all other cases, we can determine the range
2876 -- If value is compile time known, then the possible range is the
2877 -- one value that we know this expression definitely has!
2879 if Compile_Time_Known_Value
(N
) then
2880 Lo
:= Expr_Value
(N
);
2885 -- Return if already in the cache
2887 Cindex
:= Cache_Index
(N
mod Cache_Size
);
2889 if Determine_Range_Cache_N
(Cindex
) = N
then
2890 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
2891 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
2895 -- Otherwise, start by finding the bounds of the type of the
2896 -- expression, the value cannot be outside this range (if it
2897 -- is, then we have an overflow situation, which is a separate
2898 -- check, we are talking here only about the expression value).
2900 -- We use the actual bound unless it is dynamic, in which case
2901 -- use the corresponding base type bound if possible. If we can't
2902 -- get a bound then we figure we can't determine the range (a
2903 -- peculiar case, that perhaps cannot happen, but there is no
2904 -- point in bombing in this optimization circuit.
2906 -- First the low bound
2908 Bound
:= Type_Low_Bound
(Typ
);
2910 if Compile_Time_Known_Value
(Bound
) then
2911 Lo
:= Expr_Value
(Bound
);
2913 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Base_Type
(Typ
))) then
2914 Lo
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
2921 -- Now the high bound
2923 Bound
:= Type_High_Bound
(Typ
);
2925 -- We need the high bound of the base type later on, and this should
2926 -- always be compile time known. Again, it is not clear that this
2927 -- can ever be false, but no point in bombing.
2929 if Compile_Time_Known_Value
(Type_High_Bound
(Base_Type
(Typ
))) then
2930 Hbound
:= Expr_Value
(Type_High_Bound
(Base_Type
(Typ
)));
2938 -- If we have a static subtype, then that may have a tighter bound
2939 -- so use the upper bound of the subtype instead in this case.
2941 if Compile_Time_Known_Value
(Bound
) then
2942 Hi
:= Expr_Value
(Bound
);
2945 -- We may be able to refine this value in certain situations. If
2946 -- refinement is possible, then Lor and Hir are set to possibly
2947 -- tighter bounds, and OK1 is set to True.
2951 -- For unary plus, result is limited by range of operand
2954 Determine_Range
(Right_Opnd
(N
), OK1
, Lor
, Hir
);
2956 -- For unary minus, determine range of operand, and negate it
2959 Determine_Range
(Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
);
2966 -- For binary addition, get range of each operand and do the
2967 -- addition to get the result range.
2971 Lor
:= Lo_Left
+ Lo_Right
;
2972 Hir
:= Hi_Left
+ Hi_Right
;
2975 -- Division is tricky. The only case we consider is where the
2976 -- right operand is a positive constant, and in this case we
2977 -- simply divide the bounds of the left operand
2981 if Lo_Right
= Hi_Right
2982 and then Lo_Right
> 0
2984 Lor
:= Lo_Left
/ Lo_Right
;
2985 Hir
:= Hi_Left
/ Lo_Right
;
2992 -- For binary subtraction, get range of each operand and do
2993 -- the worst case subtraction to get the result range.
2995 when N_Op_Subtract
=>
2997 Lor
:= Lo_Left
- Hi_Right
;
2998 Hir
:= Hi_Left
- Lo_Right
;
3001 -- For MOD, if right operand is a positive constant, then
3002 -- result must be in the allowable range of mod results.
3006 if Lo_Right
= Hi_Right
3007 and then Lo_Right
/= 0
3009 if Lo_Right
> 0 then
3011 Hir
:= Lo_Right
- 1;
3013 else -- Lo_Right < 0
3014 Lor
:= Lo_Right
+ 1;
3023 -- For REM, if right operand is a positive constant, then
3024 -- result must be in the allowable range of mod results.
3028 if Lo_Right
= Hi_Right
3029 and then Lo_Right
/= 0
3032 Dval
: constant Uint
:= (abs Lo_Right
) - 1;
3035 -- The sign of the result depends on the sign of the
3036 -- dividend (but not on the sign of the divisor, hence
3037 -- the abs operation above).
3057 -- Attribute reference cases
3059 when N_Attribute_Reference
=>
3060 case Attribute_Name
(N
) is
3062 -- For Pos/Val attributes, we can refine the range using the
3063 -- possible range of values of the attribute expression
3065 when Name_Pos | Name_Val
=>
3066 Determine_Range
(First
(Expressions
(N
)), OK1
, Lor
, Hir
);
3068 -- For Length attribute, use the bounds of the corresponding
3069 -- index type to refine the range.
3073 Atyp
: Entity_Id
:= Etype
(Prefix
(N
));
3081 if Is_Access_Type
(Atyp
) then
3082 Atyp
:= Designated_Type
(Atyp
);
3085 -- For string literal, we know exact value
3087 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
3089 Lo
:= String_Literal_Length
(Atyp
);
3090 Hi
:= String_Literal_Length
(Atyp
);
3094 -- Otherwise check for expression given
3096 if No
(Expressions
(N
)) then
3100 UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
3103 Indx
:= First_Index
(Atyp
);
3104 for J
in 2 .. Inum
loop
3105 Indx
:= Next_Index
(Indx
);
3109 (Type_Low_Bound
(Etype
(Indx
)), OK1
, LL
, LU
);
3113 (Type_High_Bound
(Etype
(Indx
)), OK1
, UL
, UU
);
3117 -- The maximum value for Length is the biggest
3118 -- possible gap between the values of the bounds.
3119 -- But of course, this value cannot be negative.
3121 Hir
:= UI_Max
(Uint_0
, UU
- LL
);
3123 -- For constrained arrays, the minimum value for
3124 -- Length is taken from the actual value of the
3125 -- bounds, since the index will be exactly of
3128 if Is_Constrained
(Atyp
) then
3129 Lor
:= UI_Max
(Uint_0
, UL
- LU
);
3131 -- For an unconstrained array, the minimum value
3132 -- for length is always zero.
3141 -- No special handling for other attributes
3142 -- Probably more opportunities exist here ???
3149 -- For type conversion from one discrete type to another, we
3150 -- can refine the range using the converted value.
3152 when N_Type_Conversion
=>
3153 Determine_Range
(Expression
(N
), OK1
, Lor
, Hir
);
3155 -- Nothing special to do for all other expression kinds
3163 -- At this stage, if OK1 is true, then we know that the actual
3164 -- result of the computed expression is in the range Lor .. Hir.
3165 -- We can use this to restrict the possible range of results.
3169 -- If the refined value of the low bound is greater than the
3170 -- type high bound, then reset it to the more restrictive
3171 -- value. However, we do NOT do this for the case of a modular
3172 -- type where the possible upper bound on the value is above the
3173 -- base type high bound, because that means the result could wrap.
3176 and then not (Is_Modular_Integer_Type
(Typ
)
3177 and then Hir
> Hbound
)
3182 -- Similarly, if the refined value of the high bound is less
3183 -- than the value so far, then reset it to the more restrictive
3184 -- value. Again, we do not do this if the refined low bound is
3185 -- negative for a modular type, since this would wrap.
3188 and then not (Is_Modular_Integer_Type
(Typ
)
3189 and then Lor
< Uint_0
)
3195 -- Set cache entry for future call and we are all done
3197 Determine_Range_Cache_N
(Cindex
) := N
;
3198 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
3199 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
3202 -- If any exception occurs, it means that we have some bug in the compiler
3203 -- possibly triggered by a previous error, or by some unforseen peculiar
3204 -- occurrence. However, this is only an optimization attempt, so there is
3205 -- really no point in crashing the compiler. Instead we just decide, too
3206 -- bad, we can't figure out a range in this case after all.
3211 -- Debug flag K disables this behavior (useful for debugging)
3213 if Debug_Flag_K
then
3221 end Determine_Range
;
3223 ------------------------------------
3224 -- Discriminant_Checks_Suppressed --
3225 ------------------------------------
3227 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
3230 if Is_Unchecked_Union
(E
) then
3232 elsif Checks_May_Be_Suppressed
(E
) then
3233 return Is_Check_Suppressed
(E
, Discriminant_Check
);
3237 return Scope_Suppress
(Discriminant_Check
);
3238 end Discriminant_Checks_Suppressed
;
3240 --------------------------------
3241 -- Division_Checks_Suppressed --
3242 --------------------------------
3244 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
3246 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
3247 return Is_Check_Suppressed
(E
, Division_Check
);
3249 return Scope_Suppress
(Division_Check
);
3251 end Division_Checks_Suppressed
;
3253 -----------------------------------
3254 -- Elaboration_Checks_Suppressed --
3255 -----------------------------------
3257 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
3259 -- The complication in this routine is that if we are in the dynamic
3260 -- model of elaboration, we also check All_Checks, since All_Checks
3261 -- does not set Elaboration_Check explicitly.
3264 if Kill_Elaboration_Checks
(E
) then
3267 elsif Checks_May_Be_Suppressed
(E
) then
3268 if Is_Check_Suppressed
(E
, Elaboration_Check
) then
3270 elsif Dynamic_Elaboration_Checks
then
3271 return Is_Check_Suppressed
(E
, All_Checks
);
3278 if Scope_Suppress
(Elaboration_Check
) then
3280 elsif Dynamic_Elaboration_Checks
then
3281 return Scope_Suppress
(All_Checks
);
3285 end Elaboration_Checks_Suppressed
;
3287 ---------------------------
3288 -- Enable_Overflow_Check --
3289 ---------------------------
3291 procedure Enable_Overflow_Check
(N
: Node_Id
) is
3292 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
3301 if Debug_Flag_CC
then
3302 w
("Enable_Overflow_Check for node ", Int
(N
));
3303 Write_Str
(" Source location = ");
3308 -- Nothing to do if the range of the result is known OK. We skip
3309 -- this for conversions, since the caller already did the check,
3310 -- and in any case the condition for deleting the check for a
3311 -- type conversion is different in any case.
3313 if Nkind
(N
) /= N_Type_Conversion
then
3314 Determine_Range
(N
, OK
, Lo
, Hi
);
3316 -- Note in the test below that we assume that if a bound of the
3317 -- range is equal to that of the type. That's not quite accurate
3318 -- but we do this for the following reasons:
3320 -- a) The way that Determine_Range works, it will typically report
3321 -- the bounds of the value as being equal to the bounds of the
3322 -- type, because it either can't tell anything more precise, or
3323 -- does not think it is worth the effort to be more precise.
3325 -- b) It is very unusual to have a situation in which this would
3326 -- generate an unnecessary overflow check (an example would be
3327 -- a subtype with a range 0 .. Integer'Last - 1 to which the
3328 -- literal value one is added.
3330 -- c) The alternative is a lot of special casing in this routine
3331 -- which would partially duplicate Determine_Range processing.
3334 and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
3335 and then Hi
< Expr_Value
(Type_High_Bound
(Typ
))
3337 if Debug_Flag_CC
then
3338 w
("No overflow check required");
3345 -- If not in optimizing mode, set flag and we are done. We are also
3346 -- done (and just set the flag) if the type is not a discrete type,
3347 -- since it is not worth the effort to eliminate checks for other
3348 -- than discrete types. In addition, we take this same path if we
3349 -- have stored the maximum number of checks possible already (a
3350 -- very unlikely situation, but we do not want to blow up!)
3352 if Optimization_Level
= 0
3353 or else not Is_Discrete_Type
(Etype
(N
))
3354 or else Num_Saved_Checks
= Saved_Checks
'Last
3356 Set_Do_Overflow_Check
(N
, True);
3358 if Debug_Flag_CC
then
3359 w
("Optimization off");
3365 -- Otherwise evaluate and check the expression
3370 Target_Type
=> Empty
,
3376 if Debug_Flag_CC
then
3377 w
("Called Find_Check");
3381 w
(" Check_Num = ", Chk
);
3382 w
(" Ent = ", Int
(Ent
));
3383 Write_Str
(" Ofs = ");
3388 -- If check is not of form to optimize, then set flag and we are done
3391 Set_Do_Overflow_Check
(N
, True);
3395 -- If check is already performed, then return without setting flag
3398 if Debug_Flag_CC
then
3399 w
("Check suppressed!");
3405 -- Here we will make a new entry for the new check
3407 Set_Do_Overflow_Check
(N
, True);
3408 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
3409 Saved_Checks
(Num_Saved_Checks
) :=
3414 Target_Type
=> Empty
);
3416 if Debug_Flag_CC
then
3417 w
("Make new entry, check number = ", Num_Saved_Checks
);
3418 w
(" Entity = ", Int
(Ent
));
3419 Write_Str
(" Offset = ");
3421 w
(" Check_Type = O");
3422 w
(" Target_Type = Empty");
3425 -- If we get an exception, then something went wrong, probably because
3426 -- of an error in the structure of the tree due to an incorrect program.
3427 -- Or it may be a bug in the optimization circuit. In either case the
3428 -- safest thing is simply to set the check flag unconditionally.
3432 Set_Do_Overflow_Check
(N
, True);
3434 if Debug_Flag_CC
then
3435 w
(" exception occurred, overflow flag set");
3439 end Enable_Overflow_Check
;
3441 ------------------------
3442 -- Enable_Range_Check --
3443 ------------------------
3445 procedure Enable_Range_Check
(N
: Node_Id
) is
3454 -- Return if unchecked type conversion with range check killed.
3455 -- In this case we never set the flag (that's what Kill_Range_Check
3458 if Nkind
(N
) = N_Unchecked_Type_Conversion
3459 and then Kill_Range_Check
(N
)
3464 -- Debug trace output
3466 if Debug_Flag_CC
then
3467 w
("Enable_Range_Check for node ", Int
(N
));
3468 Write_Str
(" Source location = ");
3473 -- If not in optimizing mode, set flag and we are done. We are also
3474 -- done (and just set the flag) if the type is not a discrete type,
3475 -- since it is not worth the effort to eliminate checks for other
3476 -- than discrete types. In addition, we take this same path if we
3477 -- have stored the maximum number of checks possible already (a
3478 -- very unlikely situation, but we do not want to blow up!)
3480 if Optimization_Level
= 0
3481 or else No
(Etype
(N
))
3482 or else not Is_Discrete_Type
(Etype
(N
))
3483 or else Num_Saved_Checks
= Saved_Checks
'Last
3485 Set_Do_Range_Check
(N
, True);
3487 if Debug_Flag_CC
then
3488 w
("Optimization off");
3494 -- Otherwise find out the target type
3498 -- For assignment, use left side subtype
3500 if Nkind
(P
) = N_Assignment_Statement
3501 and then Expression
(P
) = N
3503 Ttyp
:= Etype
(Name
(P
));
3505 -- For indexed component, use subscript subtype
3507 elsif Nkind
(P
) = N_Indexed_Component
then
3514 Atyp
:= Etype
(Prefix
(P
));
3516 if Is_Access_Type
(Atyp
) then
3517 Atyp
:= Designated_Type
(Atyp
);
3519 -- If the prefix is an access to an unconstrained array,
3520 -- perform check unconditionally: it depends on the bounds
3521 -- of an object and we cannot currently recognize whether
3522 -- the test may be redundant.
3524 if not Is_Constrained
(Atyp
) then
3525 Set_Do_Range_Check
(N
, True);
3529 -- Ditto if the prefix is an explicit dereference whose
3530 -- designated type is unconstrained.
3532 elsif Nkind
(Prefix
(P
)) = N_Explicit_Dereference
3533 and then not Is_Constrained
(Atyp
)
3535 Set_Do_Range_Check
(N
, True);
3539 Indx
:= First_Index
(Atyp
);
3540 Subs
:= First
(Expressions
(P
));
3543 Ttyp
:= Etype
(Indx
);
3552 -- For now, ignore all other cases, they are not so interesting
3555 if Debug_Flag_CC
then
3556 w
(" target type not found, flag set");
3559 Set_Do_Range_Check
(N
, True);
3563 -- Evaluate and check the expression
3568 Target_Type
=> Ttyp
,
3574 if Debug_Flag_CC
then
3575 w
("Called Find_Check");
3576 w
("Target_Typ = ", Int
(Ttyp
));
3580 w
(" Check_Num = ", Chk
);
3581 w
(" Ent = ", Int
(Ent
));
3582 Write_Str
(" Ofs = ");
3587 -- If check is not of form to optimize, then set flag and we are done
3590 if Debug_Flag_CC
then
3591 w
(" expression not of optimizable type, flag set");
3594 Set_Do_Range_Check
(N
, True);
3598 -- If check is already performed, then return without setting flag
3601 if Debug_Flag_CC
then
3602 w
("Check suppressed!");
3608 -- Here we will make a new entry for the new check
3610 Set_Do_Range_Check
(N
, True);
3611 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
3612 Saved_Checks
(Num_Saved_Checks
) :=
3617 Target_Type
=> Ttyp
);
3619 if Debug_Flag_CC
then
3620 w
("Make new entry, check number = ", Num_Saved_Checks
);
3621 w
(" Entity = ", Int
(Ent
));
3622 Write_Str
(" Offset = ");
3624 w
(" Check_Type = R");
3625 w
(" Target_Type = ", Int
(Ttyp
));
3629 -- If we get an exception, then something went wrong, probably because
3630 -- of an error in the structure of the tree due to an incorrect program.
3631 -- Or it may be a bug in the optimization circuit. In either case the
3632 -- safest thing is simply to set the check flag unconditionally.
3636 Set_Do_Range_Check
(N
, True);
3638 if Debug_Flag_CC
then
3639 w
(" exception occurred, range flag set");
3643 end Enable_Range_Check
;
3649 procedure Ensure_Valid
(Expr
: Node_Id
; Holes_OK
: Boolean := False) is
3650 Typ
: constant Entity_Id
:= Etype
(Expr
);
3653 -- Ignore call if we are not doing any validity checking
3655 if not Validity_Checks_On
then
3658 -- Ignore call if range checks suppressed on entity in question
3660 elsif Is_Entity_Name
(Expr
)
3661 and then Range_Checks_Suppressed
(Entity
(Expr
))
3665 -- No check required if expression is from the expander, we assume
3666 -- the expander will generate whatever checks are needed. Note that
3667 -- this is not just an optimization, it avoids infinite recursions!
3669 -- Unchecked conversions must be checked, unless they are initialized
3670 -- scalar values, as in a component assignment in an init proc.
3672 -- In addition, we force a check if Force_Validity_Checks is set
3674 elsif not Comes_From_Source
(Expr
)
3675 and then not Force_Validity_Checks
3676 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
3677 or else Kill_Range_Check
(Expr
))
3681 -- No check required if expression is known to have valid value
3683 elsif Expr_Known_Valid
(Expr
) then
3686 -- No check required if checks off
3688 elsif Range_Checks_Suppressed
(Typ
) then
3691 -- Ignore case of enumeration with holes where the flag is set not
3692 -- to worry about holes, since no special validity check is needed
3694 elsif Is_Enumeration_Type
(Typ
)
3695 and then Has_Non_Standard_Rep
(Typ
)
3700 -- No check required on the left-hand side of an assignment
3702 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
3703 and then Expr
= Name
(Parent
(Expr
))
3707 -- No check on a univeral real constant. The context will eventually
3708 -- convert it to a machine number for some target type, or report an
3711 elsif Nkind
(Expr
) = N_Real_Literal
3712 and then Etype
(Expr
) = Universal_Real
3716 -- An annoying special case. If this is an out parameter of a scalar
3717 -- type, then the value is not going to be accessed, therefore it is
3718 -- inappropriate to do any validity check at the call site.
3721 -- Only need to worry about scalar types
3723 if Is_Scalar_Type
(Typ
) then
3733 -- Find actual argument (which may be a parameter association)
3734 -- and the parent of the actual argument (the call statement)
3739 if Nkind
(P
) = N_Parameter_Association
then
3744 -- Only need to worry if we are argument of a procedure
3745 -- call since functions don't have out parameters. If this
3746 -- is an indirect or dispatching call, get signature from
3747 -- the subprogram type.
3749 if Nkind
(P
) = N_Procedure_Call_Statement
then
3750 L
:= Parameter_Associations
(P
);
3752 if Is_Entity_Name
(Name
(P
)) then
3753 E
:= Entity
(Name
(P
));
3755 pragma Assert
(Nkind
(Name
(P
)) = N_Explicit_Dereference
);
3756 E
:= Etype
(Name
(P
));
3759 -- Only need to worry if there are indeed actuals, and
3760 -- if this could be a procedure call, otherwise we cannot
3761 -- get a match (either we are not an argument, or the
3762 -- mode of the formal is not OUT). This test also filters
3763 -- out the generic case.
3765 if Is_Non_Empty_List
(L
)
3766 and then Is_Subprogram
(E
)
3768 -- This is the loop through parameters, looking to
3769 -- see if there is an OUT parameter for which we are
3772 F
:= First_Formal
(E
);
3775 while Present
(F
) loop
3776 if Ekind
(F
) = E_Out_Parameter
and then A
= N
then
3789 -- If we fall through, a validity check is required. Note that it would
3790 -- not be good to set Do_Range_Check, even in contexts where this is
3791 -- permissible, since this flag causes checking against the target type,
3792 -- not the source type in contexts such as assignments
3794 Insert_Valid_Check
(Expr
);
3797 ----------------------
3798 -- Expr_Known_Valid --
3799 ----------------------
3801 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
3802 Typ
: constant Entity_Id
:= Etype
(Expr
);
3805 -- Non-scalar types are always considered valid, since they never
3806 -- give rise to the issues of erroneous or bounded error behavior
3807 -- that are the concern. In formal reference manual terms the
3808 -- notion of validity only applies to scalar types. Note that
3809 -- even when packed arrays are represented using modular types,
3810 -- they are still arrays semantically, so they are also always
3811 -- valid (in particular, the unused bits can be random rubbish
3812 -- without affecting the validity of the array value).
3814 if not Is_Scalar_Type
(Typ
) or else Is_Packed_Array_Type
(Typ
) then
3817 -- If no validity checking, then everything is considered valid
3819 elsif not Validity_Checks_On
then
3822 -- Floating-point types are considered valid unless floating-point
3823 -- validity checks have been specifically turned on.
3825 elsif Is_Floating_Point_Type
(Typ
)
3826 and then not Validity_Check_Floating_Point
3830 -- If the expression is the value of an object that is known to
3831 -- be valid, then clearly the expression value itself is valid.
3833 elsif Is_Entity_Name
(Expr
)
3834 and then Is_Known_Valid
(Entity
(Expr
))
3838 -- If the type is one for which all values are known valid, then
3839 -- we are sure that the value is valid except in the slightly odd
3840 -- case where the expression is a reference to a variable whose size
3841 -- has been explicitly set to a value greater than the object size.
3843 elsif Is_Known_Valid
(Typ
) then
3844 if Is_Entity_Name
(Expr
)
3845 and then Ekind
(Entity
(Expr
)) = E_Variable
3846 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
3853 -- Integer and character literals always have valid values, where
3854 -- appropriate these will be range checked in any case.
3856 elsif Nkind
(Expr
) = N_Integer_Literal
3858 Nkind
(Expr
) = N_Character_Literal
3862 -- If we have a type conversion or a qualification of a known valid
3863 -- value, then the result will always be valid.
3865 elsif Nkind
(Expr
) = N_Type_Conversion
3867 Nkind
(Expr
) = N_Qualified_Expression
3869 return Expr_Known_Valid
(Expression
(Expr
));
3871 -- The result of any operator is always considered valid, since we
3872 -- assume the necessary checks are done by the operator. For operators
3873 -- on floating-point operations, we must also check when the operation
3874 -- is the right-hand side of an assignment, or is an actual in a call.
3877 Nkind
(Expr
) in N_Binary_Op
or else Nkind
(Expr
) in N_Unary_Op
3879 if Is_Floating_Point_Type
(Typ
)
3880 and then Validity_Check_Floating_Point
3882 (Nkind
(Parent
(Expr
)) = N_Assignment_Statement
3883 or else Nkind
(Parent
(Expr
)) = N_Function_Call
3884 or else Nkind
(Parent
(Expr
)) = N_Parameter_Association
)
3891 -- For all other cases, we do not know the expression is valid
3896 end Expr_Known_Valid
;
3902 procedure Find_Check
3904 Check_Type
: Character;
3905 Target_Type
: Entity_Id
;
3906 Entry_OK
: out Boolean;
3907 Check_Num
: out Nat
;
3908 Ent
: out Entity_Id
;
3911 function Within_Range_Of
3912 (Target_Type
: Entity_Id
;
3913 Check_Type
: Entity_Id
) return Boolean;
3914 -- Given a requirement for checking a range against Target_Type, and
3915 -- and a range Check_Type against which a check has already been made,
3916 -- determines if the check against check type is sufficient to ensure
3917 -- that no check against Target_Type is required.
3919 ---------------------
3920 -- Within_Range_Of --
3921 ---------------------
3923 function Within_Range_Of
3924 (Target_Type
: Entity_Id
;
3925 Check_Type
: Entity_Id
) return Boolean
3928 if Target_Type
= Check_Type
then
3933 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
3934 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
3935 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
3936 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
3940 or else (Compile_Time_Known_Value
(Tlo
)
3942 Compile_Time_Known_Value
(Clo
)
3944 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
3947 or else (Compile_Time_Known_Value
(Thi
)
3949 Compile_Time_Known_Value
(Chi
)
3951 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
3959 end Within_Range_Of
;
3961 -- Start of processing for Find_Check
3964 -- Establish default, to avoid warnings from GCC
3968 -- Case of expression is simple entity reference
3970 if Is_Entity_Name
(Expr
) then
3971 Ent
:= Entity
(Expr
);
3974 -- Case of expression is entity + known constant
3976 elsif Nkind
(Expr
) = N_Op_Add
3977 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3978 and then Is_Entity_Name
(Left_Opnd
(Expr
))
3980 Ent
:= Entity
(Left_Opnd
(Expr
));
3981 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
3983 -- Case of expression is entity - known constant
3985 elsif Nkind
(Expr
) = N_Op_Subtract
3986 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3987 and then Is_Entity_Name
(Left_Opnd
(Expr
))
3989 Ent
:= Entity
(Left_Opnd
(Expr
));
3990 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
3992 -- Any other expression is not of the right form
4001 -- Come here with expression of appropriate form, check if
4002 -- entity is an appropriate one for our purposes.
4004 if (Ekind
(Ent
) = E_Variable
4006 Ekind
(Ent
) = E_Constant
4008 Ekind
(Ent
) = E_Loop_Parameter
4010 Ekind
(Ent
) = E_In_Parameter
)
4011 and then not Is_Library_Level_Entity
(Ent
)
4019 -- See if there is matching check already
4021 for J
in reverse 1 .. Num_Saved_Checks
loop
4023 SC
: Saved_Check
renames Saved_Checks
(J
);
4026 if SC
.Killed
= False
4027 and then SC
.Entity
= Ent
4028 and then SC
.Offset
= Ofs
4029 and then SC
.Check_Type
= Check_Type
4030 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
4038 -- If we fall through entry was not found
4044 ---------------------------------
4045 -- Generate_Discriminant_Check --
4046 ---------------------------------
4048 -- Note: the code for this procedure is derived from the
4049 -- emit_discriminant_check routine a-trans.c v1.659.
4051 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
4052 Loc
: constant Source_Ptr
:= Sloc
(N
);
4053 Pref
: constant Node_Id
:= Prefix
(N
);
4054 Sel
: constant Node_Id
:= Selector_Name
(N
);
4056 Orig_Comp
: constant Entity_Id
:=
4057 Original_Record_Component
(Entity
(Sel
));
4058 -- The original component to be checked
4060 Discr_Fct
: constant Entity_Id
:=
4061 Discriminant_Checking_Func
(Orig_Comp
);
4062 -- The discriminant checking function
4065 -- One discriminant to be checked in the type
4067 Real_Discr
: Entity_Id
;
4068 -- Actual discriminant in the call
4070 Pref_Type
: Entity_Id
;
4071 -- Type of relevant prefix (ignoring private/access stuff)
4074 -- List of arguments for function call
4077 -- Keep track of the formal corresponding to the actual we build
4078 -- for each discriminant, in order to be able to perform the
4079 -- necessary type conversions.
4082 -- Selected component reference for checking function argument
4085 Pref_Type
:= Etype
(Pref
);
4087 -- Force evaluation of the prefix, so that it does not get evaluated
4088 -- twice (once for the check, once for the actual reference). Such a
4089 -- double evaluation is always a potential source of inefficiency,
4090 -- and is functionally incorrect in the volatile case, or when the
4091 -- prefix may have side-effects. An entity or a component of an
4092 -- entity requires no evaluation.
4094 if Is_Entity_Name
(Pref
) then
4095 if Treat_As_Volatile
(Entity
(Pref
)) then
4096 Force_Evaluation
(Pref
, Name_Req
=> True);
4099 elsif Treat_As_Volatile
(Etype
(Pref
)) then
4100 Force_Evaluation
(Pref
, Name_Req
=> True);
4102 elsif Nkind
(Pref
) = N_Selected_Component
4103 and then Is_Entity_Name
(Prefix
(Pref
))
4108 Force_Evaluation
(Pref
, Name_Req
=> True);
4111 -- For a tagged type, use the scope of the original component to
4112 -- obtain the type, because ???
4114 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
4115 Pref_Type
:= Scope
(Orig_Comp
);
4117 -- For an untagged derived type, use the discriminants of the
4118 -- parent which have been renamed in the derivation, possibly
4119 -- by a one-to-many discriminant constraint.
4120 -- For non-tagged type, initially get the Etype of the prefix
4123 if Is_Derived_Type
(Pref_Type
)
4124 and then Number_Discriminants
(Pref_Type
) /=
4125 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
4127 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
4131 -- We definitely should have a checking function, This routine should
4132 -- not be called if no discriminant checking function is present.
4134 pragma Assert
(Present
(Discr_Fct
));
4136 -- Create the list of the actual parameters for the call. This list
4137 -- is the list of the discriminant fields of the record expression to
4138 -- be discriminant checked.
4141 Formal
:= First_Formal
(Discr_Fct
);
4142 Discr
:= First_Discriminant
(Pref_Type
);
4143 while Present
(Discr
) loop
4145 -- If we have a corresponding discriminant field, and a parent
4146 -- subtype is present, then we want to use the corresponding
4147 -- discriminant since this is the one with the useful value.
4149 if Present
(Corresponding_Discriminant
(Discr
))
4150 and then Ekind
(Pref_Type
) = E_Record_Type
4151 and then Present
(Parent_Subtype
(Pref_Type
))
4153 Real_Discr
:= Corresponding_Discriminant
(Discr
);
4155 Real_Discr
:= Discr
;
4158 -- Construct the reference to the discriminant
4161 Make_Selected_Component
(Loc
,
4163 Unchecked_Convert_To
(Pref_Type
,
4164 Duplicate_Subexpr
(Pref
)),
4165 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
4167 -- Manually analyze and resolve this selected component. We really
4168 -- want it just as it appears above, and do not want the expander
4169 -- playing discriminal games etc with this reference. Then we
4170 -- append the argument to the list we are gathering.
4172 Set_Etype
(Scomp
, Etype
(Real_Discr
));
4173 Set_Analyzed
(Scomp
, True);
4174 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
4176 Next_Formal_With_Extras
(Formal
);
4177 Next_Discriminant
(Discr
);
4180 -- Now build and insert the call
4183 Make_Raise_Constraint_Error
(Loc
,
4185 Make_Function_Call
(Loc
,
4186 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
4187 Parameter_Associations
=> Args
),
4188 Reason
=> CE_Discriminant_Check_Failed
));
4189 end Generate_Discriminant_Check
;
4191 ---------------------------
4192 -- Generate_Index_Checks --
4193 ---------------------------
4195 procedure Generate_Index_Checks
(N
: Node_Id
) is
4196 Loc
: constant Source_Ptr
:= Sloc
(N
);
4197 A
: constant Node_Id
:= Prefix
(N
);
4203 Sub
:= First
(Expressions
(N
));
4205 while Present
(Sub
) loop
4206 if Do_Range_Check
(Sub
) then
4207 Set_Do_Range_Check
(Sub
, False);
4209 -- Force evaluation except for the case of a simple name of
4210 -- a non-volatile entity.
4212 if not Is_Entity_Name
(Sub
)
4213 or else Treat_As_Volatile
(Entity
(Sub
))
4215 Force_Evaluation
(Sub
);
4218 -- Generate a raise of constraint error with the appropriate
4219 -- reason and a condition of the form:
4221 -- Base_Type(Sub) not in array'range (subscript)
4223 -- Note that the reason we generate the conversion to the
4224 -- base type here is that we definitely want the range check
4225 -- to take place, even if it looks like the subtype is OK.
4226 -- Optimization considerations that allow us to omit the
4227 -- check have already been taken into account in the setting
4228 -- of the Do_Range_Check flag earlier on.
4233 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
4237 Make_Raise_Constraint_Error
(Loc
,
4241 Convert_To
(Base_Type
(Etype
(Sub
)),
4242 Duplicate_Subexpr_Move_Checks
(Sub
)),
4244 Make_Attribute_Reference
(Loc
,
4245 Prefix
=> Duplicate_Subexpr_Move_Checks
(A
),
4246 Attribute_Name
=> Name_Range
,
4247 Expressions
=> Num
)),
4248 Reason
=> CE_Index_Check_Failed
));
4254 end Generate_Index_Checks
;
4256 --------------------------
4257 -- Generate_Range_Check --
4258 --------------------------
4260 procedure Generate_Range_Check
4262 Target_Type
: Entity_Id
;
4263 Reason
: RT_Exception_Code
)
4265 Loc
: constant Source_Ptr
:= Sloc
(N
);
4266 Source_Type
: constant Entity_Id
:= Etype
(N
);
4267 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
4268 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
4271 -- First special case, if the source type is already within the
4272 -- range of the target type, then no check is needed (probably we
4273 -- should have stopped Do_Range_Check from being set in the first
4274 -- place, but better late than later in preventing junk code!
4276 -- We do NOT apply this if the source node is a literal, since in
4277 -- this case the literal has already been labeled as having the
4278 -- subtype of the target.
4280 if In_Subrange_Of
(Source_Type
, Target_Type
)
4282 (Nkind
(N
) = N_Integer_Literal
4284 Nkind
(N
) = N_Real_Literal
4286 Nkind
(N
) = N_Character_Literal
4289 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
4294 -- We need a check, so force evaluation of the node, so that it does
4295 -- not get evaluated twice (once for the check, once for the actual
4296 -- reference). Such a double evaluation is always a potential source
4297 -- of inefficiency, and is functionally incorrect in the volatile case.
4299 if not Is_Entity_Name
(N
)
4300 or else Treat_As_Volatile
(Entity
(N
))
4302 Force_Evaluation
(N
);
4305 -- The easiest case is when Source_Base_Type and Target_Base_Type
4306 -- are the same since in this case we can simply do a direct
4307 -- check of the value of N against the bounds of Target_Type.
4309 -- [constraint_error when N not in Target_Type]
4311 -- Note: this is by far the most common case, for example all cases of
4312 -- checks on the RHS of assignments are in this category, but not all
4313 -- cases are like this. Notably conversions can involve two types.
4315 if Source_Base_Type
= Target_Base_Type
then
4317 Make_Raise_Constraint_Error
(Loc
,
4320 Left_Opnd
=> Duplicate_Subexpr
(N
),
4321 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
4324 -- Next test for the case where the target type is within the bounds
4325 -- of the base type of the source type, since in this case we can
4326 -- simply convert these bounds to the base type of T to do the test.
4328 -- [constraint_error when N not in
4329 -- Source_Base_Type (Target_Type'First)
4331 -- Source_Base_Type(Target_Type'Last))]
4333 -- The conversions will always work and need no check
4335 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
4337 Make_Raise_Constraint_Error
(Loc
,
4340 Left_Opnd
=> Duplicate_Subexpr
(N
),
4345 Convert_To
(Source_Base_Type
,
4346 Make_Attribute_Reference
(Loc
,
4348 New_Occurrence_Of
(Target_Type
, Loc
),
4349 Attribute_Name
=> Name_First
)),
4352 Convert_To
(Source_Base_Type
,
4353 Make_Attribute_Reference
(Loc
,
4355 New_Occurrence_Of
(Target_Type
, Loc
),
4356 Attribute_Name
=> Name_Last
)))),
4359 -- Note that at this stage we now that the Target_Base_Type is
4360 -- not in the range of the Source_Base_Type (since even the
4361 -- Target_Type itself is not in this range). It could still be
4362 -- the case that the Source_Type is in range of the target base
4363 -- type, since we have not checked that case.
4365 -- If that is the case, we can freely convert the source to the
4366 -- target, and then test the target result against the bounds.
4368 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
4370 -- We make a temporary to hold the value of the converted
4371 -- value (converted to the base type), and then we will
4372 -- do the test against this temporary.
4374 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
4375 -- [constraint_error when Tnn not in Target_Type]
4377 -- Then the conversion itself is replaced by an occurrence of Tnn
4380 Tnn
: constant Entity_Id
:=
4381 Make_Defining_Identifier
(Loc
,
4382 Chars
=> New_Internal_Name
('T'));
4385 Insert_Actions
(N
, New_List
(
4386 Make_Object_Declaration
(Loc
,
4387 Defining_Identifier
=> Tnn
,
4388 Object_Definition
=>
4389 New_Occurrence_Of
(Target_Base_Type
, Loc
),
4390 Constant_Present
=> True,
4392 Make_Type_Conversion
(Loc
,
4393 Subtype_Mark
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
4394 Expression
=> Duplicate_Subexpr
(N
))),
4396 Make_Raise_Constraint_Error
(Loc
,
4399 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
4400 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
4402 Reason
=> Reason
)));
4404 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
4407 -- At this stage, we know that we have two scalar types, which are
4408 -- directly convertible, and where neither scalar type has a base
4409 -- range that is in the range of the other scalar type.
4411 -- The only way this can happen is with a signed and unsigned type.
4412 -- So test for these two cases:
4415 -- Case of the source is unsigned and the target is signed
4417 if Is_Unsigned_Type
(Source_Base_Type
)
4418 and then not Is_Unsigned_Type
(Target_Base_Type
)
4420 -- If the source is unsigned and the target is signed, then we
4421 -- know that the source is not shorter than the target (otherwise
4422 -- the source base type would be in the target base type range).
4424 -- In other words, the unsigned type is either the same size
4425 -- as the target, or it is larger. It cannot be smaller.
4428 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
4430 -- We only need to check the low bound if the low bound of the
4431 -- target type is non-negative. If the low bound of the target
4432 -- type is negative, then we know that we will fit fine.
4434 -- If the high bound of the target type is negative, then we
4435 -- know we have a constraint error, since we can't possibly
4436 -- have a negative source.
4438 -- With these two checks out of the way, we can do the check
4439 -- using the source type safely
4441 -- This is definitely the most annoying case!
4443 -- [constraint_error
4444 -- when (Target_Type'First >= 0
4446 -- N < Source_Base_Type (Target_Type'First))
4447 -- or else Target_Type'Last < 0
4448 -- or else N > Source_Base_Type (Target_Type'Last)];
4450 -- We turn off all checks since we know that the conversions
4451 -- will work fine, given the guards for negative values.
4454 Make_Raise_Constraint_Error
(Loc
,
4460 Left_Opnd
=> Make_Op_Ge
(Loc
,
4462 Make_Attribute_Reference
(Loc
,
4464 New_Occurrence_Of
(Target_Type
, Loc
),
4465 Attribute_Name
=> Name_First
),
4466 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
4470 Left_Opnd
=> Duplicate_Subexpr
(N
),
4472 Convert_To
(Source_Base_Type
,
4473 Make_Attribute_Reference
(Loc
,
4475 New_Occurrence_Of
(Target_Type
, Loc
),
4476 Attribute_Name
=> Name_First
)))),
4481 Make_Attribute_Reference
(Loc
,
4482 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
4483 Attribute_Name
=> Name_Last
),
4484 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
4488 Left_Opnd
=> Duplicate_Subexpr
(N
),
4490 Convert_To
(Source_Base_Type
,
4491 Make_Attribute_Reference
(Loc
,
4492 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
4493 Attribute_Name
=> Name_Last
)))),
4496 Suppress
=> All_Checks
);
4498 -- Only remaining possibility is that the source is signed and
4499 -- the target is unsigned
4502 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
4503 and then Is_Unsigned_Type
(Target_Base_Type
));
4505 -- If the source is signed and the target is unsigned, then
4506 -- we know that the target is not shorter than the source
4507 -- (otherwise the target base type would be in the source
4508 -- base type range).
4510 -- In other words, the unsigned type is either the same size
4511 -- as the target, or it is larger. It cannot be smaller.
4513 -- Clearly we have an error if the source value is negative
4514 -- since no unsigned type can have negative values. If the
4515 -- source type is non-negative, then the check can be done
4516 -- using the target type.
4518 -- Tnn : constant Target_Base_Type (N) := Target_Type;
4520 -- [constraint_error
4521 -- when N < 0 or else Tnn not in Target_Type];
4523 -- We turn off all checks for the conversion of N to the
4524 -- target base type, since we generate the explicit check
4525 -- to ensure that the value is non-negative
4528 Tnn
: constant Entity_Id
:=
4529 Make_Defining_Identifier
(Loc
,
4530 Chars
=> New_Internal_Name
('T'));
4533 Insert_Actions
(N
, New_List
(
4534 Make_Object_Declaration
(Loc
,
4535 Defining_Identifier
=> Tnn
,
4536 Object_Definition
=>
4537 New_Occurrence_Of
(Target_Base_Type
, Loc
),
4538 Constant_Present
=> True,
4540 Make_Type_Conversion
(Loc
,
4542 New_Occurrence_Of
(Target_Base_Type
, Loc
),
4543 Expression
=> Duplicate_Subexpr
(N
))),
4545 Make_Raise_Constraint_Error
(Loc
,
4550 Left_Opnd
=> Duplicate_Subexpr
(N
),
4551 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
4555 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
4557 New_Occurrence_Of
(Target_Type
, Loc
))),
4560 Suppress
=> All_Checks
);
4562 -- Set the Etype explicitly, because Insert_Actions may
4563 -- have placed the declaration in the freeze list for an
4564 -- enclosing construct, and thus it is not analyzed yet.
4566 Set_Etype
(Tnn
, Target_Base_Type
);
4567 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
4571 end Generate_Range_Check
;
4573 ---------------------
4574 -- Get_Discriminal --
4575 ---------------------
4577 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
4578 Loc
: constant Source_Ptr
:= Sloc
(E
);
4583 -- The entity E is the type of a private component of the protected
4584 -- type, or the type of a renaming of that component within a protected
4585 -- operation of that type.
4589 if Ekind
(Sc
) /= E_Protected_Type
then
4592 if Ekind
(Sc
) /= E_Protected_Type
then
4597 D
:= First_Discriminant
(Sc
);
4600 and then Chars
(D
) /= Chars
(Bound
)
4602 Next_Discriminant
(D
);
4605 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
4606 end Get_Discriminal
;
4612 function Guard_Access
4615 Ck_Node
: Node_Id
) return Node_Id
4618 if Nkind
(Cond
) = N_Or_Else
then
4619 Set_Paren_Count
(Cond
, 1);
4622 if Nkind
(Ck_Node
) = N_Allocator
then
4629 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
4630 Right_Opnd
=> Make_Null
(Loc
)),
4631 Right_Opnd
=> Cond
);
4635 -----------------------------
4636 -- Index_Checks_Suppressed --
4637 -----------------------------
4639 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4641 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4642 return Is_Check_Suppressed
(E
, Index_Check
);
4644 return Scope_Suppress
(Index_Check
);
4646 end Index_Checks_Suppressed
;
4652 procedure Initialize
is
4654 for J
in Determine_Range_Cache_N
'Range loop
4655 Determine_Range_Cache_N
(J
) := Empty
;
4659 -------------------------
4660 -- Insert_Range_Checks --
4661 -------------------------
4663 procedure Insert_Range_Checks
4664 (Checks
: Check_Result
;
4666 Suppress_Typ
: Entity_Id
;
4667 Static_Sloc
: Source_Ptr
:= No_Location
;
4668 Flag_Node
: Node_Id
:= Empty
;
4669 Do_Before
: Boolean := False)
4671 Internal_Flag_Node
: Node_Id
:= Flag_Node
;
4672 Internal_Static_Sloc
: Source_Ptr
:= Static_Sloc
;
4674 Check_Node
: Node_Id
;
4675 Checks_On
: constant Boolean :=
4676 (not Index_Checks_Suppressed
(Suppress_Typ
))
4678 (not Range_Checks_Suppressed
(Suppress_Typ
));
4681 -- For now we just return if Checks_On is false, however this should
4682 -- be enhanced to check for an always True value in the condition
4683 -- and to generate a compilation warning???
4685 if not Expander_Active
or else not Checks_On
then
4689 if Static_Sloc
= No_Location
then
4690 Internal_Static_Sloc
:= Sloc
(Node
);
4693 if No
(Flag_Node
) then
4694 Internal_Flag_Node
:= Node
;
4697 for J
in 1 .. 2 loop
4698 exit when No
(Checks
(J
));
4700 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
4701 and then Present
(Condition
(Checks
(J
)))
4703 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
4704 Check_Node
:= Checks
(J
);
4705 Mark_Rewrite_Insertion
(Check_Node
);
4708 Insert_Before_And_Analyze
(Node
, Check_Node
);
4710 Insert_After_And_Analyze
(Node
, Check_Node
);
4713 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
4718 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
4719 Reason
=> CE_Range_Check_Failed
);
4720 Mark_Rewrite_Insertion
(Check_Node
);
4723 Insert_Before_And_Analyze
(Node
, Check_Node
);
4725 Insert_After_And_Analyze
(Node
, Check_Node
);
4729 end Insert_Range_Checks
;
4731 ------------------------
4732 -- Insert_Valid_Check --
4733 ------------------------
4735 procedure Insert_Valid_Check
(Expr
: Node_Id
) is
4736 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
4740 -- Do not insert if checks off, or if not checking validity
4742 if Range_Checks_Suppressed
(Etype
(Expr
))
4743 or else (not Validity_Checks_On
)
4748 -- If we have a checked conversion, then validity check applies to
4749 -- the expression inside the conversion, not the result, since if
4750 -- the expression inside is valid, then so is the conversion result.
4753 while Nkind
(Exp
) = N_Type_Conversion
loop
4754 Exp
:= Expression
(Exp
);
4757 -- Insert the validity check. Note that we do this with validity
4758 -- checks turned off, to avoid recursion, we do not want validity
4759 -- checks on the validity checking code itself!
4761 Validity_Checks_On
:= False;
4764 Make_Raise_Constraint_Error
(Loc
,
4768 Make_Attribute_Reference
(Loc
,
4770 Duplicate_Subexpr_No_Checks
(Exp
, Name_Req
=> True),
4771 Attribute_Name
=> Name_Valid
)),
4772 Reason
=> CE_Invalid_Data
),
4773 Suppress
=> All_Checks
);
4775 -- If the expression is a a reference to an element of a bit-packed
4776 -- array, it is rewritten as a renaming declaration. If the expression
4777 -- is an actual in a call, it has not been expanded, waiting for the
4778 -- proper point at which to do it. The same happens with renamings, so
4779 -- that we have to force the expansion now. This non-local complication
4780 -- is due to code in exp_ch2,adb, exp_ch4.adb and exp_ch6.adb.
4782 if Is_Entity_Name
(Exp
)
4783 and then Nkind
(Parent
(Entity
(Exp
))) = N_Object_Renaming_Declaration
4786 Old_Exp
: constant Node_Id
:= Name
(Parent
(Entity
(Exp
)));
4788 if Nkind
(Old_Exp
) = N_Indexed_Component
4789 and then Is_Bit_Packed_Array
(Etype
(Prefix
(Old_Exp
)))
4791 Expand_Packed_Element_Reference
(Old_Exp
);
4796 Validity_Checks_On
:= True;
4797 end Insert_Valid_Check
;
4799 ----------------------------------
4800 -- Install_Null_Excluding_Check --
4801 ----------------------------------
4803 procedure Install_Null_Excluding_Check
(N
: Node_Id
) is
4804 Loc
: constant Source_Ptr
:= Sloc
(N
);
4805 Typ
: constant Entity_Id
:= Etype
(N
);
4807 procedure Mark_Non_Null
;
4808 -- After installation of check, marks node as non-null if entity
4814 procedure Mark_Non_Null
is
4816 if Is_Entity_Name
(N
) then
4817 Set_Is_Known_Null
(Entity
(N
), False);
4819 if Safe_To_Capture_Value
(N
, Entity
(N
)) then
4820 Set_Is_Known_Non_Null
(Entity
(N
), True);
4825 -- Start of processing for Install_Null_Excluding_Check
4828 pragma Assert
(Is_Access_Type
(Typ
));
4830 -- No check inside a generic (why not???)
4832 if Inside_A_Generic
then
4836 -- No check needed if known to be non-null
4838 if Known_Non_Null
(N
) then
4842 -- If known to be null, here is where we generate a compile time check
4844 if Known_Null
(N
) then
4845 Apply_Compile_Time_Constraint_Error
4847 "null value not allowed here?",
4848 CE_Access_Check_Failed
);
4853 -- If entity is never assigned, for sure a warning is appropriate
4855 if Is_Entity_Name
(N
) then
4856 Check_Unset_Reference
(N
);
4859 -- No check needed if checks are suppressed on the range. Note that we
4860 -- don't set Is_Known_Non_Null in this case (we could legitimately do
4861 -- so, since the program is erroneous, but we don't like to casually
4862 -- propagate such conclusions from erroneosity).
4864 if Access_Checks_Suppressed
(Typ
) then
4868 -- Otherwise install access check
4871 Make_Raise_Constraint_Error
(Loc
,
4874 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(N
),
4875 Right_Opnd
=> Make_Null
(Loc
)),
4876 Reason
=> CE_Access_Check_Failed
));
4879 end Install_Null_Excluding_Check
;
4881 --------------------------
4882 -- Install_Static_Check --
4883 --------------------------
4885 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
4886 Stat
: constant Boolean := Is_Static_Expression
(R_Cno
);
4887 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
4891 Make_Raise_Constraint_Error
(Loc
,
4892 Reason
=> CE_Range_Check_Failed
));
4893 Set_Analyzed
(R_Cno
);
4894 Set_Etype
(R_Cno
, Typ
);
4895 Set_Raises_Constraint_Error
(R_Cno
);
4896 Set_Is_Static_Expression
(R_Cno
, Stat
);
4897 end Install_Static_Check
;
4899 ---------------------
4900 -- Kill_All_Checks --
4901 ---------------------
4903 procedure Kill_All_Checks
is
4905 if Debug_Flag_CC
then
4906 w
("Kill_All_Checks");
4909 -- We reset the number of saved checks to zero, and also modify
4910 -- all stack entries for statement ranges to indicate that the
4911 -- number of checks at each level is now zero.
4913 Num_Saved_Checks
:= 0;
4915 for J
in 1 .. Saved_Checks_TOS
loop
4916 Saved_Checks_Stack
(J
) := 0;
4918 end Kill_All_Checks
;
4924 procedure Kill_Checks
(V
: Entity_Id
) is
4926 if Debug_Flag_CC
then
4927 w
("Kill_Checks for entity", Int
(V
));
4930 for J
in 1 .. Num_Saved_Checks
loop
4931 if Saved_Checks
(J
).Entity
= V
then
4932 if Debug_Flag_CC
then
4933 w
(" Checks killed for saved check ", J
);
4936 Saved_Checks
(J
).Killed
:= True;
4941 ------------------------------
4942 -- Length_Checks_Suppressed --
4943 ------------------------------
4945 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4947 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4948 return Is_Check_Suppressed
(E
, Length_Check
);
4950 return Scope_Suppress
(Length_Check
);
4952 end Length_Checks_Suppressed
;
4954 --------------------------------
4955 -- Overflow_Checks_Suppressed --
4956 --------------------------------
4958 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4960 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4961 return Is_Check_Suppressed
(E
, Overflow_Check
);
4963 return Scope_Suppress
(Overflow_Check
);
4965 end Overflow_Checks_Suppressed
;
4971 function Range_Check
4973 Target_Typ
: Entity_Id
;
4974 Source_Typ
: Entity_Id
:= Empty
;
4975 Warn_Node
: Node_Id
:= Empty
) return Check_Result
4978 return Selected_Range_Checks
4979 (Ck_Node
, Target_Typ
, Source_Typ
, Warn_Node
);
4982 -----------------------------
4983 -- Range_Checks_Suppressed --
4984 -----------------------------
4986 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4990 -- Note: for now we always suppress range checks on Vax float types,
4991 -- since Gigi does not know how to generate these checks.
4993 if Vax_Float
(E
) then
4995 elsif Kill_Range_Checks
(E
) then
4997 elsif Checks_May_Be_Suppressed
(E
) then
4998 return Is_Check_Suppressed
(E
, Range_Check
);
5002 return Scope_Suppress
(Range_Check
);
5003 end Range_Checks_Suppressed
;
5009 procedure Remove_Checks
(Expr
: Node_Id
) is
5010 Discard
: Traverse_Result
;
5011 pragma Warnings
(Off
, Discard
);
5013 function Process
(N
: Node_Id
) return Traverse_Result
;
5014 -- Process a single node during the traversal
5016 function Traverse
is new Traverse_Func
(Process
);
5017 -- The traversal function itself
5023 function Process
(N
: Node_Id
) return Traverse_Result
is
5025 if Nkind
(N
) not in N_Subexpr
then
5029 Set_Do_Range_Check
(N
, False);
5033 Discard
:= Traverse
(Left_Opnd
(N
));
5036 when N_Attribute_Reference
=>
5037 Set_Do_Overflow_Check
(N
, False);
5039 when N_Function_Call
=>
5040 Set_Do_Tag_Check
(N
, False);
5043 Set_Do_Overflow_Check
(N
, False);
5047 Set_Do_Division_Check
(N
, False);
5050 Set_Do_Length_Check
(N
, False);
5053 Set_Do_Division_Check
(N
, False);
5056 Set_Do_Length_Check
(N
, False);
5059 Set_Do_Division_Check
(N
, False);
5062 Set_Do_Length_Check
(N
, False);
5069 Discard
:= Traverse
(Left_Opnd
(N
));
5072 when N_Selected_Component
=>
5073 Set_Do_Discriminant_Check
(N
, False);
5075 when N_Type_Conversion
=>
5076 Set_Do_Length_Check
(N
, False);
5077 Set_Do_Tag_Check
(N
, False);
5078 Set_Do_Overflow_Check
(N
, False);
5087 -- Start of processing for Remove_Checks
5090 Discard
:= Traverse
(Expr
);
5093 ----------------------------
5094 -- Selected_Length_Checks --
5095 ----------------------------
5097 function Selected_Length_Checks
5099 Target_Typ
: Entity_Id
;
5100 Source_Typ
: Entity_Id
;
5101 Warn_Node
: Node_Id
) return Check_Result
5103 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
5106 Expr_Actual
: Node_Id
;
5108 Cond
: Node_Id
:= Empty
;
5109 Do_Access
: Boolean := False;
5110 Wnode
: Node_Id
:= Warn_Node
;
5111 Ret_Result
: Check_Result
:= (Empty
, Empty
);
5112 Num_Checks
: Natural := 0;
5114 procedure Add_Check
(N
: Node_Id
);
5115 -- Adds the action given to Ret_Result if N is non-Empty
5117 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
5118 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
5119 -- Comments required ???
5121 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
5122 -- True for equal literals and for nodes that denote the same constant
5123 -- entity, even if its value is not a static constant. This includes the
5124 -- case of a discriminal reference within an init proc. Removes some
5125 -- obviously superfluous checks.
5127 function Length_E_Cond
5128 (Exptyp
: Entity_Id
;
5130 Indx
: Nat
) return Node_Id
;
5131 -- Returns expression to compute:
5132 -- Typ'Length /= Exptyp'Length
5134 function Length_N_Cond
5137 Indx
: Nat
) return Node_Id
;
5138 -- Returns expression to compute:
5139 -- Typ'Length /= Expr'Length
5145 procedure Add_Check
(N
: Node_Id
) is
5149 -- For now, ignore attempt to place more than 2 checks ???
5151 if Num_Checks
= 2 then
5155 pragma Assert
(Num_Checks
<= 1);
5156 Num_Checks
:= Num_Checks
+ 1;
5157 Ret_Result
(Num_Checks
) := N
;
5165 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
5166 Pt
: constant Entity_Id
:= Scope
(Scope
(E
));
5168 E1
: Entity_Id
:= E
;
5171 if Ekind
(Scope
(E
)) = E_Record_Type
5172 and then Has_Discriminants
(Scope
(E
))
5174 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
5177 Insert_Action
(Ck_Node
, N
);
5178 E1
:= Defining_Identifier
(N
);
5182 if Ekind
(E1
) = E_String_Literal_Subtype
then
5184 Make_Integer_Literal
(Loc
,
5185 Intval
=> String_Literal_Length
(E1
));
5187 elsif Ekind
(Pt
) = E_Protected_Type
5188 and then Has_Discriminants
(Pt
)
5189 and then Has_Completion
(Pt
)
5190 and then not Inside_Init_Proc
5193 -- If the type whose length is needed is a private component
5194 -- constrained by a discriminant, we must expand the 'Length
5195 -- attribute into an explicit computation, using the discriminal
5196 -- of the current protected operation. This is because the actual
5197 -- type of the prival is constructed after the protected opera-
5198 -- tion has been fully expanded.
5201 Indx_Type
: Node_Id
;
5204 Do_Expand
: Boolean := False;
5207 Indx_Type
:= First_Index
(E
);
5209 for J
in 1 .. Indx
- 1 loop
5210 Next_Index
(Indx_Type
);
5213 Get_Index_Bounds
(Indx_Type
, Lo
, Hi
);
5215 if Nkind
(Lo
) = N_Identifier
5216 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
5218 Lo
:= Get_Discriminal
(E
, Lo
);
5222 if Nkind
(Hi
) = N_Identifier
5223 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
5225 Hi
:= Get_Discriminal
(E
, Hi
);
5230 if not Is_Entity_Name
(Lo
) then
5231 Lo
:= Duplicate_Subexpr_No_Checks
(Lo
);
5234 if not Is_Entity_Name
(Hi
) then
5235 Lo
:= Duplicate_Subexpr_No_Checks
(Hi
);
5241 Make_Op_Subtract
(Loc
,
5245 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
5250 Make_Attribute_Reference
(Loc
,
5251 Attribute_Name
=> Name_Length
,
5253 New_Occurrence_Of
(E1
, Loc
));
5256 Set_Expressions
(N
, New_List
(
5257 Make_Integer_Literal
(Loc
, Indx
)));
5266 Make_Attribute_Reference
(Loc
,
5267 Attribute_Name
=> Name_Length
,
5269 New_Occurrence_Of
(E1
, Loc
));
5272 Set_Expressions
(N
, New_List
(
5273 Make_Integer_Literal
(Loc
, Indx
)));
5285 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
5288 Make_Attribute_Reference
(Loc
,
5289 Attribute_Name
=> Name_Length
,
5291 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
5292 Expressions
=> New_List
(
5293 Make_Integer_Literal
(Loc
, Indx
)));
5301 function Length_E_Cond
5302 (Exptyp
: Entity_Id
;
5304 Indx
: Nat
) return Node_Id
5309 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
5310 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
5318 function Length_N_Cond
5321 Indx
: Nat
) return Node_Id
5326 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
5327 Right_Opnd
=> Get_N_Length
(Expr
, Indx
));
5331 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
5334 (Nkind
(L
) = N_Integer_Literal
5335 and then Nkind
(R
) = N_Integer_Literal
5336 and then Intval
(L
) = Intval
(R
))
5340 and then Ekind
(Entity
(L
)) = E_Constant
5341 and then ((Is_Entity_Name
(R
)
5342 and then Entity
(L
) = Entity
(R
))
5344 (Nkind
(R
) = N_Type_Conversion
5345 and then Is_Entity_Name
(Expression
(R
))
5346 and then Entity
(L
) = Entity
(Expression
(R
)))))
5350 and then Ekind
(Entity
(R
)) = E_Constant
5351 and then Nkind
(L
) = N_Type_Conversion
5352 and then Is_Entity_Name
(Expression
(L
))
5353 and then Entity
(R
) = Entity
(Expression
(L
)))
5357 and then Is_Entity_Name
(R
)
5358 and then Entity
(L
) = Entity
(R
)
5359 and then Ekind
(Entity
(L
)) = E_In_Parameter
5360 and then Inside_Init_Proc
);
5363 -- Start of processing for Selected_Length_Checks
5366 if not Expander_Active
then
5370 if Target_Typ
= Any_Type
5371 or else Target_Typ
= Any_Composite
5372 or else Raises_Constraint_Error
(Ck_Node
)
5381 T_Typ
:= Target_Typ
;
5383 if No
(Source_Typ
) then
5384 S_Typ
:= Etype
(Ck_Node
);
5386 S_Typ
:= Source_Typ
;
5389 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
5393 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
5394 S_Typ
:= Designated_Type
(S_Typ
);
5395 T_Typ
:= Designated_Type
(T_Typ
);
5398 -- A simple optimization
5400 if Nkind
(Ck_Node
) = N_Null
then
5405 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
5406 if Is_Constrained
(T_Typ
) then
5408 -- The checking code to be generated will freeze the
5409 -- corresponding array type. However, we must freeze the
5410 -- type now, so that the freeze node does not appear within
5411 -- the generated condional expression, but ahead of it.
5413 Freeze_Before
(Ck_Node
, T_Typ
);
5415 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
5416 Exptyp
:= Get_Actual_Subtype
(Ck_Node
);
5418 if Is_Access_Type
(Exptyp
) then
5419 Exptyp
:= Designated_Type
(Exptyp
);
5422 -- String_Literal case. This needs to be handled specially be-
5423 -- cause no index types are available for string literals. The
5424 -- condition is simply:
5426 -- T_Typ'Length = string-literal-length
5428 if Nkind
(Expr_Actual
) = N_String_Literal
5429 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
5433 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
5435 Make_Integer_Literal
(Loc
,
5437 String_Literal_Length
(Etype
(Expr_Actual
))));
5439 -- General array case. Here we have a usable actual subtype for
5440 -- the expression, and the condition is built from the two types
5443 -- T_Typ'Length /= Exptyp'Length or else
5444 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
5445 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
5448 elsif Is_Constrained
(Exptyp
) then
5450 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
5464 -- At the library level, we need to ensure that the
5465 -- type of the object is elaborated before the check
5466 -- itself is emitted. This is only done if the object
5467 -- is in the current compilation unit, otherwise the
5468 -- type is frozen and elaborated in its unit.
5470 if Is_Itype
(Exptyp
)
5472 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
5474 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
5475 and then In_Open_Scopes
(Scope
(Exptyp
))
5477 Ref_Node
:= Make_Itype_Reference
(Sloc
(Ck_Node
));
5478 Set_Itype
(Ref_Node
, Exptyp
);
5479 Insert_Action
(Ck_Node
, Ref_Node
);
5482 L_Index
:= First_Index
(T_Typ
);
5483 R_Index
:= First_Index
(Exptyp
);
5485 for Indx
in 1 .. Ndims
loop
5486 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
5488 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
5490 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
5491 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
5493 -- Deal with compile time length check. Note that we
5494 -- skip this in the access case, because the access
5495 -- value may be null, so we cannot know statically.
5498 and then Compile_Time_Known_Value
(L_Low
)
5499 and then Compile_Time_Known_Value
(L_High
)
5500 and then Compile_Time_Known_Value
(R_Low
)
5501 and then Compile_Time_Known_Value
(R_High
)
5503 if Expr_Value
(L_High
) >= Expr_Value
(L_Low
) then
5504 L_Length
:= Expr_Value
(L_High
) -
5505 Expr_Value
(L_Low
) + 1;
5507 L_Length
:= UI_From_Int
(0);
5510 if Expr_Value
(R_High
) >= Expr_Value
(R_Low
) then
5511 R_Length
:= Expr_Value
(R_High
) -
5512 Expr_Value
(R_Low
) + 1;
5514 R_Length
:= UI_From_Int
(0);
5517 if L_Length
> R_Length
then
5519 (Compile_Time_Constraint_Error
5520 (Wnode
, "too few elements for}?", T_Typ
));
5522 elsif L_Length
< R_Length
then
5524 (Compile_Time_Constraint_Error
5525 (Wnode
, "too many elements for}?", T_Typ
));
5528 -- The comparison for an individual index subtype
5529 -- is omitted if the corresponding index subtypes
5530 -- statically match, since the result is known to
5531 -- be true. Note that this test is worth while even
5532 -- though we do static evaluation, because non-static
5533 -- subtypes can statically match.
5536 Subtypes_Statically_Match
5537 (Etype
(L_Index
), Etype
(R_Index
))
5540 (Same_Bounds
(L_Low
, R_Low
)
5541 and then Same_Bounds
(L_High
, R_High
))
5544 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
5553 -- Handle cases where we do not get a usable actual subtype that
5554 -- is constrained. This happens for example in the function call
5555 -- and explicit dereference cases. In these cases, we have to get
5556 -- the length or range from the expression itself, making sure we
5557 -- do not evaluate it more than once.
5559 -- Here Ck_Node is the original expression, or more properly the
5560 -- result of applying Duplicate_Expr to the original tree,
5561 -- forcing the result to be a name.
5565 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
5568 -- Build the condition for the explicit dereference case
5570 for Indx
in 1 .. Ndims
loop
5572 (Cond
, Length_N_Cond
(Ck_Node
, T_Typ
, Indx
));
5579 -- Construct the test and insert into the tree
5581 if Present
(Cond
) then
5583 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
5587 (Make_Raise_Constraint_Error
(Loc
,
5589 Reason
=> CE_Length_Check_Failed
));
5593 end Selected_Length_Checks
;
5595 ---------------------------
5596 -- Selected_Range_Checks --
5597 ---------------------------
5599 function Selected_Range_Checks
5601 Target_Typ
: Entity_Id
;
5602 Source_Typ
: Entity_Id
;
5603 Warn_Node
: Node_Id
) return Check_Result
5605 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
5608 Expr_Actual
: Node_Id
;
5610 Cond
: Node_Id
:= Empty
;
5611 Do_Access
: Boolean := False;
5612 Wnode
: Node_Id
:= Warn_Node
;
5613 Ret_Result
: Check_Result
:= (Empty
, Empty
);
5614 Num_Checks
: Integer := 0;
5616 procedure Add_Check
(N
: Node_Id
);
5617 -- Adds the action given to Ret_Result if N is non-Empty
5619 function Discrete_Range_Cond
5621 Typ
: Entity_Id
) return Node_Id
;
5622 -- Returns expression to compute:
5623 -- Low_Bound (Expr) < Typ'First
5625 -- High_Bound (Expr) > Typ'Last
5627 function Discrete_Expr_Cond
5629 Typ
: Entity_Id
) return Node_Id
;
5630 -- Returns expression to compute:
5635 function Get_E_First_Or_Last
5638 Nam
: Name_Id
) return Node_Id
;
5639 -- Returns expression to compute:
5640 -- E'First or E'Last
5642 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
5643 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
5644 -- Returns expression to compute:
5645 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
5647 function Range_E_Cond
5648 (Exptyp
: Entity_Id
;
5652 -- Returns expression to compute:
5653 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
5655 function Range_Equal_E_Cond
5656 (Exptyp
: Entity_Id
;
5658 Indx
: Nat
) return Node_Id
;
5659 -- Returns expression to compute:
5660 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
5662 function Range_N_Cond
5665 Indx
: Nat
) return Node_Id
;
5666 -- Return expression to compute:
5667 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
5673 procedure Add_Check
(N
: Node_Id
) is
5677 -- For now, ignore attempt to place more than 2 checks ???
5679 if Num_Checks
= 2 then
5683 pragma Assert
(Num_Checks
<= 1);
5684 Num_Checks
:= Num_Checks
+ 1;
5685 Ret_Result
(Num_Checks
) := N
;
5689 -------------------------
5690 -- Discrete_Expr_Cond --
5691 -------------------------
5693 function Discrete_Expr_Cond
5695 Typ
: Entity_Id
) return Node_Id
5703 Convert_To
(Base_Type
(Typ
),
5704 Duplicate_Subexpr_No_Checks
(Expr
)),
5706 Convert_To
(Base_Type
(Typ
),
5707 Get_E_First_Or_Last
(Typ
, 0, Name_First
))),
5712 Convert_To
(Base_Type
(Typ
),
5713 Duplicate_Subexpr_No_Checks
(Expr
)),
5717 Get_E_First_Or_Last
(Typ
, 0, Name_Last
))));
5718 end Discrete_Expr_Cond
;
5720 -------------------------
5721 -- Discrete_Range_Cond --
5722 -------------------------
5724 function Discrete_Range_Cond
5726 Typ
: Entity_Id
) return Node_Id
5728 LB
: Node_Id
:= Low_Bound
(Expr
);
5729 HB
: Node_Id
:= High_Bound
(Expr
);
5731 Left_Opnd
: Node_Id
;
5732 Right_Opnd
: Node_Id
;
5735 if Nkind
(LB
) = N_Identifier
5736 and then Ekind
(Entity
(LB
)) = E_Discriminant
then
5737 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
5740 if Nkind
(HB
) = N_Identifier
5741 and then Ekind
(Entity
(HB
)) = E_Discriminant
then
5742 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
5749 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
5753 (Base_Type
(Typ
), Get_E_First_Or_Last
(Typ
, 0, Name_First
)));
5755 if Base_Type
(Typ
) = Typ
then
5758 elsif Compile_Time_Known_Value
(High_Bound
(Scalar_Range
(Typ
)))
5760 Compile_Time_Known_Value
(High_Bound
(Scalar_Range
5763 if Is_Floating_Point_Type
(Typ
) then
5764 if Expr_Value_R
(High_Bound
(Scalar_Range
(Typ
))) =
5765 Expr_Value_R
(High_Bound
(Scalar_Range
(Base_Type
(Typ
))))
5771 if Expr_Value
(High_Bound
(Scalar_Range
(Typ
))) =
5772 Expr_Value
(High_Bound
(Scalar_Range
(Base_Type
(Typ
))))
5783 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
5788 Get_E_First_Or_Last
(Typ
, 0, Name_Last
)));
5790 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
5791 end Discrete_Range_Cond
;
5793 -------------------------
5794 -- Get_E_First_Or_Last --
5795 -------------------------
5797 function Get_E_First_Or_Last
5800 Nam
: Name_Id
) return Node_Id
5808 if Is_Array_Type
(E
) then
5809 N
:= First_Index
(E
);
5811 for J
in 2 .. Indx
loop
5816 N
:= Scalar_Range
(E
);
5819 if Nkind
(N
) = N_Subtype_Indication
then
5820 LB
:= Low_Bound
(Range_Expression
(Constraint
(N
)));
5821 HB
:= High_Bound
(Range_Expression
(Constraint
(N
)));
5823 elsif Is_Entity_Name
(N
) then
5824 LB
:= Type_Low_Bound
(Etype
(N
));
5825 HB
:= Type_High_Bound
(Etype
(N
));
5828 LB
:= Low_Bound
(N
);
5829 HB
:= High_Bound
(N
);
5832 if Nam
= Name_First
then
5838 if Nkind
(Bound
) = N_Identifier
5839 and then Ekind
(Entity
(Bound
)) = E_Discriminant
5841 -- If this is a task discriminant, and we are the body, we must
5842 -- retrieve the corresponding body discriminal. This is another
5843 -- consequence of the early creation of discriminals, and the
5844 -- need to generate constraint checks before their declarations
5845 -- are made visible.
5847 if Is_Concurrent_Record_Type
(Scope
(Entity
(Bound
))) then
5849 Tsk
: constant Entity_Id
:=
5850 Corresponding_Concurrent_Type
5851 (Scope
(Entity
(Bound
)));
5855 if In_Open_Scopes
(Tsk
)
5856 and then Has_Completion
(Tsk
)
5858 -- Find discriminant of original task, and use its
5859 -- current discriminal, which is the renaming within
5862 Disc
:= First_Discriminant
(Tsk
);
5863 while Present
(Disc
) loop
5864 if Chars
(Disc
) = Chars
(Entity
(Bound
)) then
5865 Set_Scope
(Discriminal
(Disc
), Tsk
);
5866 return New_Occurrence_Of
(Discriminal
(Disc
), Loc
);
5869 Next_Discriminant
(Disc
);
5872 -- That loop should always succeed in finding a matching
5873 -- entry and returning. Fatal error if not.
5875 raise Program_Error
;
5879 New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
5883 return New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
5886 elsif Nkind
(Bound
) = N_Identifier
5887 and then Ekind
(Entity
(Bound
)) = E_In_Parameter
5888 and then not Inside_Init_Proc
5890 return Get_Discriminal
(E
, Bound
);
5892 elsif Nkind
(Bound
) = N_Integer_Literal
then
5893 return Make_Integer_Literal
(Loc
, Intval
(Bound
));
5895 -- Case of a bound that has been rewritten to an
5896 -- N_Raise_Constraint_Error node because it is an out-of-range
5897 -- value. We may not call Duplicate_Subexpr on this node because
5898 -- an N_Raise_Constraint_Error is not side effect free, and we may
5899 -- not assume that we are in the proper context to remove side
5900 -- effects on it at the point of reference.
5902 elsif Nkind
(Bound
) = N_Raise_Constraint_Error
then
5903 return New_Copy_Tree
(Bound
);
5906 return Duplicate_Subexpr_No_Checks
(Bound
);
5908 end Get_E_First_Or_Last
;
5914 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
5917 Make_Attribute_Reference
(Loc
,
5918 Attribute_Name
=> Name_First
,
5920 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
5921 Expressions
=> New_List
(
5922 Make_Integer_Literal
(Loc
, Indx
)));
5929 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
5932 Make_Attribute_Reference
(Loc
,
5933 Attribute_Name
=> Name_Last
,
5935 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
5936 Expressions
=> New_List
(
5937 Make_Integer_Literal
(Loc
, Indx
)));
5944 function Range_E_Cond
5945 (Exptyp
: Entity_Id
;
5947 Indx
: Nat
) return Node_Id
5954 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_First
),
5955 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_First
)),
5959 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_Last
),
5960 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_Last
)));
5964 ------------------------
5965 -- Range_Equal_E_Cond --
5966 ------------------------
5968 function Range_Equal_E_Cond
5969 (Exptyp
: Entity_Id
;
5971 Indx
: Nat
) return Node_Id
5978 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_First
),
5979 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_First
)),
5982 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_Last
),
5983 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_Last
)));
5984 end Range_Equal_E_Cond
;
5990 function Range_N_Cond
5993 Indx
: Nat
) return Node_Id
6000 Left_Opnd
=> Get_N_First
(Expr
, Indx
),
6001 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_First
)),
6005 Left_Opnd
=> Get_N_Last
(Expr
, Indx
),
6006 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_Last
)));
6009 -- Start of processing for Selected_Range_Checks
6012 if not Expander_Active
then
6016 if Target_Typ
= Any_Type
6017 or else Target_Typ
= Any_Composite
6018 or else Raises_Constraint_Error
(Ck_Node
)
6027 T_Typ
:= Target_Typ
;
6029 if No
(Source_Typ
) then
6030 S_Typ
:= Etype
(Ck_Node
);
6032 S_Typ
:= Source_Typ
;
6035 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
6039 -- The order of evaluating T_Typ before S_Typ seems to be critical
6040 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
6041 -- in, and since Node can be an N_Range node, it might be invalid.
6042 -- Should there be an assert check somewhere for taking the Etype of
6043 -- an N_Range node ???
6045 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
6046 S_Typ
:= Designated_Type
(S_Typ
);
6047 T_Typ
:= Designated_Type
(T_Typ
);
6050 -- A simple optimization
6052 if Nkind
(Ck_Node
) = N_Null
then
6057 -- For an N_Range Node, check for a null range and then if not
6058 -- null generate a range check action.
6060 if Nkind
(Ck_Node
) = N_Range
then
6062 -- There's no point in checking a range against itself
6064 if Ck_Node
= Scalar_Range
(T_Typ
) then
6069 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
6070 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
6071 LB
: constant Node_Id
:= Low_Bound
(Ck_Node
);
6072 HB
: constant Node_Id
:= High_Bound
(Ck_Node
);
6073 Null_Range
: Boolean;
6075 Out_Of_Range_L
: Boolean;
6076 Out_Of_Range_H
: Boolean;
6079 -- Check for case where everything is static and we can
6080 -- do the check at compile time. This is skipped if we
6081 -- have an access type, since the access value may be null.
6083 -- ??? This code can be improved since you only need to know
6084 -- that the two respective bounds (LB & T_LB or HB & T_HB)
6085 -- are known at compile time to emit pertinent messages.
6087 if Compile_Time_Known_Value
(LB
)
6088 and then Compile_Time_Known_Value
(HB
)
6089 and then Compile_Time_Known_Value
(T_LB
)
6090 and then Compile_Time_Known_Value
(T_HB
)
6091 and then not Do_Access
6093 -- Floating-point case
6095 if Is_Floating_Point_Type
(S_Typ
) then
6096 Null_Range
:= Expr_Value_R
(HB
) < Expr_Value_R
(LB
);
6098 (Expr_Value_R
(LB
) < Expr_Value_R
(T_LB
))
6100 (Expr_Value_R
(LB
) > Expr_Value_R
(T_HB
));
6103 (Expr_Value_R
(HB
) > Expr_Value_R
(T_HB
))
6105 (Expr_Value_R
(HB
) < Expr_Value_R
(T_LB
));
6107 -- Fixed or discrete type case
6110 Null_Range
:= Expr_Value
(HB
) < Expr_Value
(LB
);
6112 (Expr_Value
(LB
) < Expr_Value
(T_LB
))
6114 (Expr_Value
(LB
) > Expr_Value
(T_HB
));
6117 (Expr_Value
(HB
) > Expr_Value
(T_HB
))
6119 (Expr_Value
(HB
) < Expr_Value
(T_LB
));
6122 if not Null_Range
then
6123 if Out_Of_Range_L
then
6124 if No
(Warn_Node
) then
6126 (Compile_Time_Constraint_Error
6127 (Low_Bound
(Ck_Node
),
6128 "static value out of range of}?", T_Typ
));
6132 (Compile_Time_Constraint_Error
6134 "static range out of bounds of}?", T_Typ
));
6138 if Out_Of_Range_H
then
6139 if No
(Warn_Node
) then
6141 (Compile_Time_Constraint_Error
6142 (High_Bound
(Ck_Node
),
6143 "static value out of range of}?", T_Typ
));
6147 (Compile_Time_Constraint_Error
6149 "static range out of bounds of}?", T_Typ
));
6157 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
6158 HB
: Node_Id
:= High_Bound
(Ck_Node
);
6162 -- If either bound is a discriminant and we are within
6163 -- the record declaration, it is a use of the discriminant
6164 -- in a constraint of a component, and nothing can be
6165 -- checked here. The check will be emitted within the
6166 -- init proc. Before then, the discriminal has no real
6169 if Nkind
(LB
) = N_Identifier
6170 and then Ekind
(Entity
(LB
)) = E_Discriminant
6172 if Current_Scope
= Scope
(Entity
(LB
)) then
6176 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
6180 if Nkind
(HB
) = N_Identifier
6181 and then Ekind
(Entity
(HB
)) = E_Discriminant
6183 if Current_Scope
= Scope
(Entity
(HB
)) then
6187 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
6191 Cond
:= Discrete_Range_Cond
(Ck_Node
, T_Typ
);
6192 Set_Paren_Count
(Cond
, 1);
6198 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(HB
),
6199 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(LB
)),
6200 Right_Opnd
=> Cond
);
6206 elsif Is_Scalar_Type
(S_Typ
) then
6208 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
6209 -- except the above simply sets a flag in the node and lets
6210 -- gigi generate the check base on the Etype of the expression.
6211 -- Sometimes, however we want to do a dynamic check against an
6212 -- arbitrary target type, so we do that here.
6214 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
6215 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
6217 -- For literals, we can tell if the constraint error will be
6218 -- raised at compile time, so we never need a dynamic check, but
6219 -- if the exception will be raised, then post the usual warning,
6220 -- and replace the literal with a raise constraint error
6221 -- expression. As usual, skip this for access types
6223 elsif Compile_Time_Known_Value
(Ck_Node
)
6224 and then not Do_Access
6227 LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
6228 UB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
6230 Out_Of_Range
: Boolean;
6231 Static_Bounds
: constant Boolean :=
6232 Compile_Time_Known_Value
(LB
)
6233 and Compile_Time_Known_Value
(UB
);
6236 -- Following range tests should use Sem_Eval routine ???
6238 if Static_Bounds
then
6239 if Is_Floating_Point_Type
(S_Typ
) then
6241 (Expr_Value_R
(Ck_Node
) < Expr_Value_R
(LB
))
6243 (Expr_Value_R
(Ck_Node
) > Expr_Value_R
(UB
));
6245 else -- fixed or discrete type
6247 Expr_Value
(Ck_Node
) < Expr_Value
(LB
)
6249 Expr_Value
(Ck_Node
) > Expr_Value
(UB
);
6252 -- Bounds of the type are static and the literal is
6253 -- out of range so make a warning message.
6255 if Out_Of_Range
then
6256 if No
(Warn_Node
) then
6258 (Compile_Time_Constraint_Error
6260 "static value out of range of}?", T_Typ
));
6264 (Compile_Time_Constraint_Error
6266 "static value out of range of}?", T_Typ
));
6271 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
6275 -- Here for the case of a non-static expression, we need a runtime
6276 -- check unless the source type range is guaranteed to be in the
6277 -- range of the target type.
6280 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
6281 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
6286 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
6287 if Is_Constrained
(T_Typ
) then
6289 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
6290 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
6292 if Is_Access_Type
(Exptyp
) then
6293 Exptyp
:= Designated_Type
(Exptyp
);
6296 -- String_Literal case. This needs to be handled specially be-
6297 -- cause no index types are available for string literals. The
6298 -- condition is simply:
6300 -- T_Typ'Length = string-literal-length
6302 if Nkind
(Expr_Actual
) = N_String_Literal
then
6305 -- General array case. Here we have a usable actual subtype for
6306 -- the expression, and the condition is built from the two types
6308 -- T_Typ'First < Exptyp'First or else
6309 -- T_Typ'Last > Exptyp'Last or else
6310 -- T_Typ'First(1) < Exptyp'First(1) or else
6311 -- T_Typ'Last(1) > Exptyp'Last(1) or else
6314 elsif Is_Constrained
(Exptyp
) then
6316 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
6326 L_Index
:= First_Index
(T_Typ
);
6327 R_Index
:= First_Index
(Exptyp
);
6329 for Indx
in 1 .. Ndims
loop
6330 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
6332 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
6334 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
6335 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
6337 -- Deal with compile time length check. Note that we
6338 -- skip this in the access case, because the access
6339 -- value may be null, so we cannot know statically.
6342 Subtypes_Statically_Match
6343 (Etype
(L_Index
), Etype
(R_Index
))
6345 -- If the target type is constrained then we
6346 -- have to check for exact equality of bounds
6347 -- (required for qualified expressions).
6349 if Is_Constrained
(T_Typ
) then
6352 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
6356 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
6367 -- Handle cases where we do not get a usable actual subtype that
6368 -- is constrained. This happens for example in the function call
6369 -- and explicit dereference cases. In these cases, we have to get
6370 -- the length or range from the expression itself, making sure we
6371 -- do not evaluate it more than once.
6373 -- Here Ck_Node is the original expression, or more properly the
6374 -- result of applying Duplicate_Expr to the original tree,
6375 -- forcing the result to be a name.
6379 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
6382 -- Build the condition for the explicit dereference case
6384 for Indx
in 1 .. Ndims
loop
6386 (Cond
, Range_N_Cond
(Ck_Node
, T_Typ
, Indx
));
6393 -- Generate an Action to check that the bounds of the
6394 -- source value are within the constraints imposed by the
6395 -- target type for a conversion to an unconstrained type.
6398 if Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
then
6400 Opnd_Index
: Node_Id
;
6401 Targ_Index
: Node_Id
;
6405 := First_Index
(Get_Actual_Subtype
(Ck_Node
));
6406 Targ_Index
:= First_Index
(T_Typ
);
6408 while Opnd_Index
/= Empty
loop
6409 if Nkind
(Opnd_Index
) = N_Range
then
6411 (Low_Bound
(Opnd_Index
), Etype
(Targ_Index
))
6414 (High_Bound
(Opnd_Index
), Etype
(Targ_Index
))
6418 -- If null range, no check needed
6421 Compile_Time_Known_Value
(High_Bound
(Opnd_Index
))
6423 Compile_Time_Known_Value
(Low_Bound
(Opnd_Index
))
6425 Expr_Value
(High_Bound
(Opnd_Index
)) <
6426 Expr_Value
(Low_Bound
(Opnd_Index
))
6430 elsif Is_Out_Of_Range
6431 (Low_Bound
(Opnd_Index
), Etype
(Targ_Index
))
6434 (High_Bound
(Opnd_Index
), Etype
(Targ_Index
))
6437 (Compile_Time_Constraint_Error
6438 (Wnode
, "value out of range of}?", T_Typ
));
6444 (Opnd_Index
, Etype
(Targ_Index
)));
6448 Next_Index
(Opnd_Index
);
6449 Next_Index
(Targ_Index
);
6456 -- Construct the test and insert into the tree
6458 if Present
(Cond
) then
6460 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
6464 (Make_Raise_Constraint_Error
(Loc
,
6466 Reason
=> CE_Range_Check_Failed
));
6470 end Selected_Range_Checks
;
6472 -------------------------------
6473 -- Storage_Checks_Suppressed --
6474 -------------------------------
6476 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6478 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
6479 return Is_Check_Suppressed
(E
, Storage_Check
);
6481 return Scope_Suppress
(Storage_Check
);
6483 end Storage_Checks_Suppressed
;
6485 ---------------------------
6486 -- Tag_Checks_Suppressed --
6487 ---------------------------
6489 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
6492 if Kill_Tag_Checks
(E
) then
6494 elsif Checks_May_Be_Suppressed
(E
) then
6495 return Is_Check_Suppressed
(E
, Tag_Check
);
6499 return Scope_Suppress
(Tag_Check
);
6500 end Tag_Checks_Suppressed
;