1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2003 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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_Util
; use Exp_Util
;
33 with Elists
; use Elists
;
34 with Freeze
; use Freeze
;
36 with Nlists
; use Nlists
;
37 with Nmake
; use Nmake
;
39 with Output
; use Output
;
40 with Restrict
; use Restrict
;
41 with Rtsfind
; use Rtsfind
;
43 with Sem_Eval
; use Sem_Eval
;
44 with Sem_Ch8
; use Sem_Ch8
;
45 with Sem_Res
; use Sem_Res
;
46 with Sem_Util
; use Sem_Util
;
47 with Sem_Warn
; use Sem_Warn
;
48 with Sinfo
; use Sinfo
;
49 with Sinput
; use Sinput
;
50 with Snames
; use Snames
;
51 with Sprint
; use Sprint
;
52 with Stand
; use Stand
;
53 with Targparm
; use Targparm
;
54 with Tbuild
; use Tbuild
;
55 with Ttypes
; use Ttypes
;
56 with Urealp
; use Urealp
;
57 with Validsw
; use Validsw
;
59 package body Checks
is
61 -- General note: many of these routines are concerned with generating
62 -- checking code to make sure that constraint error is raised at runtime.
63 -- Clearly this code is only needed if the expander is active, since
64 -- otherwise we will not be generating code or going into the runtime
67 -- We therefore disconnect most of these checks if the expander is
68 -- inactive. This has the additional benefit that we do not need to
69 -- worry about the tree being messed up by previous errors (since errors
70 -- turn off expansion anyway).
72 -- There are a few exceptions to the above rule. For instance routines
73 -- such as Apply_Scalar_Range_Check that do not insert any code can be
74 -- safely called even when the Expander is inactive (but Errors_Detected
75 -- is 0). The benefit of executing this code when expansion is off, is
76 -- the ability to emit constraint error warning for static expressions
77 -- even when we are not generating code.
79 -------------------------------------
80 -- Suppression of Redundant Checks --
81 -------------------------------------
83 -- This unit implements a limited circuit for removal of redundant
84 -- checks. The processing is based on a tracing of simple sequential
85 -- flow. For any sequence of statements, we save expressions that are
86 -- marked to be checked, and then if the same expression appears later
87 -- with the same check, then under certain circumstances, the second
88 -- check can be suppressed.
90 -- Basically, we can suppress the check if we know for certain that
91 -- the previous expression has been elaborated (together with its
92 -- check), and we know that the exception frame is the same, and that
93 -- nothing has happened to change the result of the exception.
95 -- Let us examine each of these three conditions in turn to describe
96 -- how we ensure that this condition is met.
98 -- First, we need to know for certain that the previous expression has
99 -- been executed. This is done principly by the mechanism of calling
100 -- Conditional_Statements_Begin at the start of any statement sequence
101 -- and Conditional_Statements_End at the end. The End call causes all
102 -- checks remembered since the Begin call to be discarded. This does
103 -- miss a few cases, notably the case of a nested BEGIN-END block with
104 -- no exception handlers. But the important thing is to be conservative.
105 -- The other protection is that all checks are discarded if a label
106 -- is encountered, since then the assumption of sequential execution
107 -- is violated, and we don't know enough about the flow.
109 -- Second, we need to know that the exception frame is the same. We
110 -- do this by killing all remembered checks when we enter a new frame.
111 -- Again, that's over-conservative, but generally the cases we can help
112 -- with are pretty local anyway (like the body of a loop for example).
114 -- Third, we must be sure to forget any checks which are no longer valid.
115 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
116 -- used to note any changes to local variables. We only attempt to deal
117 -- with checks involving local variables, so we do not need to worry
118 -- about global variables. Second, a call to any non-global procedure
119 -- causes us to abandon all stored checks, since such a all may affect
120 -- the values of any local variables.
122 -- The following define the data structures used to deal with remembering
123 -- checks so that redundant checks can be eliminated as described above.
125 -- Right now, the only expressions that we deal with are of the form of
126 -- simple local objects (either declared locally, or IN parameters) or
127 -- such objects plus/minus a compile time known constant. We can do
128 -- more later on if it seems worthwhile, but this catches many simple
129 -- cases in practice.
131 -- The following record type reflects a single saved check. An entry
132 -- is made in the stack of saved checks if and only if the expression
133 -- has been elaborated with the indicated checks.
135 type Saved_Check
is record
137 -- Set True if entry is killed by Kill_Checks
140 -- The entity involved in the expression that is checked
143 -- A compile time value indicating the result of adding or
144 -- subtracting a compile time value. This value is to be
145 -- added to the value of the Entity. A value of zero is
146 -- used for the case of a simple entity reference.
148 Check_Type
: Character;
149 -- This is set to 'R' for a range check (in which case Target_Type
150 -- is set to the target type for the range check) or to 'O' for an
151 -- overflow check (in which case Target_Type is set to Empty).
153 Target_Type
: Entity_Id
;
154 -- Used only if Do_Range_Check is set. Records the target type for
155 -- the check. We need this, because a check is a duplicate only if
156 -- it has a the same target type (or more accurately one with a
157 -- range that is smaller or equal to the stored target type of a
161 -- The following table keeps track of saved checks. Rather than use an
162 -- extensible table. We just use a table of fixed size, and we discard
163 -- any saved checks that do not fit. That's very unlikely to happen and
164 -- this is only an optimization in any case.
166 Saved_Checks
: array (Int
range 1 .. 200) of Saved_Check
;
167 -- Array of saved checks
169 Num_Saved_Checks
: Nat
:= 0;
170 -- Number of saved checks
172 -- The following stack keeps track of statement ranges. It is treated
173 -- as a stack. When Conditional_Statements_Begin is called, an entry
174 -- is pushed onto this stack containing the value of Num_Saved_Checks
175 -- at the time of the call. Then when Conditional_Statements_End is
176 -- called, this value is popped off and used to reset Num_Saved_Checks.
178 -- Note: again, this is a fixed length stack with a size that should
179 -- always be fine. If the value of the stack pointer goes above the
180 -- limit, then we just forget all saved checks.
182 Saved_Checks_Stack
: array (Int
range 1 .. 100) of Nat
;
183 Saved_Checks_TOS
: Nat
:= 0;
185 -----------------------
186 -- Local Subprograms --
187 -----------------------
189 procedure Apply_Selected_Length_Checks
191 Target_Typ
: Entity_Id
;
192 Source_Typ
: Entity_Id
;
193 Do_Static
: Boolean);
194 -- This is the subprogram that does all the work for Apply_Length_Check
195 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
196 -- described for the above routines. The Do_Static flag indicates that
197 -- only a static check is to be done.
199 procedure Apply_Selected_Range_Checks
201 Target_Typ
: Entity_Id
;
202 Source_Typ
: Entity_Id
;
203 Do_Static
: Boolean);
204 -- This is the subprogram that does all the work for Apply_Range_Check.
205 -- Expr, Target_Typ and Source_Typ are as described for the above
206 -- routine. The Do_Static flag indicates that only a static check is
211 Check_Type
: Character;
212 Target_Type
: Entity_Id
;
213 Entry_OK
: out Boolean;
217 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
218 -- to see if a check is of the form for optimization, and if so, to see
219 -- if it has already been performed. Expr is the expression to check,
220 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
221 -- Target_Type is the target type for a range check, and Empty for an
222 -- overflow check. If the entry is not of the form for optimization,
223 -- then Entry_OK is set to False, and the remaining out parameters
224 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
225 -- entity and offset from the expression. Check_Num is the number of
226 -- a matching saved entry in Saved_Checks, or zero if no such entry
229 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
;
230 -- If a discriminal is used in constraining a prival, Return reference
231 -- to the discriminal of the protected body (which renames the parameter
232 -- of the enclosing protected operation). This clumsy transformation is
233 -- needed because privals are created too late and their actual subtypes
234 -- are not available when analysing the bodies of the protected operations.
235 -- To be cleaned up???
237 function Guard_Access
242 -- In the access type case, guard the test with a test to ensure
243 -- that the access value is non-null, since the checks do not
244 -- not apply to null access values.
246 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
);
247 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
248 -- Constraint_Error node.
250 function Selected_Length_Checks
252 Target_Typ
: Entity_Id
;
253 Source_Typ
: Entity_Id
;
256 -- Like Apply_Selected_Length_Checks, except it doesn't modify
257 -- anything, just returns a list of nodes as described in the spec of
258 -- this package for the Range_Check function.
260 function Selected_Range_Checks
262 Target_Typ
: Entity_Id
;
263 Source_Typ
: Entity_Id
;
266 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
267 -- just returns a list of nodes as described in the spec of this package
268 -- for the Range_Check function.
270 ------------------------------
271 -- Access_Checks_Suppressed --
272 ------------------------------
274 function Access_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
276 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
277 return Is_Check_Suppressed
(E
, Access_Check
);
279 return Scope_Suppress
(Access_Check
);
281 end Access_Checks_Suppressed
;
283 -------------------------------------
284 -- Accessibility_Checks_Suppressed --
285 -------------------------------------
287 function Accessibility_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
289 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
290 return Is_Check_Suppressed
(E
, Accessibility_Check
);
292 return Scope_Suppress
(Accessibility_Check
);
294 end Accessibility_Checks_Suppressed
;
296 -------------------------
297 -- Append_Range_Checks --
298 -------------------------
300 procedure Append_Range_Checks
301 (Checks
: Check_Result
;
303 Suppress_Typ
: Entity_Id
;
304 Static_Sloc
: Source_Ptr
;
307 Internal_Flag_Node
: constant Node_Id
:= Flag_Node
;
308 Internal_Static_Sloc
: constant Source_Ptr
:= Static_Sloc
;
310 Checks_On
: constant Boolean :=
311 (not Index_Checks_Suppressed
(Suppress_Typ
))
313 (not Range_Checks_Suppressed
(Suppress_Typ
));
316 -- For now we just return if Checks_On is false, however this should
317 -- be enhanced to check for an always True value in the condition
318 -- and to generate a compilation warning???
320 if not Checks_On
then
325 exit when No
(Checks
(J
));
327 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
328 and then Present
(Condition
(Checks
(J
)))
330 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
331 Append_To
(Stmts
, Checks
(J
));
332 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
338 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
339 Reason
=> CE_Range_Check_Failed
));
342 end Append_Range_Checks
;
344 ------------------------
345 -- Apply_Access_Check --
346 ------------------------
348 procedure Apply_Access_Check
(N
: Node_Id
) is
349 P
: constant Node_Id
:= Prefix
(N
);
352 if Inside_A_Generic
then
356 if Is_Entity_Name
(P
) then
357 Check_Unset_Reference
(P
);
360 -- Don't need access check if prefix is known to be non-null
362 if Known_Non_Null
(P
) then
365 -- Don't need access checks if they are suppressed on the type
367 elsif Access_Checks_Suppressed
(Etype
(P
)) then
371 -- Case where P is an entity name
373 if Is_Entity_Name
(P
) then
375 Ent
: constant Entity_Id
:= Entity
(P
);
378 if Access_Checks_Suppressed
(Ent
) then
382 -- Otherwise we are going to generate an access check, and
383 -- are we have done it, the entity will now be known non null
384 -- But we have to check for safe sequential semantics here!
386 if Safe_To_Capture_Value
(N
, Ent
) then
387 Set_Is_Known_Non_Null
(Ent
);
392 -- Access check is required
395 Loc
: constant Source_Ptr
:= Sloc
(N
);
399 Make_Raise_Constraint_Error
(Sloc
(N
),
402 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(P
),
405 Reason
=> CE_Access_Check_Failed
));
407 end Apply_Access_Check
;
409 -------------------------------
410 -- Apply_Accessibility_Check --
411 -------------------------------
413 procedure Apply_Accessibility_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
414 Loc
: constant Source_Ptr
:= Sloc
(N
);
415 Param_Ent
: constant Entity_Id
:= Param_Entity
(N
);
416 Param_Level
: Node_Id
;
417 Type_Level
: Node_Id
;
420 if Inside_A_Generic
then
423 -- Only apply the run-time check if the access parameter
424 -- has an associated extra access level parameter and
425 -- when the level of the type is less deep than the level
426 -- of the access parameter.
428 elsif Present
(Param_Ent
)
429 and then Present
(Extra_Accessibility
(Param_Ent
))
430 and then UI_Gt
(Object_Access_Level
(N
),
431 Type_Access_Level
(Typ
))
432 and then not Accessibility_Checks_Suppressed
(Param_Ent
)
433 and then not Accessibility_Checks_Suppressed
(Typ
)
436 New_Occurrence_Of
(Extra_Accessibility
(Param_Ent
), Loc
);
439 Make_Integer_Literal
(Loc
, Type_Access_Level
(Typ
));
441 -- Raise Program_Error if the accessibility level of the
442 -- the access parameter is deeper than the level of the
443 -- target access type.
446 Make_Raise_Program_Error
(Loc
,
449 Left_Opnd
=> Param_Level
,
450 Right_Opnd
=> Type_Level
),
451 Reason
=> PE_Accessibility_Check_Failed
));
453 Analyze_And_Resolve
(N
);
455 end Apply_Accessibility_Check
;
457 ---------------------------
458 -- Apply_Alignment_Check --
459 ---------------------------
461 procedure Apply_Alignment_Check
(E
: Entity_Id
; N
: Node_Id
) is
462 AC
: constant Node_Id
:= Address_Clause
(E
);
467 -- See if check needed. Note that we never need a check if the
468 -- maximum alignment is one, since the check will always succeed
471 or else not Check_Address_Alignment
(AC
)
472 or else Maximum_Alignment
= 1
478 Expr
:= Expression
(AC
);
480 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
481 Expr
:= Expression
(Expr
);
483 elsif Nkind
(Expr
) = N_Function_Call
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
)
499 if Expr_Value
(Expr
) mod Alignment
(E
) /= 0 then
501 Make_Raise_Program_Error
(Loc
,
502 Reason
=> PE_Misaligned_Address_Value
));
504 ("?specified address for& not " &
505 "consistent with alignment", Expr
, E
);
508 -- Here we do not know if the value is acceptable, generate
509 -- code to raise PE if alignment is inappropriate.
512 -- Skip generation of this code if we don't want elab code
514 if not Restrictions
(No_Elaboration_Code
) then
515 Insert_After_And_Analyze
(N
,
516 Make_Raise_Program_Error
(Loc
,
523 (RTE
(RE_Integer_Address
),
524 Duplicate_Subexpr_No_Checks
(Expr
)),
526 Make_Attribute_Reference
(Loc
,
527 Prefix
=> New_Occurrence_Of
(E
, Loc
),
528 Attribute_Name
=> Name_Alignment
)),
529 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
530 Reason
=> PE_Misaligned_Address_Value
),
531 Suppress
=> All_Checks
);
538 when RE_Not_Available
=>
540 end Apply_Alignment_Check
;
542 -------------------------------------
543 -- Apply_Arithmetic_Overflow_Check --
544 -------------------------------------
546 -- This routine is called only if the type is an integer type, and
547 -- a software arithmetic overflow check must be performed for op
548 -- (add, subtract, multiply). The check is performed only if
549 -- Software_Overflow_Checking is enabled and Do_Overflow_Check
550 -- is set. In this case we expand the operation into a more complex
551 -- sequence of tests that ensures that overflow is properly caught.
553 procedure Apply_Arithmetic_Overflow_Check
(N
: Node_Id
) is
554 Loc
: constant Source_Ptr
:= Sloc
(N
);
555 Typ
: constant Entity_Id
:= Etype
(N
);
556 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
557 Siz
: constant Int
:= UI_To_Int
(Esize
(Rtyp
));
558 Dsiz
: constant Int
:= Siz
* 2;
565 -- Skip this if overflow checks are done in back end, or the overflow
566 -- flag is not set anyway, or we are not doing code expansion.
568 if Backend_Overflow_Checks_On_Target
569 or not Do_Overflow_Check
(N
)
570 or not Expander_Active
575 -- Otherwise, we generate the full general code for front end overflow
576 -- detection, which works by doing arithmetic in a larger type:
582 -- Typ (Checktyp (x) op Checktyp (y));
584 -- where Typ is the type of the original expression, and Checktyp is
585 -- an integer type of sufficient length to hold the largest possible
588 -- In the case where check type exceeds the size of Long_Long_Integer,
589 -- we use a different approach, expanding to:
591 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
593 -- where xxx is Add, Multiply or Subtract as appropriate
595 -- Find check type if one exists
597 if Dsiz
<= Standard_Integer_Size
then
598 Ctyp
:= Standard_Integer
;
600 elsif Dsiz
<= Standard_Long_Long_Integer_Size
then
601 Ctyp
:= Standard_Long_Long_Integer
;
603 -- No check type exists, use runtime call
606 if Nkind
(N
) = N_Op_Add
then
607 Cent
:= RE_Add_With_Ovflo_Check
;
609 elsif Nkind
(N
) = N_Op_Multiply
then
610 Cent
:= RE_Multiply_With_Ovflo_Check
;
613 pragma Assert
(Nkind
(N
) = N_Op_Subtract
);
614 Cent
:= RE_Subtract_With_Ovflo_Check
;
619 Make_Function_Call
(Loc
,
620 Name
=> New_Reference_To
(RTE
(Cent
), Loc
),
621 Parameter_Associations
=> New_List
(
622 OK_Convert_To
(RTE
(RE_Integer_64
), Left_Opnd
(N
)),
623 OK_Convert_To
(RTE
(RE_Integer_64
), Right_Opnd
(N
))))));
625 Analyze_And_Resolve
(N
, Typ
);
629 -- If we fall through, we have the case where we do the arithmetic in
630 -- the next higher type and get the check by conversion. In these cases
631 -- Ctyp is set to the type to be used as the check type.
633 Opnod
:= Relocate_Node
(N
);
635 Opnd
:= OK_Convert_To
(Ctyp
, Left_Opnd
(Opnod
));
638 Set_Etype
(Opnd
, Ctyp
);
639 Set_Analyzed
(Opnd
, True);
640 Set_Left_Opnd
(Opnod
, Opnd
);
642 Opnd
:= OK_Convert_To
(Ctyp
, Right_Opnd
(Opnod
));
645 Set_Etype
(Opnd
, Ctyp
);
646 Set_Analyzed
(Opnd
, True);
647 Set_Right_Opnd
(Opnod
, Opnd
);
649 -- The type of the operation changes to the base type of the check
650 -- type, and we reset the overflow check indication, since clearly
651 -- no overflow is possible now that we are using a double length
652 -- type. We also set the Analyzed flag to avoid a recursive attempt
653 -- to expand the node.
655 Set_Etype
(Opnod
, Base_Type
(Ctyp
));
656 Set_Do_Overflow_Check
(Opnod
, False);
657 Set_Analyzed
(Opnod
, True);
659 -- Now build the outer conversion
661 Opnd
:= OK_Convert_To
(Typ
, Opnod
);
663 Set_Etype
(Opnd
, Typ
);
665 -- In the discrete type case, we directly generate the range check
666 -- for the outer operand. This range check will implement the required
669 if Is_Discrete_Type
(Typ
) then
671 Generate_Range_Check
(Expression
(N
), Typ
, CE_Overflow_Check_Failed
);
673 -- For other types, we enable overflow checking on the conversion,
674 -- after setting the node as analyzed to prevent recursive attempts
675 -- to expand the conversion node.
678 Set_Analyzed
(Opnd
, True);
679 Enable_Overflow_Check
(Opnd
);
684 when RE_Not_Available
=>
686 end Apply_Arithmetic_Overflow_Check
;
688 ----------------------------
689 -- Apply_Array_Size_Check --
690 ----------------------------
692 -- Note: Really of course this entre check should be in the backend,
693 -- and perhaps this is not quite the right value, but it is good
694 -- enough to catch the normal cases (and the relevant ACVC tests!)
696 procedure Apply_Array_Size_Check
(N
: Node_Id
; Typ
: Entity_Id
) is
697 Loc
: constant Source_Ptr
:= Sloc
(N
);
698 Ctyp
: constant Entity_Id
:= Component_Type
(Typ
);
699 Ent
: constant Entity_Id
:= Defining_Identifier
(N
);
711 Static
: Boolean := True;
712 -- Set false if any index subtye bound is non-static
714 Umark
: constant Uintp
.Save_Mark
:= Uintp
.Mark
;
715 -- We can throw away all the Uint computations here, since they are
716 -- done only to generate boolean test results.
719 -- Size to check against
721 function Is_Address_Or_Import
(Decl
: Node_Id
) return Boolean;
722 -- Determines if Decl is an address clause or Import/Interface pragma
723 -- that references the defining identifier of the current declaration.
725 --------------------------
726 -- Is_Address_Or_Import --
727 --------------------------
729 function Is_Address_Or_Import
(Decl
: Node_Id
) return Boolean is
731 if Nkind
(Decl
) = N_At_Clause
then
732 return Chars
(Identifier
(Decl
)) = Chars
(Ent
);
734 elsif Nkind
(Decl
) = N_Attribute_Definition_Clause
then
736 Chars
(Decl
) = Name_Address
738 Nkind
(Name
(Decl
)) = N_Identifier
740 Chars
(Name
(Decl
)) = Chars
(Ent
);
742 elsif Nkind
(Decl
) = N_Pragma
then
743 if (Chars
(Decl
) = Name_Import
745 Chars
(Decl
) = Name_Interface
)
746 and then Present
(Pragma_Argument_Associations
(Decl
))
749 F
: constant Node_Id
:=
750 First
(Pragma_Argument_Associations
(Decl
));
758 Nkind
(Expression
(Next
(F
))) = N_Identifier
760 Chars
(Expression
(Next
(F
))) = Chars
(Ent
);
770 end Is_Address_Or_Import
;
772 -- Start of processing for Apply_Array_Size_Check
775 if not Expander_Active
776 or else Storage_Checks_Suppressed
(Typ
)
781 -- It is pointless to insert this check inside an init proc, because
782 -- that's too late, we have already built the object to be the right
783 -- size, and if it's too large, too bad!
785 if Inside_Init_Proc
then
789 -- Look head for pragma interface/import or address clause applying
790 -- to this entity. If found, we suppress the check entirely. For now
791 -- we only look ahead 20 declarations to stop this becoming too slow
792 -- Note that eventually this whole routine gets moved to gigi.
795 for Ctr
in 1 .. 20 loop
799 if Is_Address_Or_Import
(Decl
) then
804 -- First step is to calculate the maximum number of elements. For this
805 -- calculation, we use the actual size of the subtype if it is static,
806 -- and if a bound of a subtype is non-static, we go to the bound of the
810 Indx
:= First_Index
(Typ
);
811 while Present
(Indx
) loop
812 Xtyp
:= Etype
(Indx
);
813 Lo
:= Type_Low_Bound
(Xtyp
);
814 Hi
:= Type_High_Bound
(Xtyp
);
816 -- If any bound raises constraint error, we will never get this
817 -- far, so there is no need to generate any kind of check.
819 if Raises_Constraint_Error
(Lo
)
821 Raises_Constraint_Error
(Hi
)
823 Uintp
.Release
(Umark
);
827 -- Otherwise get bounds values
829 if Is_Static_Expression
(Lo
) then
830 Lob
:= Expr_Value
(Lo
);
832 Lob
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Xtyp
)));
836 if Is_Static_Expression
(Hi
) then
837 Hib
:= Expr_Value
(Hi
);
839 Hib
:= Expr_Value
(Type_High_Bound
(Base_Type
(Xtyp
)));
843 Siz
:= Siz
* UI_Max
(Hib
- Lob
+ 1, Uint_0
);
847 -- Compute the limit against which we want to check. For subprograms,
848 -- where the array will go on the stack, we use 8*2**24, which (in
849 -- bits) is the size of a 16 megabyte array.
851 if Is_Subprogram
(Scope
(Ent
)) then
852 Check_Siz
:= Uint_2
** 27;
854 Check_Siz
:= Uint_2
** 31;
857 -- If we have all static bounds and Siz is too large, then we know we
858 -- know we have a storage error right now, so generate message
860 if Static
and then Siz
>= Check_Siz
then
862 Make_Raise_Storage_Error
(Loc
,
863 Reason
=> SE_Object_Too_Large
));
864 Error_Msg_N
("?Storage_Error will be raised at run-time", N
);
865 Uintp
.Release
(Umark
);
869 -- Case of component size known at compile time. If the array
870 -- size is definitely in range, then we do not need a check.
872 if Known_Esize
(Ctyp
)
873 and then Siz
* Esize
(Ctyp
) < Check_Siz
875 Uintp
.Release
(Umark
);
879 -- Here if a dynamic check is required
881 -- What we do is to build an expression for the size of the array,
882 -- which is computed as the 'Size of the array component, times
883 -- the size of each dimension.
885 Uintp
.Release
(Umark
);
888 Make_Attribute_Reference
(Loc
,
889 Prefix
=> New_Occurrence_Of
(Ctyp
, Loc
),
890 Attribute_Name
=> Name_Size
);
892 Indx
:= First_Index
(Typ
);
894 for J
in 1 .. Number_Dimensions
(Typ
) loop
895 if Sloc
(Etype
(Indx
)) = Sloc
(N
) then
896 Ensure_Defined
(Etype
(Indx
), N
);
900 Make_Op_Multiply
(Loc
,
903 Make_Attribute_Reference
(Loc
,
904 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
905 Attribute_Name
=> Name_Length
,
906 Expressions
=> New_List
(
907 Make_Integer_Literal
(Loc
, J
))));
912 Make_Raise_Storage_Error
(Loc
,
917 Make_Integer_Literal
(Loc
, Check_Siz
)),
918 Reason
=> SE_Object_Too_Large
);
920 Set_Size_Check_Code
(Defining_Identifier
(N
), Code
);
921 Insert_Action
(N
, Code
);
922 end Apply_Array_Size_Check
;
924 ----------------------------
925 -- Apply_Constraint_Check --
926 ----------------------------
928 procedure Apply_Constraint_Check
931 No_Sliding
: Boolean := False)
933 Desig_Typ
: Entity_Id
;
936 if Inside_A_Generic
then
939 elsif Is_Scalar_Type
(Typ
) then
940 Apply_Scalar_Range_Check
(N
, Typ
);
942 elsif Is_Array_Type
(Typ
) then
944 -- A useful optimization: an aggregate with only an Others clause
945 -- always has the right bounds.
947 if Nkind
(N
) = N_Aggregate
948 and then No
(Expressions
(N
))
950 (First
(Choices
(First
(Component_Associations
(N
)))))
956 if Is_Constrained
(Typ
) then
957 Apply_Length_Check
(N
, Typ
);
960 Apply_Range_Check
(N
, Typ
);
963 Apply_Range_Check
(N
, Typ
);
966 elsif (Is_Record_Type
(Typ
)
967 or else Is_Private_Type
(Typ
))
968 and then Has_Discriminants
(Base_Type
(Typ
))
969 and then Is_Constrained
(Typ
)
971 Apply_Discriminant_Check
(N
, Typ
);
973 elsif Is_Access_Type
(Typ
) then
975 Desig_Typ
:= Designated_Type
(Typ
);
977 -- No checks necessary if expression statically null
979 if Nkind
(N
) = N_Null
then
982 -- No sliding possible on access to arrays
984 elsif Is_Array_Type
(Desig_Typ
) then
985 if Is_Constrained
(Desig_Typ
) then
986 Apply_Length_Check
(N
, Typ
);
989 Apply_Range_Check
(N
, Typ
);
991 elsif Has_Discriminants
(Base_Type
(Desig_Typ
))
992 and then Is_Constrained
(Desig_Typ
)
994 Apply_Discriminant_Check
(N
, Typ
);
997 end Apply_Constraint_Check
;
999 ------------------------------
1000 -- Apply_Discriminant_Check --
1001 ------------------------------
1003 procedure Apply_Discriminant_Check
1006 Lhs
: Node_Id
:= Empty
)
1008 Loc
: constant Source_Ptr
:= Sloc
(N
);
1009 Do_Access
: constant Boolean := Is_Access_Type
(Typ
);
1010 S_Typ
: Entity_Id
:= Etype
(N
);
1014 function Is_Aliased_Unconstrained_Component
return Boolean;
1015 -- It is possible for an aliased component to have a nominal
1016 -- unconstrained subtype (through instantiation). If this is a
1017 -- discriminated component assigned in the expansion of an aggregate
1018 -- in an initialization, the check must be suppressed. This unusual
1019 -- situation requires a predicate of its own (see 7503-008).
1021 ----------------------------------------
1022 -- Is_Aliased_Unconstrained_Component --
1023 ----------------------------------------
1025 function Is_Aliased_Unconstrained_Component
return Boolean is
1030 if Nkind
(Lhs
) /= N_Selected_Component
then
1033 Comp
:= Entity
(Selector_Name
(Lhs
));
1034 Pref
:= Prefix
(Lhs
);
1037 if Ekind
(Comp
) /= E_Component
1038 or else not Is_Aliased
(Comp
)
1043 return not Comes_From_Source
(Pref
)
1044 and then In_Instance
1045 and then not Is_Constrained
(Etype
(Comp
));
1046 end Is_Aliased_Unconstrained_Component
;
1048 -- Start of processing for Apply_Discriminant_Check
1052 T_Typ
:= Designated_Type
(Typ
);
1057 -- Nothing to do if discriminant checks are suppressed or else no code
1058 -- is to be generated
1060 if not Expander_Active
1061 or else Discriminant_Checks_Suppressed
(T_Typ
)
1066 -- No discriminant checks necessary for access when expression
1067 -- is statically Null. This is not only an optimization, this is
1068 -- fundamental because otherwise discriminant checks may be generated
1069 -- in init procs for types containing an access to a non-frozen yet
1070 -- record, causing a deadly forward reference.
1072 -- Also, if the expression is of an access type whose designated
1073 -- type is incomplete, then the access value must be null and
1074 -- we suppress the check.
1076 if Nkind
(N
) = N_Null
then
1079 elsif Is_Access_Type
(S_Typ
) then
1080 S_Typ
:= Designated_Type
(S_Typ
);
1082 if Ekind
(S_Typ
) = E_Incomplete_Type
then
1087 -- If an assignment target is present, then we need to generate
1088 -- the actual subtype if the target is a parameter or aliased
1089 -- object with an unconstrained nominal subtype.
1092 and then (Present
(Param_Entity
(Lhs
))
1093 or else (not Is_Constrained
(T_Typ
)
1094 and then Is_Aliased_View
(Lhs
)
1095 and then not Is_Aliased_Unconstrained_Component
))
1097 T_Typ
:= Get_Actual_Subtype
(Lhs
);
1100 -- Nothing to do if the type is unconstrained (this is the case
1101 -- where the actual subtype in the RM sense of N is unconstrained
1102 -- and no check is required).
1104 if not Is_Constrained
(T_Typ
) then
1108 -- Suppress checks if the subtypes are the same.
1109 -- the check must be preserved in an assignment to a formal, because
1110 -- the constraint is given by the actual.
1112 if Nkind
(Original_Node
(N
)) /= N_Allocator
1114 or else not Is_Entity_Name
(Lhs
)
1115 or else No
(Param_Entity
(Lhs
)))
1118 or else (Do_Access
and then Designated_Type
(Typ
) = S_Typ
))
1119 and then not Is_Aliased_View
(Lhs
)
1124 -- We can also eliminate checks on allocators with a subtype mark
1125 -- that coincides with the context type. The context type may be a
1126 -- subtype without a constraint (common case, a generic actual).
1128 elsif Nkind
(Original_Node
(N
)) = N_Allocator
1129 and then Is_Entity_Name
(Expression
(Original_Node
(N
)))
1132 Alloc_Typ
: constant Entity_Id
:=
1133 Entity
(Expression
(Original_Node
(N
)));
1136 if Alloc_Typ
= T_Typ
1137 or else (Nkind
(Parent
(T_Typ
)) = N_Subtype_Declaration
1138 and then Is_Entity_Name
(
1139 Subtype_Indication
(Parent
(T_Typ
)))
1140 and then Alloc_Typ
= Base_Type
(T_Typ
))
1148 -- See if we have a case where the types are both constrained, and
1149 -- all the constraints are constants. In this case, we can do the
1150 -- check successfully at compile time.
1152 -- We skip this check for the case where the node is a rewritten`
1153 -- allocator, because it already carries the context subtype, and
1154 -- extracting the discriminants from the aggregate is messy.
1156 if Is_Constrained
(S_Typ
)
1157 and then Nkind
(Original_Node
(N
)) /= N_Allocator
1167 -- S_Typ may not have discriminants in the case where it is a
1168 -- private type completed by a default discriminated type. In
1169 -- that case, we need to get the constraints from the
1170 -- underlying_type. If the underlying type is unconstrained (i.e.
1171 -- has no default discriminants) no check is needed.
1173 if Has_Discriminants
(S_Typ
) then
1174 Discr
:= First_Discriminant
(S_Typ
);
1175 DconS
:= First_Elmt
(Discriminant_Constraint
(S_Typ
));
1178 Discr
:= First_Discriminant
(Underlying_Type
(S_Typ
));
1181 (Discriminant_Constraint
(Underlying_Type
(S_Typ
)));
1187 -- A further optimization: if T_Typ is derived from S_Typ
1188 -- without imposing a constraint, no check is needed.
1190 if Nkind
(Original_Node
(Parent
(T_Typ
))) =
1191 N_Full_Type_Declaration
1194 Type_Def
: Node_Id
:=
1196 (Original_Node
(Parent
(T_Typ
)));
1198 if Nkind
(Type_Def
) = N_Derived_Type_Definition
1199 and then Is_Entity_Name
(Subtype_Indication
(Type_Def
))
1200 and then Entity
(Subtype_Indication
(Type_Def
)) = S_Typ
1208 DconT
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
1210 while Present
(Discr
) loop
1211 ItemS
:= Node
(DconS
);
1212 ItemT
:= Node
(DconT
);
1215 not Is_OK_Static_Expression
(ItemS
)
1217 not Is_OK_Static_Expression
(ItemT
);
1219 if Expr_Value
(ItemS
) /= Expr_Value
(ItemT
) then
1220 if Do_Access
then -- needs run-time check.
1223 Apply_Compile_Time_Constraint_Error
1224 (N
, "incorrect value for discriminant&?",
1225 CE_Discriminant_Check_Failed
, Ent
=> Discr
);
1232 Next_Discriminant
(Discr
);
1241 -- Here we need a discriminant check. First build the expression
1242 -- for the comparisons of the discriminants:
1244 -- (n.disc1 /= typ.disc1) or else
1245 -- (n.disc2 /= typ.disc2) or else
1247 -- (n.discn /= typ.discn)
1249 Cond
:= Build_Discriminant_Checks
(N
, T_Typ
);
1251 -- If Lhs is set and is a parameter, then the condition is
1252 -- guarded by: lhs'constrained and then (condition built above)
1254 if Present
(Param_Entity
(Lhs
)) then
1258 Make_Attribute_Reference
(Loc
,
1259 Prefix
=> New_Occurrence_Of
(Param_Entity
(Lhs
), Loc
),
1260 Attribute_Name
=> Name_Constrained
),
1261 Right_Opnd
=> Cond
);
1265 Cond
:= Guard_Access
(Cond
, Loc
, N
);
1269 Make_Raise_Constraint_Error
(Loc
,
1271 Reason
=> CE_Discriminant_Check_Failed
));
1272 end Apply_Discriminant_Check
;
1274 ------------------------
1275 -- Apply_Divide_Check --
1276 ------------------------
1278 procedure Apply_Divide_Check
(N
: Node_Id
) is
1279 Loc
: constant Source_Ptr
:= Sloc
(N
);
1280 Typ
: constant Entity_Id
:= Etype
(N
);
1281 Left
: constant Node_Id
:= Left_Opnd
(N
);
1282 Right
: constant Node_Id
:= Right_Opnd
(N
);
1294 and not Backend_Divide_Checks_On_Target
1296 Determine_Range
(Right
, ROK
, Rlo
, Rhi
);
1298 -- See if division by zero possible, and if so generate test. This
1299 -- part of the test is not controlled by the -gnato switch.
1301 if Do_Division_Check
(N
) then
1303 if (not ROK
) or else (Rlo
<= 0 and then 0 <= Rhi
) then
1305 Make_Raise_Constraint_Error
(Loc
,
1308 Left_Opnd
=> Duplicate_Subexpr_Move_Checks
(Right
),
1309 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1310 Reason
=> CE_Divide_By_Zero
));
1314 -- Test for extremely annoying case of xxx'First divided by -1
1316 if Do_Overflow_Check
(N
) then
1318 if Nkind
(N
) = N_Op_Divide
1319 and then Is_Signed_Integer_Type
(Typ
)
1321 Determine_Range
(Left
, LOK
, Llo
, Lhi
);
1322 LLB
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
1324 if ((not ROK
) or else (Rlo
<= (-1) and then (-1) <= Rhi
))
1326 ((not LOK
) or else (Llo
= LLB
))
1329 Make_Raise_Constraint_Error
(Loc
,
1335 Duplicate_Subexpr_Move_Checks
(Left
),
1336 Right_Opnd
=> Make_Integer_Literal
(Loc
, LLB
)),
1340 Duplicate_Subexpr
(Right
),
1342 Make_Integer_Literal
(Loc
, -1))),
1343 Reason
=> CE_Overflow_Check_Failed
));
1348 end Apply_Divide_Check
;
1350 ------------------------
1351 -- Apply_Length_Check --
1352 ------------------------
1354 procedure Apply_Length_Check
1356 Target_Typ
: Entity_Id
;
1357 Source_Typ
: Entity_Id
:= Empty
)
1360 Apply_Selected_Length_Checks
1361 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
1362 end Apply_Length_Check
;
1364 -----------------------
1365 -- Apply_Range_Check --
1366 -----------------------
1368 procedure Apply_Range_Check
1370 Target_Typ
: Entity_Id
;
1371 Source_Typ
: Entity_Id
:= Empty
)
1374 Apply_Selected_Range_Checks
1375 (Ck_Node
, Target_Typ
, Source_Typ
, Do_Static
=> False);
1376 end Apply_Range_Check
;
1378 ------------------------------
1379 -- Apply_Scalar_Range_Check --
1380 ------------------------------
1382 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check
1383 -- flag off if it is already set on.
1385 procedure Apply_Scalar_Range_Check
1387 Target_Typ
: Entity_Id
;
1388 Source_Typ
: Entity_Id
:= Empty
;
1389 Fixed_Int
: Boolean := False)
1391 Parnt
: constant Node_Id
:= Parent
(Expr
);
1393 Arr
: Node_Id
:= Empty
; -- initialize to prevent warning
1394 Arr_Typ
: Entity_Id
:= Empty
; -- initialize to prevent warning
1397 Is_Subscr_Ref
: Boolean;
1398 -- Set true if Expr is a subscript
1400 Is_Unconstrained_Subscr_Ref
: Boolean;
1401 -- Set true if Expr is a subscript of an unconstrained array. In this
1402 -- case we do not attempt to do an analysis of the value against the
1403 -- range of the subscript, since we don't know the actual subtype.
1406 -- Set to True if Expr should be regarded as a real value
1407 -- even though the type of Expr might be discrete.
1409 procedure Bad_Value
;
1410 -- Procedure called if value is determined to be out of range
1416 procedure Bad_Value
is
1418 Apply_Compile_Time_Constraint_Error
1419 (Expr
, "value not in range of}?", CE_Range_Check_Failed
,
1424 -- Start of processing for Apply_Scalar_Range_Check
1427 if Inside_A_Generic
then
1430 -- Return if check obviously not needed. Note that we do not check
1431 -- for the expander being inactive, since this routine does not
1432 -- insert any code, but it does generate useful warnings sometimes,
1433 -- which we would like even if we are in semantics only mode.
1435 elsif Target_Typ
= Any_Type
1436 or else not Is_Scalar_Type
(Target_Typ
)
1437 or else Raises_Constraint_Error
(Expr
)
1442 -- Now, see if checks are suppressed
1445 Is_List_Member
(Expr
) and then Nkind
(Parnt
) = N_Indexed_Component
;
1447 if Is_Subscr_Ref
then
1448 Arr
:= Prefix
(Parnt
);
1449 Arr_Typ
:= Get_Actual_Subtype_If_Available
(Arr
);
1452 if not Do_Range_Check
(Expr
) then
1454 -- Subscript reference. Check for Index_Checks suppressed
1456 if Is_Subscr_Ref
then
1458 -- Check array type and its base type
1460 if Index_Checks_Suppressed
(Arr_Typ
)
1461 or else Index_Checks_Suppressed
(Base_Type
(Arr_Typ
))
1465 -- Check array itself if it is an entity name
1467 elsif Is_Entity_Name
(Arr
)
1468 and then Index_Checks_Suppressed
(Entity
(Arr
))
1472 -- Check expression itself if it is an entity name
1474 elsif Is_Entity_Name
(Expr
)
1475 and then Index_Checks_Suppressed
(Entity
(Expr
))
1480 -- All other cases, check for Range_Checks suppressed
1483 -- Check target type and its base type
1485 if Range_Checks_Suppressed
(Target_Typ
)
1486 or else Range_Checks_Suppressed
(Base_Type
(Target_Typ
))
1490 -- Check expression itself if it is an entity name
1492 elsif Is_Entity_Name
(Expr
)
1493 and then Range_Checks_Suppressed
(Entity
(Expr
))
1497 -- If Expr is part of an assignment statement, then check
1498 -- left side of assignment if it is an entity name.
1500 elsif Nkind
(Parnt
) = N_Assignment_Statement
1501 and then Is_Entity_Name
(Name
(Parnt
))
1502 and then Range_Checks_Suppressed
(Entity
(Name
(Parnt
)))
1509 -- Do not set range checks if they are killed
1511 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
1512 and then Kill_Range_Check
(Expr
)
1517 -- Do not set range checks for any values from System.Scalar_Values
1518 -- since the whole idea of such values is to avoid checking them!
1520 if Is_Entity_Name
(Expr
)
1521 and then Is_RTU
(Scope
(Entity
(Expr
)), System_Scalar_Values
)
1526 -- Now see if we need a check
1528 if No
(Source_Typ
) then
1529 S_Typ
:= Etype
(Expr
);
1531 S_Typ
:= Source_Typ
;
1534 if not Is_Scalar_Type
(S_Typ
) or else S_Typ
= Any_Type
then
1538 Is_Unconstrained_Subscr_Ref
:=
1539 Is_Subscr_Ref
and then not Is_Constrained
(Arr_Typ
);
1541 -- Always do a range check if the source type includes infinities
1542 -- and the target type does not include infinities. We do not do
1543 -- this if range checks are killed.
1545 if Is_Floating_Point_Type
(S_Typ
)
1546 and then Has_Infinities
(S_Typ
)
1547 and then not Has_Infinities
(Target_Typ
)
1549 Enable_Range_Check
(Expr
);
1552 -- Return if we know expression is definitely in the range of
1553 -- the target type as determined by Determine_Range. Right now
1554 -- we only do this for discrete types, and not fixed-point or
1555 -- floating-point types.
1557 -- The additional less-precise tests below catch these cases.
1559 -- Note: skip this if we are given a source_typ, since the point
1560 -- of supplying a Source_Typ is to stop us looking at the expression.
1561 -- could sharpen this test to be out parameters only ???
1563 if Is_Discrete_Type
(Target_Typ
)
1564 and then Is_Discrete_Type
(Etype
(Expr
))
1565 and then not Is_Unconstrained_Subscr_Ref
1566 and then No
(Source_Typ
)
1569 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Typ
);
1570 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Typ
);
1575 if Compile_Time_Known_Value
(Tlo
)
1576 and then Compile_Time_Known_Value
(Thi
)
1579 Lov
: constant Uint
:= Expr_Value
(Tlo
);
1580 Hiv
: constant Uint
:= Expr_Value
(Thi
);
1583 -- If range is null, we for sure have a constraint error
1584 -- (we don't even need to look at the value involved,
1585 -- since all possible values will raise CE).
1592 -- Otherwise determine range of value
1594 Determine_Range
(Expr
, OK
, Lo
, Hi
);
1598 -- If definitely in range, all OK
1600 if Lo
>= Lov
and then Hi
<= Hiv
then
1603 -- If definitely not in range, warn
1605 elsif Lov
> Hi
or else Hiv
< Lo
then
1609 -- Otherwise we don't know
1621 Is_Floating_Point_Type
(S_Typ
)
1622 or else (Is_Fixed_Point_Type
(S_Typ
) and then not Fixed_Int
);
1624 -- Check if we can determine at compile time whether Expr is in the
1625 -- range of the target type. Note that if S_Typ is within the bounds
1626 -- of Target_Typ then this must be the case. This check is meaningful
1627 -- only if this is not a conversion between integer and real types.
1629 if not Is_Unconstrained_Subscr_Ref
1631 Is_Discrete_Type
(S_Typ
) = Is_Discrete_Type
(Target_Typ
)
1633 (In_Subrange_Of
(S_Typ
, Target_Typ
, Fixed_Int
)
1635 Is_In_Range
(Expr
, Target_Typ
, Fixed_Int
, Int_Real
))
1639 elsif Is_Out_Of_Range
(Expr
, Target_Typ
, Fixed_Int
, Int_Real
) then
1643 -- In the floating-point case, we only do range checks if the
1644 -- type is constrained. We definitely do NOT want range checks
1645 -- for unconstrained types, since we want to have infinities
1647 elsif Is_Floating_Point_Type
(S_Typ
) then
1648 if Is_Constrained
(S_Typ
) then
1649 Enable_Range_Check
(Expr
);
1652 -- For all other cases we enable a range check unconditionally
1655 Enable_Range_Check
(Expr
);
1658 end Apply_Scalar_Range_Check
;
1660 ----------------------------------
1661 -- Apply_Selected_Length_Checks --
1662 ----------------------------------
1664 procedure Apply_Selected_Length_Checks
1666 Target_Typ
: Entity_Id
;
1667 Source_Typ
: Entity_Id
;
1668 Do_Static
: Boolean)
1671 R_Result
: Check_Result
;
1674 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1675 Checks_On
: constant Boolean :=
1676 (not Index_Checks_Suppressed
(Target_Typ
))
1678 (not Length_Checks_Suppressed
(Target_Typ
));
1681 if not Expander_Active
then
1686 Selected_Length_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
1688 for J
in 1 .. 2 loop
1689 R_Cno
:= R_Result
(J
);
1690 exit when No
(R_Cno
);
1692 -- A length check may mention an Itype which is attached to a
1693 -- subsequent node. At the top level in a package this can cause
1694 -- an order-of-elaboration problem, so we make sure that the itype
1695 -- is referenced now.
1697 if Ekind
(Current_Scope
) = E_Package
1698 and then Is_Compilation_Unit
(Current_Scope
)
1700 Ensure_Defined
(Target_Typ
, Ck_Node
);
1702 if Present
(Source_Typ
) then
1703 Ensure_Defined
(Source_Typ
, Ck_Node
);
1705 elsif Is_Itype
(Etype
(Ck_Node
)) then
1706 Ensure_Defined
(Etype
(Ck_Node
), Ck_Node
);
1710 -- If the item is a conditional raise of constraint error,
1711 -- then have a look at what check is being performed and
1714 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
1715 and then Present
(Condition
(R_Cno
))
1717 Cond
:= Condition
(R_Cno
);
1719 if not Has_Dynamic_Length_Check
(Ck_Node
)
1722 Insert_Action
(Ck_Node
, R_Cno
);
1724 if not Do_Static
then
1725 Set_Has_Dynamic_Length_Check
(Ck_Node
);
1729 -- Output a warning if the condition is known to be True
1731 if Is_Entity_Name
(Cond
)
1732 and then Entity
(Cond
) = Standard_True
1734 Apply_Compile_Time_Constraint_Error
1735 (Ck_Node
, "wrong length for array of}?",
1736 CE_Length_Check_Failed
,
1740 -- If we were only doing a static check, or if checks are not
1741 -- on, then we want to delete the check, since it is not needed.
1742 -- We do this by replacing the if statement by a null statement
1744 elsif Do_Static
or else not Checks_On
then
1745 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
1749 Install_Static_Check
(R_Cno
, Loc
);
1754 end Apply_Selected_Length_Checks
;
1756 ---------------------------------
1757 -- Apply_Selected_Range_Checks --
1758 ---------------------------------
1760 procedure Apply_Selected_Range_Checks
1762 Target_Typ
: Entity_Id
;
1763 Source_Typ
: Entity_Id
;
1764 Do_Static
: Boolean)
1767 R_Result
: Check_Result
;
1770 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
1771 Checks_On
: constant Boolean :=
1772 (not Index_Checks_Suppressed
(Target_Typ
))
1774 (not Range_Checks_Suppressed
(Target_Typ
));
1777 if not Expander_Active
or else not Checks_On
then
1782 Selected_Range_Checks
(Ck_Node
, Target_Typ
, Source_Typ
, Empty
);
1784 for J
in 1 .. 2 loop
1786 R_Cno
:= R_Result
(J
);
1787 exit when No
(R_Cno
);
1789 -- If the item is a conditional raise of constraint error,
1790 -- then have a look at what check is being performed and
1793 if Nkind
(R_Cno
) = N_Raise_Constraint_Error
1794 and then Present
(Condition
(R_Cno
))
1796 Cond
:= Condition
(R_Cno
);
1798 if not Has_Dynamic_Range_Check
(Ck_Node
) then
1799 Insert_Action
(Ck_Node
, R_Cno
);
1801 if not Do_Static
then
1802 Set_Has_Dynamic_Range_Check
(Ck_Node
);
1806 -- Output a warning if the condition is known to be True
1808 if Is_Entity_Name
(Cond
)
1809 and then Entity
(Cond
) = Standard_True
1811 -- Since an N_Range is technically not an expression, we
1812 -- have to set one of the bounds to C_E and then just flag
1813 -- the N_Range. The warning message will point to the
1814 -- lower bound and complain about a range, which seems OK.
1816 if Nkind
(Ck_Node
) = N_Range
then
1817 Apply_Compile_Time_Constraint_Error
1818 (Low_Bound
(Ck_Node
), "static range out of bounds of}?",
1819 CE_Range_Check_Failed
,
1823 Set_Raises_Constraint_Error
(Ck_Node
);
1826 Apply_Compile_Time_Constraint_Error
1827 (Ck_Node
, "static value out of range of}?",
1828 CE_Range_Check_Failed
,
1833 -- If we were only doing a static check, or if checks are not
1834 -- on, then we want to delete the check, since it is not needed.
1835 -- We do this by replacing the if statement by a null statement
1837 elsif Do_Static
or else not Checks_On
then
1838 Rewrite
(R_Cno
, Make_Null_Statement
(Loc
));
1842 Install_Static_Check
(R_Cno
, Loc
);
1845 end Apply_Selected_Range_Checks
;
1847 -------------------------------
1848 -- Apply_Static_Length_Check --
1849 -------------------------------
1851 procedure Apply_Static_Length_Check
1853 Target_Typ
: Entity_Id
;
1854 Source_Typ
: Entity_Id
:= Empty
)
1857 Apply_Selected_Length_Checks
1858 (Expr
, Target_Typ
, Source_Typ
, Do_Static
=> True);
1859 end Apply_Static_Length_Check
;
1861 -------------------------------------
1862 -- Apply_Subscript_Validity_Checks --
1863 -------------------------------------
1865 procedure Apply_Subscript_Validity_Checks
(Expr
: Node_Id
) is
1869 pragma Assert
(Nkind
(Expr
) = N_Indexed_Component
);
1871 -- Loop through subscripts
1873 Sub
:= First
(Expressions
(Expr
));
1874 while Present
(Sub
) loop
1876 -- Check one subscript. Note that we do not worry about
1877 -- enumeration type with holes, since we will convert the
1878 -- value to a Pos value for the subscript, and that convert
1879 -- will do the necessary validity check.
1881 Ensure_Valid
(Sub
, Holes_OK
=> True);
1883 -- Move to next subscript
1887 end Apply_Subscript_Validity_Checks
;
1889 ----------------------------------
1890 -- Apply_Type_Conversion_Checks --
1891 ----------------------------------
1893 procedure Apply_Type_Conversion_Checks
(N
: Node_Id
) is
1894 Target_Type
: constant Entity_Id
:= Etype
(N
);
1895 Target_Base
: constant Entity_Id
:= Base_Type
(Target_Type
);
1896 Expr
: constant Node_Id
:= Expression
(N
);
1897 Expr_Type
: constant Entity_Id
:= Etype
(Expr
);
1900 if Inside_A_Generic
then
1903 -- Skip these checks if serious errors detected, there are some nasty
1904 -- situations of incomplete trees that blow things up.
1906 elsif Serious_Errors_Detected
> 0 then
1909 -- Scalar type conversions of the form Target_Type (Expr) require
1910 -- a range check if we cannot be sure that Expr is in the base type
1911 -- of Target_Typ and also that Expr is in the range of Target_Typ.
1912 -- These are not quite the same condition from an implementation
1913 -- point of view, but clearly the second includes the first.
1915 elsif Is_Scalar_Type
(Target_Type
) then
1917 Conv_OK
: constant Boolean := Conversion_OK
(N
);
1918 -- If the Conversion_OK flag on the type conversion is set
1919 -- and no floating point type is involved in the type conversion
1920 -- then fixed point values must be read as integral values.
1923 if not Overflow_Checks_Suppressed
(Target_Base
)
1924 and then not In_Subrange_Of
(Expr_Type
, Target_Base
, Conv_OK
)
1926 Set_Do_Overflow_Check
(N
);
1929 if not Range_Checks_Suppressed
(Target_Type
)
1930 and then not Range_Checks_Suppressed
(Expr_Type
)
1932 Apply_Scalar_Range_Check
1933 (Expr
, Target_Type
, Fixed_Int
=> Conv_OK
);
1937 elsif Comes_From_Source
(N
)
1938 and then Is_Record_Type
(Target_Type
)
1939 and then Is_Derived_Type
(Target_Type
)
1940 and then not Is_Tagged_Type
(Target_Type
)
1941 and then not Is_Constrained
(Target_Type
)
1942 and then Present
(Stored_Constraint
(Target_Type
))
1944 -- An unconstrained derived type may have inherited discriminant
1945 -- Build an actual discriminant constraint list using the stored
1946 -- constraint, to verify that the expression of the parent type
1947 -- satisfies the constraints imposed by the (unconstrained!)
1948 -- derived type. This applies to value conversions, not to view
1949 -- conversions of tagged types.
1952 Loc
: constant Source_Ptr
:= Sloc
(N
);
1954 Constraint
: Elmt_Id
;
1955 Discr_Value
: Node_Id
;
1958 New_Constraints
: constant Elist_Id
:= New_Elmt_List
;
1959 Old_Constraints
: constant Elist_Id
:=
1960 Discriminant_Constraint
(Expr_Type
);
1963 Constraint
:= First_Elmt
(Stored_Constraint
(Target_Type
));
1965 while Present
(Constraint
) loop
1966 Discr_Value
:= Node
(Constraint
);
1968 if Is_Entity_Name
(Discr_Value
)
1969 and then Ekind
(Entity
(Discr_Value
)) = E_Discriminant
1971 Discr
:= Corresponding_Discriminant
(Entity
(Discr_Value
));
1974 and then Scope
(Discr
) = Base_Type
(Expr_Type
)
1976 -- Parent is constrained by new discriminant. Obtain
1977 -- Value of original discriminant in expression. If
1978 -- the new discriminant has been used to constrain more
1979 -- than one of the stored discriminants, this will
1980 -- provide the required consistency check.
1983 Make_Selected_Component
(Loc
,
1985 Duplicate_Subexpr_No_Checks
1986 (Expr
, Name_Req
=> True),
1988 Make_Identifier
(Loc
, Chars
(Discr
))),
1992 -- Discriminant of more remote ancestor ???
1997 -- Derived type definition has an explicit value for
1998 -- this stored discriminant.
2002 (Duplicate_Subexpr_No_Checks
(Discr_Value
),
2006 Next_Elmt
(Constraint
);
2009 -- Use the unconstrained expression type to retrieve the
2010 -- discriminants of the parent, and apply momentarily the
2011 -- discriminant constraint synthesized above.
2013 Set_Discriminant_Constraint
(Expr_Type
, New_Constraints
);
2014 Cond
:= Build_Discriminant_Checks
(Expr
, Expr_Type
);
2015 Set_Discriminant_Constraint
(Expr_Type
, Old_Constraints
);
2018 Make_Raise_Constraint_Error
(Loc
,
2020 Reason
=> CE_Discriminant_Check_Failed
));
2023 -- For arrays, conversions are applied during expansion, to take
2024 -- into accounts changes of representation. The checks become range
2025 -- checks on the base type or length checks on the subtype, depending
2026 -- on whether the target type is unconstrained or constrained.
2031 end Apply_Type_Conversion_Checks
;
2033 ----------------------------------------------
2034 -- Apply_Universal_Integer_Attribute_Checks --
2035 ----------------------------------------------
2037 procedure Apply_Universal_Integer_Attribute_Checks
(N
: Node_Id
) is
2038 Loc
: constant Source_Ptr
:= Sloc
(N
);
2039 Typ
: constant Entity_Id
:= Etype
(N
);
2042 if Inside_A_Generic
then
2045 -- Nothing to do if checks are suppressed
2047 elsif Range_Checks_Suppressed
(Typ
)
2048 and then Overflow_Checks_Suppressed
(Typ
)
2052 -- Nothing to do if the attribute does not come from source. The
2053 -- internal attributes we generate of this type do not need checks,
2054 -- and furthermore the attempt to check them causes some circular
2055 -- elaboration orders when dealing with packed types.
2057 elsif not Comes_From_Source
(N
) then
2060 -- If the prefix is a selected component that depends on a discriminant
2061 -- the check may improperly expose a discriminant instead of using
2062 -- the bounds of the object itself. Set the type of the attribute to
2063 -- the base type of the context, so that a check will be imposed when
2064 -- needed (e.g. if the node appears as an index).
2066 elsif Nkind
(Prefix
(N
)) = N_Selected_Component
2067 and then Ekind
(Typ
) = E_Signed_Integer_Subtype
2068 and then Depends_On_Discriminant
(Scalar_Range
(Typ
))
2070 Set_Etype
(N
, Base_Type
(Typ
));
2072 -- Otherwise, replace the attribute node with a type conversion
2073 -- node whose expression is the attribute, retyped to universal
2074 -- integer, and whose subtype mark is the target type. The call
2075 -- to analyze this conversion will set range and overflow checks
2076 -- as required for proper detection of an out of range value.
2079 Set_Etype
(N
, Universal_Integer
);
2080 Set_Analyzed
(N
, True);
2083 Make_Type_Conversion
(Loc
,
2084 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
2085 Expression
=> Relocate_Node
(N
)));
2087 Analyze_And_Resolve
(N
, Typ
);
2091 end Apply_Universal_Integer_Attribute_Checks
;
2093 -------------------------------
2094 -- Build_Discriminant_Checks --
2095 -------------------------------
2097 function Build_Discriminant_Checks
2102 Loc
: constant Source_Ptr
:= Sloc
(N
);
2105 Disc_Ent
: Entity_Id
;
2111 Disc
:= First_Elmt
(Discriminant_Constraint
(T_Typ
));
2113 -- For a fully private type, use the discriminants of the parent type
2115 if Is_Private_Type
(T_Typ
)
2116 and then No
(Full_View
(T_Typ
))
2118 Disc_Ent
:= First_Discriminant
(Etype
(Base_Type
(T_Typ
)));
2120 Disc_Ent
:= First_Discriminant
(T_Typ
);
2123 while Present
(Disc
) loop
2124 Dval
:= Node
(Disc
);
2126 if Nkind
(Dval
) = N_Identifier
2127 and then Ekind
(Entity
(Dval
)) = E_Discriminant
2129 Dval
:= New_Occurrence_Of
(Discriminal
(Entity
(Dval
)), Loc
);
2131 Dval
:= Duplicate_Subexpr_No_Checks
(Dval
);
2135 Make_Selected_Component
(Loc
,
2137 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
2139 Make_Identifier
(Loc
, Chars
(Disc_Ent
)));
2141 Set_Is_In_Discriminant_Check
(Dref
);
2143 Evolve_Or_Else
(Cond
,
2146 Right_Opnd
=> Dval
));
2149 Next_Discriminant
(Disc_Ent
);
2153 end Build_Discriminant_Checks
;
2155 -----------------------------------
2156 -- Check_Valid_Lvalue_Subscripts --
2157 -----------------------------------
2159 procedure Check_Valid_Lvalue_Subscripts
(Expr
: Node_Id
) is
2161 -- Skip this if range checks are suppressed
2163 if Range_Checks_Suppressed
(Etype
(Expr
)) then
2166 -- Only do this check for expressions that come from source. We
2167 -- assume that expander generated assignments explicitly include
2168 -- any necessary checks. Note that this is not just an optimization,
2169 -- it avoids infinite recursions!
2171 elsif not Comes_From_Source
(Expr
) then
2174 -- For a selected component, check the prefix
2176 elsif Nkind
(Expr
) = N_Selected_Component
then
2177 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
2180 -- Case of indexed component
2182 elsif Nkind
(Expr
) = N_Indexed_Component
then
2183 Apply_Subscript_Validity_Checks
(Expr
);
2185 -- Prefix may itself be or contain an indexed component, and
2186 -- these subscripts need checking as well
2188 Check_Valid_Lvalue_Subscripts
(Prefix
(Expr
));
2190 end Check_Valid_Lvalue_Subscripts
;
2192 ----------------------------------
2193 -- Conditional_Statements_Begin --
2194 ----------------------------------
2196 procedure Conditional_Statements_Begin
is
2198 Saved_Checks_TOS
:= Saved_Checks_TOS
+ 1;
2200 -- If stack overflows, kill all checks, that way we know to
2201 -- simply reset the number of saved checks to zero on return.
2202 -- This should never occur in practice.
2204 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
2207 -- In the normal case, we just make a new stack entry saving
2208 -- the current number of saved checks for a later restore.
2211 Saved_Checks_Stack
(Saved_Checks_TOS
) := Num_Saved_Checks
;
2213 if Debug_Flag_CC
then
2214 w
("Conditional_Statements_Begin: Num_Saved_Checks = ",
2218 end Conditional_Statements_Begin
;
2220 --------------------------------
2221 -- Conditional_Statements_End --
2222 --------------------------------
2224 procedure Conditional_Statements_End
is
2226 pragma Assert
(Saved_Checks_TOS
> 0);
2228 -- If the saved checks stack overflowed, then we killed all
2229 -- checks, so setting the number of saved checks back to
2230 -- zero is correct. This should never occur in practice.
2232 if Saved_Checks_TOS
> Saved_Checks_Stack
'Last then
2233 Num_Saved_Checks
:= 0;
2235 -- In the normal case, restore the number of saved checks
2236 -- from the top stack entry.
2239 Num_Saved_Checks
:= Saved_Checks_Stack
(Saved_Checks_TOS
);
2240 if Debug_Flag_CC
then
2241 w
("Conditional_Statements_End: Num_Saved_Checks = ",
2246 Saved_Checks_TOS
:= Saved_Checks_TOS
- 1;
2247 end Conditional_Statements_End
;
2249 ---------------------
2250 -- Determine_Range --
2251 ---------------------
2253 Cache_Size
: constant := 2 ** 10;
2254 type Cache_Index
is range 0 .. Cache_Size
- 1;
2255 -- Determine size of below cache (power of 2 is more efficient!)
2257 Determine_Range_Cache_N
: array (Cache_Index
) of Node_Id
;
2258 Determine_Range_Cache_Lo
: array (Cache_Index
) of Uint
;
2259 Determine_Range_Cache_Hi
: array (Cache_Index
) of Uint
;
2260 -- The above arrays are used to implement a small direct cache
2261 -- for Determine_Range calls. Because of the way Determine_Range
2262 -- recursively traces subexpressions, and because overflow checking
2263 -- calls the routine on the way up the tree, a quadratic behavior
2264 -- can otherwise be encountered in large expressions. The cache
2265 -- entry for node N is stored in the (N mod Cache_Size) entry, and
2266 -- can be validated by checking the actual node value stored there.
2268 procedure Determine_Range
2274 Typ
: constant Entity_Id
:= Etype
(N
);
2278 -- Lo and Hi bounds of left operand
2282 -- Lo and Hi bounds of right (or only) operand
2285 -- Temp variable used to hold a bound node
2288 -- High bound of base type of expression
2292 -- Refined values for low and high bounds, after tightening
2295 -- Used in lower level calls to indicate if call succeeded
2297 Cindex
: Cache_Index
;
2298 -- Used to search cache
2300 function OK_Operands
return Boolean;
2301 -- Used for binary operators. Determines the ranges of the left and
2302 -- right operands, and if they are both OK, returns True, and puts
2303 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left
2309 function OK_Operands
return Boolean is
2311 Determine_Range
(Left_Opnd
(N
), OK1
, Lo_Left
, Hi_Left
);
2317 Determine_Range
(Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
);
2321 -- Start of processing for Determine_Range
2324 -- Prevent junk warnings by initializing range variables
2331 -- If the type is not discrete, or is undefined, then we can't
2332 -- do anything about determining the range.
2334 if No
(Typ
) or else not Is_Discrete_Type
(Typ
)
2335 or else Error_Posted
(N
)
2341 -- For all other cases, we can determine the range
2345 -- If value is compile time known, then the possible range is the
2346 -- one value that we know this expression definitely has!
2348 if Compile_Time_Known_Value
(N
) then
2349 Lo
:= Expr_Value
(N
);
2354 -- Return if already in the cache
2356 Cindex
:= Cache_Index
(N
mod Cache_Size
);
2358 if Determine_Range_Cache_N
(Cindex
) = N
then
2359 Lo
:= Determine_Range_Cache_Lo
(Cindex
);
2360 Hi
:= Determine_Range_Cache_Hi
(Cindex
);
2364 -- Otherwise, start by finding the bounds of the type of the
2365 -- expression, the value cannot be outside this range (if it
2366 -- is, then we have an overflow situation, which is a separate
2367 -- check, we are talking here only about the expression value).
2369 -- We use the actual bound unless it is dynamic, in which case
2370 -- use the corresponding base type bound if possible. If we can't
2371 -- get a bound then we figure we can't determine the range (a
2372 -- peculiar case, that perhaps cannot happen, but there is no
2373 -- point in bombing in this optimization circuit.
2375 -- First the low bound
2377 Bound
:= Type_Low_Bound
(Typ
);
2379 if Compile_Time_Known_Value
(Bound
) then
2380 Lo
:= Expr_Value
(Bound
);
2382 elsif Compile_Time_Known_Value
(Type_Low_Bound
(Base_Type
(Typ
))) then
2383 Lo
:= Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
)));
2390 -- Now the high bound
2392 Bound
:= Type_High_Bound
(Typ
);
2394 -- We need the high bound of the base type later on, and this should
2395 -- always be compile time known. Again, it is not clear that this
2396 -- can ever be false, but no point in bombing.
2398 if Compile_Time_Known_Value
(Type_High_Bound
(Base_Type
(Typ
))) then
2399 Hbound
:= Expr_Value
(Type_High_Bound
(Base_Type
(Typ
)));
2407 -- If we have a static subtype, then that may have a tighter bound
2408 -- so use the upper bound of the subtype instead in this case.
2410 if Compile_Time_Known_Value
(Bound
) then
2411 Hi
:= Expr_Value
(Bound
);
2414 -- We may be able to refine this value in certain situations. If
2415 -- refinement is possible, then Lor and Hir are set to possibly
2416 -- tighter bounds, and OK1 is set to True.
2420 -- For unary plus, result is limited by range of operand
2423 Determine_Range
(Right_Opnd
(N
), OK1
, Lor
, Hir
);
2425 -- For unary minus, determine range of operand, and negate it
2428 Determine_Range
(Right_Opnd
(N
), OK1
, Lo_Right
, Hi_Right
);
2435 -- For binary addition, get range of each operand and do the
2436 -- addition to get the result range.
2440 Lor
:= Lo_Left
+ Lo_Right
;
2441 Hir
:= Hi_Left
+ Hi_Right
;
2444 -- Division is tricky. The only case we consider is where the
2445 -- right operand is a positive constant, and in this case we
2446 -- simply divide the bounds of the left operand
2450 if Lo_Right
= Hi_Right
2451 and then Lo_Right
> 0
2453 Lor
:= Lo_Left
/ Lo_Right
;
2454 Hir
:= Hi_Left
/ Lo_Right
;
2461 -- For binary subtraction, get range of each operand and do
2462 -- the worst case subtraction to get the result range.
2464 when N_Op_Subtract
=>
2466 Lor
:= Lo_Left
- Hi_Right
;
2467 Hir
:= Hi_Left
- Lo_Right
;
2470 -- For MOD, if right operand is a positive constant, then
2471 -- result must be in the allowable range of mod results.
2475 if Lo_Right
= Hi_Right
2476 and then Lo_Right
/= 0
2478 if Lo_Right
> 0 then
2480 Hir
:= Lo_Right
- 1;
2482 else -- Lo_Right < 0
2483 Lor
:= Lo_Right
+ 1;
2492 -- For REM, if right operand is a positive constant, then
2493 -- result must be in the allowable range of mod results.
2497 if Lo_Right
= Hi_Right
2498 and then Lo_Right
/= 0
2501 Dval
: constant Uint
:= (abs Lo_Right
) - 1;
2504 -- The sign of the result depends on the sign of the
2505 -- dividend (but not on the sign of the divisor, hence
2506 -- the abs operation above).
2526 -- Attribute reference cases
2528 when N_Attribute_Reference
=>
2529 case Attribute_Name
(N
) is
2531 -- For Pos/Val attributes, we can refine the range using the
2532 -- possible range of values of the attribute expression
2534 when Name_Pos | Name_Val
=>
2535 Determine_Range
(First
(Expressions
(N
)), OK1
, Lor
, Hir
);
2537 -- For Length attribute, use the bounds of the corresponding
2538 -- index type to refine the range.
2542 Atyp
: Entity_Id
:= Etype
(Prefix
(N
));
2550 if Is_Access_Type
(Atyp
) then
2551 Atyp
:= Designated_Type
(Atyp
);
2554 -- For string literal, we know exact value
2556 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
2558 Lo
:= String_Literal_Length
(Atyp
);
2559 Hi
:= String_Literal_Length
(Atyp
);
2563 -- Otherwise check for expression given
2565 if No
(Expressions
(N
)) then
2569 UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
2572 Indx
:= First_Index
(Atyp
);
2573 for J
in 2 .. Inum
loop
2574 Indx
:= Next_Index
(Indx
);
2578 (Type_Low_Bound
(Etype
(Indx
)), OK1
, LL
, LU
);
2582 (Type_High_Bound
(Etype
(Indx
)), OK1
, UL
, UU
);
2586 -- The maximum value for Length is the biggest
2587 -- possible gap between the values of the bounds.
2588 -- But of course, this value cannot be negative.
2590 Hir
:= UI_Max
(Uint_0
, UU
- LL
);
2592 -- For constrained arrays, the minimum value for
2593 -- Length is taken from the actual value of the
2594 -- bounds, since the index will be exactly of
2597 if Is_Constrained
(Atyp
) then
2598 Lor
:= UI_Max
(Uint_0
, UL
- LU
);
2600 -- For an unconstrained array, the minimum value
2601 -- for length is always zero.
2610 -- No special handling for other attributes
2611 -- Probably more opportunities exist here ???
2618 -- For type conversion from one discrete type to another, we
2619 -- can refine the range using the converted value.
2621 when N_Type_Conversion
=>
2622 Determine_Range
(Expression
(N
), OK1
, Lor
, Hir
);
2624 -- Nothing special to do for all other expression kinds
2632 -- At this stage, if OK1 is true, then we know that the actual
2633 -- result of the computed expression is in the range Lor .. Hir.
2634 -- We can use this to restrict the possible range of results.
2638 -- If the refined value of the low bound is greater than the
2639 -- type high bound, then reset it to the more restrictive
2640 -- value. However, we do NOT do this for the case of a modular
2641 -- type where the possible upper bound on the value is above the
2642 -- base type high bound, because that means the result could wrap.
2645 and then not (Is_Modular_Integer_Type
(Typ
)
2646 and then Hir
> Hbound
)
2651 -- Similarly, if the refined value of the high bound is less
2652 -- than the value so far, then reset it to the more restrictive
2653 -- value. Again, we do not do this if the refined low bound is
2654 -- negative for a modular type, since this would wrap.
2657 and then not (Is_Modular_Integer_Type
(Typ
)
2658 and then Lor
< Uint_0
)
2664 -- Set cache entry for future call and we are all done
2666 Determine_Range_Cache_N
(Cindex
) := N
;
2667 Determine_Range_Cache_Lo
(Cindex
) := Lo
;
2668 Determine_Range_Cache_Hi
(Cindex
) := Hi
;
2671 -- If any exception occurs, it means that we have some bug in the compiler
2672 -- possibly triggered by a previous error, or by some unforseen peculiar
2673 -- occurrence. However, this is only an optimization attempt, so there is
2674 -- really no point in crashing the compiler. Instead we just decide, too
2675 -- bad, we can't figure out a range in this case after all.
2680 -- Debug flag K disables this behavior (useful for debugging)
2682 if Debug_Flag_K
then
2690 end Determine_Range
;
2692 ------------------------------------
2693 -- Discriminant_Checks_Suppressed --
2694 ------------------------------------
2696 function Discriminant_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
2699 if Is_Unchecked_Union
(E
) then
2701 elsif Checks_May_Be_Suppressed
(E
) then
2702 return Is_Check_Suppressed
(E
, Discriminant_Check
);
2706 return Scope_Suppress
(Discriminant_Check
);
2707 end Discriminant_Checks_Suppressed
;
2709 --------------------------------
2710 -- Division_Checks_Suppressed --
2711 --------------------------------
2713 function Division_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
2715 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
2716 return Is_Check_Suppressed
(E
, Division_Check
);
2718 return Scope_Suppress
(Division_Check
);
2720 end Division_Checks_Suppressed
;
2722 -----------------------------------
2723 -- Elaboration_Checks_Suppressed --
2724 -----------------------------------
2726 function Elaboration_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
2729 if Kill_Elaboration_Checks
(E
) then
2731 elsif Checks_May_Be_Suppressed
(E
) then
2732 return Is_Check_Suppressed
(E
, Elaboration_Check
);
2736 return Scope_Suppress
(Elaboration_Check
);
2737 end Elaboration_Checks_Suppressed
;
2739 ---------------------------
2740 -- Enable_Overflow_Check --
2741 ---------------------------
2743 procedure Enable_Overflow_Check
(N
: Node_Id
) is
2744 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
2753 if Debug_Flag_CC
then
2754 w
("Enable_Overflow_Check for node ", Int
(N
));
2755 Write_Str
(" Source location = ");
2760 -- Nothing to do if the range of the result is known OK. We skip
2761 -- this for conversions, since the caller already did the check,
2762 -- and in any case the condition for deleting the check for a
2763 -- type conversion is different in any case.
2765 if Nkind
(N
) /= N_Type_Conversion
then
2766 Determine_Range
(N
, OK
, Lo
, Hi
);
2768 -- Note in the test below that we assume that if a bound of the
2769 -- range is equal to that of the type. That's not quite accurate
2770 -- but we do this for the following reasons:
2772 -- a) The way that Determine_Range works, it will typically report
2773 -- the bounds of the value as being equal to the bounds of the
2774 -- type, because it either can't tell anything more precise, or
2775 -- does not think it is worth the effort to be more precise.
2777 -- b) It is very unusual to have a situation in which this would
2778 -- generate an unnecessary overflow check (an example would be
2779 -- a subtype with a range 0 .. Integer'Last - 1 to which the
2780 -- literal value one is added.
2782 -- c) The alternative is a lot of special casing in this routine
2783 -- which would partially duplicate Determine_Range processing.
2786 and then Lo
> Expr_Value
(Type_Low_Bound
(Typ
))
2787 and then Hi
< Expr_Value
(Type_High_Bound
(Typ
))
2789 if Debug_Flag_CC
then
2790 w
("No overflow check required");
2797 -- If not in optimizing mode, set flag and we are done. We are also
2798 -- done (and just set the flag) if the type is not a discrete type,
2799 -- since it is not worth the effort to eliminate checks for other
2800 -- than discrete types. In addition, we take this same path if we
2801 -- have stored the maximum number of checks possible already (a
2802 -- very unlikely situation, but we do not want to blow up!)
2804 if Optimization_Level
= 0
2805 or else not Is_Discrete_Type
(Etype
(N
))
2806 or else Num_Saved_Checks
= Saved_Checks
'Last
2808 Set_Do_Overflow_Check
(N
, True);
2810 if Debug_Flag_CC
then
2811 w
("Optimization off");
2817 -- Otherwise evaluate and check the expression
2822 Target_Type
=> Empty
,
2828 if Debug_Flag_CC
then
2829 w
("Called Find_Check");
2833 w
(" Check_Num = ", Chk
);
2834 w
(" Ent = ", Int
(Ent
));
2835 Write_Str
(" Ofs = ");
2840 -- If check is not of form to optimize, then set flag and we are done
2843 Set_Do_Overflow_Check
(N
, True);
2847 -- If check is already performed, then return without setting flag
2850 if Debug_Flag_CC
then
2851 w
("Check suppressed!");
2857 -- Here we will make a new entry for the new check
2859 Set_Do_Overflow_Check
(N
, True);
2860 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
2861 Saved_Checks
(Num_Saved_Checks
) :=
2866 Target_Type
=> Empty
);
2868 if Debug_Flag_CC
then
2869 w
("Make new entry, check number = ", Num_Saved_Checks
);
2870 w
(" Entity = ", Int
(Ent
));
2871 Write_Str
(" Offset = ");
2873 w
(" Check_Type = O");
2874 w
(" Target_Type = Empty");
2877 -- If we get an exception, then something went wrong, probably because
2878 -- of an error in the structure of the tree due to an incorrect program.
2879 -- Or it may be a bug in the optimization circuit. In either case the
2880 -- safest thing is simply to set the check flag unconditionally.
2884 Set_Do_Overflow_Check
(N
, True);
2886 if Debug_Flag_CC
then
2887 w
(" exception occurred, overflow flag set");
2891 end Enable_Overflow_Check
;
2893 ------------------------
2894 -- Enable_Range_Check --
2895 ------------------------
2897 procedure Enable_Range_Check
(N
: Node_Id
) is
2906 -- Return if unchecked type conversion with range check killed.
2907 -- In this case we never set the flag (that's what Kill_Range_Check
2910 if Nkind
(N
) = N_Unchecked_Type_Conversion
2911 and then Kill_Range_Check
(N
)
2916 -- Debug trace output
2918 if Debug_Flag_CC
then
2919 w
("Enable_Range_Check for node ", Int
(N
));
2920 Write_Str
(" Source location = ");
2925 -- If not in optimizing mode, set flag and we are done. We are also
2926 -- done (and just set the flag) if the type is not a discrete type,
2927 -- since it is not worth the effort to eliminate checks for other
2928 -- than discrete types. In addition, we take this same path if we
2929 -- have stored the maximum number of checks possible already (a
2930 -- very unlikely situation, but we do not want to blow up!)
2932 if Optimization_Level
= 0
2933 or else No
(Etype
(N
))
2934 or else not Is_Discrete_Type
(Etype
(N
))
2935 or else Num_Saved_Checks
= Saved_Checks
'Last
2937 Set_Do_Range_Check
(N
, True);
2939 if Debug_Flag_CC
then
2940 w
("Optimization off");
2946 -- Otherwise find out the target type
2950 -- For assignment, use left side subtype
2952 if Nkind
(P
) = N_Assignment_Statement
2953 and then Expression
(P
) = N
2955 Ttyp
:= Etype
(Name
(P
));
2957 -- For indexed component, use subscript subtype
2959 elsif Nkind
(P
) = N_Indexed_Component
then
2966 Atyp
:= Etype
(Prefix
(P
));
2968 if Is_Access_Type
(Atyp
) then
2969 Atyp
:= Designated_Type
(Atyp
);
2972 Indx
:= First_Index
(Atyp
);
2973 Subs
:= First
(Expressions
(P
));
2976 Ttyp
:= Etype
(Indx
);
2985 -- For now, ignore all other cases, they are not so interesting
2988 if Debug_Flag_CC
then
2989 w
(" target type not found, flag set");
2992 Set_Do_Range_Check
(N
, True);
2996 -- Evaluate and check the expression
3001 Target_Type
=> Ttyp
,
3007 if Debug_Flag_CC
then
3008 w
("Called Find_Check");
3009 w
("Target_Typ = ", Int
(Ttyp
));
3013 w
(" Check_Num = ", Chk
);
3014 w
(" Ent = ", Int
(Ent
));
3015 Write_Str
(" Ofs = ");
3020 -- If check is not of form to optimize, then set flag and we are done
3023 if Debug_Flag_CC
then
3024 w
(" expression not of optimizable type, flag set");
3027 Set_Do_Range_Check
(N
, True);
3031 -- If check is already performed, then return without setting flag
3034 if Debug_Flag_CC
then
3035 w
("Check suppressed!");
3041 -- Here we will make a new entry for the new check
3043 Set_Do_Range_Check
(N
, True);
3044 Num_Saved_Checks
:= Num_Saved_Checks
+ 1;
3045 Saved_Checks
(Num_Saved_Checks
) :=
3050 Target_Type
=> Ttyp
);
3052 if Debug_Flag_CC
then
3053 w
("Make new entry, check number = ", Num_Saved_Checks
);
3054 w
(" Entity = ", Int
(Ent
));
3055 Write_Str
(" Offset = ");
3057 w
(" Check_Type = R");
3058 w
(" Target_Type = ", Int
(Ttyp
));
3062 -- If we get an exception, then something went wrong, probably because
3063 -- of an error in the structure of the tree due to an incorrect program.
3064 -- Or it may be a bug in the optimization circuit. In either case the
3065 -- safest thing is simply to set the check flag unconditionally.
3069 Set_Do_Range_Check
(N
, True);
3071 if Debug_Flag_CC
then
3072 w
(" exception occurred, range flag set");
3076 end Enable_Range_Check
;
3082 procedure Ensure_Valid
(Expr
: Node_Id
; Holes_OK
: Boolean := False) is
3083 Typ
: constant Entity_Id
:= Etype
(Expr
);
3086 -- Ignore call if we are not doing any validity checking
3088 if not Validity_Checks_On
then
3091 -- Ignore call if range checks suppressed on entity in question
3093 elsif Is_Entity_Name
(Expr
)
3094 and then Range_Checks_Suppressed
(Entity
(Expr
))
3098 -- No check required if expression is from the expander, we assume
3099 -- the expander will generate whatever checks are needed. Note that
3100 -- this is not just an optimization, it avoids infinite recursions!
3102 -- Unchecked conversions must be checked, unless they are initialized
3103 -- scalar values, as in a component assignment in an init proc.
3105 -- In addition, we force a check if Force_Validity_Checks is set
3107 elsif not Comes_From_Source
(Expr
)
3108 and then not Force_Validity_Checks
3109 and then (Nkind
(Expr
) /= N_Unchecked_Type_Conversion
3110 or else Kill_Range_Check
(Expr
))
3114 -- No check required if expression is known to have valid value
3116 elsif Expr_Known_Valid
(Expr
) then
3119 -- No check required if checks off
3121 elsif Range_Checks_Suppressed
(Typ
) then
3124 -- Ignore case of enumeration with holes where the flag is set not
3125 -- to worry about holes, since no special validity check is needed
3127 elsif Is_Enumeration_Type
(Typ
)
3128 and then Has_Non_Standard_Rep
(Typ
)
3133 -- No check required on the left-hand side of an assignment.
3135 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
3136 and then Expr
= Name
(Parent
(Expr
))
3140 -- An annoying special case. If this is an out parameter of a scalar
3141 -- type, then the value is not going to be accessed, therefore it is
3142 -- inappropriate to do any validity check at the call site.
3145 -- Only need to worry about scalar types
3147 if Is_Scalar_Type
(Typ
) then
3157 -- Find actual argument (which may be a parameter association)
3158 -- and the parent of the actual argument (the call statement)
3163 if Nkind
(P
) = N_Parameter_Association
then
3168 -- Only need to worry if we are argument of a procedure
3169 -- call since functions don't have out parameters. If this
3170 -- is an indirect or dispatching call, get signature from
3171 -- the subprogram type.
3173 if Nkind
(P
) = N_Procedure_Call_Statement
then
3174 L
:= Parameter_Associations
(P
);
3176 if Is_Entity_Name
(Name
(P
)) then
3177 E
:= Entity
(Name
(P
));
3179 pragma Assert
(Nkind
(Name
(P
)) = N_Explicit_Dereference
);
3180 E
:= Etype
(Name
(P
));
3183 -- Only need to worry if there are indeed actuals, and
3184 -- if this could be a procedure call, otherwise we cannot
3185 -- get a match (either we are not an argument, or the
3186 -- mode of the formal is not OUT). This test also filters
3187 -- out the generic case.
3189 if Is_Non_Empty_List
(L
)
3190 and then Is_Subprogram
(E
)
3192 -- This is the loop through parameters, looking to
3193 -- see if there is an OUT parameter for which we are
3196 F
:= First_Formal
(E
);
3199 while Present
(F
) loop
3200 if Ekind
(F
) = E_Out_Parameter
and then A
= N
then
3213 -- If we fall through, a validity check is required. Note that it would
3214 -- not be good to set Do_Range_Check, even in contexts where this is
3215 -- permissible, since this flag causes checking against the target type,
3216 -- not the source type in contexts such as assignments
3218 Insert_Valid_Check
(Expr
);
3221 ----------------------
3222 -- Expr_Known_Valid --
3223 ----------------------
3225 function Expr_Known_Valid
(Expr
: Node_Id
) return Boolean is
3226 Typ
: constant Entity_Id
:= Etype
(Expr
);
3229 -- Non-scalar types are always consdered valid, since they never
3230 -- give rise to the issues of erroneous or bounded error behavior
3231 -- that are the concern. In formal reference manual terms the
3232 -- notion of validity only applies to scalar types.
3234 if not Is_Scalar_Type
(Typ
) then
3237 -- If no validity checking, then everything is considered valid
3239 elsif not Validity_Checks_On
then
3242 -- Floating-point types are considered valid unless floating-point
3243 -- validity checks have been specifically turned on.
3245 elsif Is_Floating_Point_Type
(Typ
)
3246 and then not Validity_Check_Floating_Point
3250 -- If the expression is the value of an object that is known to
3251 -- be valid, then clearly the expression value itself is valid.
3253 elsif Is_Entity_Name
(Expr
)
3254 and then Is_Known_Valid
(Entity
(Expr
))
3258 -- If the type is one for which all values are known valid, then
3259 -- we are sure that the value is valid except in the slightly odd
3260 -- case where the expression is a reference to a variable whose size
3261 -- has been explicitly set to a value greater than the object size.
3263 elsif Is_Known_Valid
(Typ
) then
3264 if Is_Entity_Name
(Expr
)
3265 and then Ekind
(Entity
(Expr
)) = E_Variable
3266 and then Esize
(Entity
(Expr
)) > Esize
(Typ
)
3273 -- Integer and character literals always have valid values, where
3274 -- appropriate these will be range checked in any case.
3276 elsif Nkind
(Expr
) = N_Integer_Literal
3278 Nkind
(Expr
) = N_Character_Literal
3282 -- If we have a type conversion or a qualification of a known valid
3283 -- value, then the result will always be valid.
3285 elsif Nkind
(Expr
) = N_Type_Conversion
3287 Nkind
(Expr
) = N_Qualified_Expression
3289 return Expr_Known_Valid
(Expression
(Expr
));
3291 -- The result of any function call or operator is always considered
3292 -- valid, since we assume the necessary checks are done by the call.
3294 elsif Nkind
(Expr
) in N_Binary_Op
3296 Nkind
(Expr
) in N_Unary_Op
3298 Nkind
(Expr
) = N_Function_Call
3302 -- For all other cases, we do not know the expression is valid
3307 end Expr_Known_Valid
;
3313 procedure Find_Check
3315 Check_Type
: Character;
3316 Target_Type
: Entity_Id
;
3317 Entry_OK
: out Boolean;
3318 Check_Num
: out Nat
;
3319 Ent
: out Entity_Id
;
3322 function Within_Range_Of
3323 (Target_Type
: Entity_Id
;
3324 Check_Type
: Entity_Id
)
3326 -- Given a requirement for checking a range against Target_Type, and
3327 -- and a range Check_Type against which a check has already been made,
3328 -- determines if the check against check type is sufficient to ensure
3329 -- that no check against Target_Type is required.
3331 ---------------------
3332 -- Within_Range_Of --
3333 ---------------------
3335 function Within_Range_Of
3336 (Target_Type
: Entity_Id
;
3337 Check_Type
: Entity_Id
)
3341 if Target_Type
= Check_Type
then
3346 Tlo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
3347 Thi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
3348 Clo
: constant Node_Id
:= Type_Low_Bound
(Check_Type
);
3349 Chi
: constant Node_Id
:= Type_High_Bound
(Check_Type
);
3353 or else (Compile_Time_Known_Value
(Tlo
)
3355 Compile_Time_Known_Value
(Clo
)
3357 Expr_Value
(Clo
) >= Expr_Value
(Tlo
)))
3360 or else (Compile_Time_Known_Value
(Thi
)
3362 Compile_Time_Known_Value
(Chi
)
3364 Expr_Value
(Chi
) <= Expr_Value
(Clo
)))
3372 end Within_Range_Of
;
3374 -- Start of processing for Find_Check
3377 -- Establish default, to avoid warnings from GCC.
3381 -- Case of expression is simple entity reference
3383 if Is_Entity_Name
(Expr
) then
3384 Ent
:= Entity
(Expr
);
3387 -- Case of expression is entity + known constant
3389 elsif Nkind
(Expr
) = N_Op_Add
3390 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3391 and then Is_Entity_Name
(Left_Opnd
(Expr
))
3393 Ent
:= Entity
(Left_Opnd
(Expr
));
3394 Ofs
:= Expr_Value
(Right_Opnd
(Expr
));
3396 -- Case of expression is entity - known constant
3398 elsif Nkind
(Expr
) = N_Op_Subtract
3399 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3400 and then Is_Entity_Name
(Left_Opnd
(Expr
))
3402 Ent
:= Entity
(Left_Opnd
(Expr
));
3403 Ofs
:= UI_Negate
(Expr_Value
(Right_Opnd
(Expr
)));
3405 -- Any other expression is not of the right form
3414 -- Come here with expression of appropriate form, check if
3415 -- entity is an appropriate one for our purposes.
3417 if (Ekind
(Ent
) = E_Variable
3419 Ekind
(Ent
) = E_Constant
3421 Ekind
(Ent
) = E_Loop_Parameter
3423 Ekind
(Ent
) = E_In_Parameter
)
3424 and then not Is_Library_Level_Entity
(Ent
)
3432 -- See if there is matching check already
3434 for J
in reverse 1 .. Num_Saved_Checks
loop
3436 SC
: Saved_Check
renames Saved_Checks
(J
);
3439 if SC
.Killed
= False
3440 and then SC
.Entity
= Ent
3441 and then SC
.Offset
= Ofs
3442 and then SC
.Check_Type
= Check_Type
3443 and then Within_Range_Of
(Target_Type
, SC
.Target_Type
)
3451 -- If we fall through entry was not found
3457 ---------------------------------
3458 -- Generate_Discriminant_Check --
3459 ---------------------------------
3461 -- Note: the code for this procedure is derived from the
3462 -- emit_discriminant_check routine a-trans.c v1.659.
3464 procedure Generate_Discriminant_Check
(N
: Node_Id
) is
3465 Loc
: constant Source_Ptr
:= Sloc
(N
);
3466 Pref
: constant Node_Id
:= Prefix
(N
);
3467 Sel
: constant Node_Id
:= Selector_Name
(N
);
3469 Orig_Comp
: constant Entity_Id
:=
3470 Original_Record_Component
(Entity
(Sel
));
3471 -- The original component to be checked
3473 Discr_Fct
: constant Entity_Id
:=
3474 Discriminant_Checking_Func
(Orig_Comp
);
3475 -- The discriminant checking function
3478 -- One discriminant to be checked in the type
3480 Real_Discr
: Entity_Id
;
3481 -- Actual discriminant in the call
3483 Pref_Type
: Entity_Id
;
3484 -- Type of relevant prefix (ignoring private/access stuff)
3487 -- List of arguments for function call
3490 -- Keep track of the formal corresponding to the actual we build
3491 -- for each discriminant, in order to be able to perform the
3492 -- necessary type conversions.
3495 -- Selected component reference for checking function argument
3498 Pref_Type
:= Etype
(Pref
);
3500 -- Force evaluation of the prefix, so that it does not get evaluated
3501 -- twice (once for the check, once for the actual reference). Such a
3502 -- double evaluation is always a potential source of inefficiency,
3503 -- and is functionally incorrect in the volatile case, or when the
3504 -- prefix may have side-effects. An entity or a component of an
3505 -- entity requires no evaluation.
3507 if Is_Entity_Name
(Pref
) then
3508 if Treat_As_Volatile
(Entity
(Pref
)) then
3509 Force_Evaluation
(Pref
, Name_Req
=> True);
3512 elsif Treat_As_Volatile
(Etype
(Pref
)) then
3513 Force_Evaluation
(Pref
, Name_Req
=> True);
3515 elsif Nkind
(Pref
) = N_Selected_Component
3516 and then Is_Entity_Name
(Prefix
(Pref
))
3521 Force_Evaluation
(Pref
, Name_Req
=> True);
3524 -- For a tagged type, use the scope of the original component to
3525 -- obtain the type, because ???
3527 if Is_Tagged_Type
(Scope
(Orig_Comp
)) then
3528 Pref_Type
:= Scope
(Orig_Comp
);
3530 -- For an untagged derived type, use the discriminants of the
3531 -- parent which have been renamed in the derivation, possibly
3532 -- by a one-to-many discriminant constraint.
3533 -- For non-tagged type, initially get the Etype of the prefix
3536 if Is_Derived_Type
(Pref_Type
)
3537 and then Number_Discriminants
(Pref_Type
) /=
3538 Number_Discriminants
(Etype
(Base_Type
(Pref_Type
)))
3540 Pref_Type
:= Etype
(Base_Type
(Pref_Type
));
3544 -- We definitely should have a checking function, This routine should
3545 -- not be called if no discriminant checking function is present.
3547 pragma Assert
(Present
(Discr_Fct
));
3549 -- Create the list of the actual parameters for the call. This list
3550 -- is the list of the discriminant fields of the record expression to
3551 -- be discriminant checked.
3554 Formal
:= First_Formal
(Discr_Fct
);
3555 Discr
:= First_Discriminant
(Pref_Type
);
3556 while Present
(Discr
) loop
3558 -- If we have a corresponding discriminant field, and a parent
3559 -- subtype is present, then we want to use the corresponding
3560 -- discriminant since this is the one with the useful value.
3562 if Present
(Corresponding_Discriminant
(Discr
))
3563 and then Ekind
(Pref_Type
) = E_Record_Type
3564 and then Present
(Parent_Subtype
(Pref_Type
))
3566 Real_Discr
:= Corresponding_Discriminant
(Discr
);
3568 Real_Discr
:= Discr
;
3571 -- Construct the reference to the discriminant
3574 Make_Selected_Component
(Loc
,
3576 Unchecked_Convert_To
(Pref_Type
,
3577 Duplicate_Subexpr
(Pref
)),
3578 Selector_Name
=> New_Occurrence_Of
(Real_Discr
, Loc
));
3580 -- Manually analyze and resolve this selected component. We really
3581 -- want it just as it appears above, and do not want the expander
3582 -- playing discriminal games etc with this reference. Then we
3583 -- append the argument to the list we are gathering.
3585 Set_Etype
(Scomp
, Etype
(Real_Discr
));
3586 Set_Analyzed
(Scomp
, True);
3587 Append_To
(Args
, Convert_To
(Etype
(Formal
), Scomp
));
3589 Next_Formal_With_Extras
(Formal
);
3590 Next_Discriminant
(Discr
);
3593 -- Now build and insert the call
3596 Make_Raise_Constraint_Error
(Loc
,
3598 Make_Function_Call
(Loc
,
3599 Name
=> New_Occurrence_Of
(Discr_Fct
, Loc
),
3600 Parameter_Associations
=> Args
),
3601 Reason
=> CE_Discriminant_Check_Failed
));
3602 end Generate_Discriminant_Check
;
3604 ----------------------------
3605 -- Generate_Index_Checks --
3606 ----------------------------
3608 procedure Generate_Index_Checks
(N
: Node_Id
) is
3609 Loc
: constant Source_Ptr
:= Sloc
(N
);
3610 A
: constant Node_Id
:= Prefix
(N
);
3616 Sub
:= First
(Expressions
(N
));
3618 while Present
(Sub
) loop
3619 if Do_Range_Check
(Sub
) then
3620 Set_Do_Range_Check
(Sub
, False);
3622 -- Force evaluation except for the case of a simple name of
3623 -- a non-volatile entity.
3625 if not Is_Entity_Name
(Sub
)
3626 or else Treat_As_Volatile
(Entity
(Sub
))
3628 Force_Evaluation
(Sub
);
3631 -- Generate a raise of constraint error with the appropriate
3632 -- reason and a condition of the form:
3634 -- Base_Type(Sub) not in array'range (subscript)
3636 -- Note that the reason we generate the conversion to the
3637 -- base type here is that we definitely want the range check
3638 -- to take place, even if it looks like the subtype is OK.
3639 -- Optimization considerations that allow us to omit the
3640 -- check have already been taken into account in the setting
3641 -- of the Do_Range_Check flag earlier on.
3646 Num
:= New_List
(Make_Integer_Literal
(Loc
, Ind
));
3650 Make_Raise_Constraint_Error
(Loc
,
3654 Convert_To
(Base_Type
(Etype
(Sub
)),
3655 Duplicate_Subexpr_Move_Checks
(Sub
)),
3657 Make_Attribute_Reference
(Loc
,
3658 Prefix
=> Duplicate_Subexpr_Move_Checks
(A
),
3659 Attribute_Name
=> Name_Range
,
3660 Expressions
=> Num
)),
3661 Reason
=> CE_Index_Check_Failed
));
3667 end Generate_Index_Checks
;
3669 --------------------------
3670 -- Generate_Range_Check --
3671 --------------------------
3673 procedure Generate_Range_Check
3675 Target_Type
: Entity_Id
;
3676 Reason
: RT_Exception_Code
)
3678 Loc
: constant Source_Ptr
:= Sloc
(N
);
3679 Source_Type
: constant Entity_Id
:= Etype
(N
);
3680 Source_Base_Type
: constant Entity_Id
:= Base_Type
(Source_Type
);
3681 Target_Base_Type
: constant Entity_Id
:= Base_Type
(Target_Type
);
3684 -- First special case, if the source type is already within the
3685 -- range of the target type, then no check is needed (probably we
3686 -- should have stopped Do_Range_Check from being set in the first
3687 -- place, but better late than later in preventing junk code!
3689 -- We do NOT apply this if the source node is a literal, since in
3690 -- this case the literal has already been labeled as having the
3691 -- subtype of the target.
3693 if In_Subrange_Of
(Source_Type
, Target_Type
)
3695 (Nkind
(N
) = N_Integer_Literal
3697 Nkind
(N
) = N_Real_Literal
3699 Nkind
(N
) = N_Character_Literal
3702 and then Ekind
(Entity
(N
)) = E_Enumeration_Literal
))
3707 -- We need a check, so force evaluation of the node, so that it does
3708 -- not get evaluated twice (once for the check, once for the actual
3709 -- reference). Such a double evaluation is always a potential source
3710 -- of inefficiency, and is functionally incorrect in the volatile case.
3712 if not Is_Entity_Name
(N
)
3713 or else Treat_As_Volatile
(Entity
(N
))
3715 Force_Evaluation
(N
);
3718 -- The easiest case is when Source_Base_Type and Target_Base_Type
3719 -- are the same since in this case we can simply do a direct
3720 -- check of the value of N against the bounds of Target_Type.
3722 -- [constraint_error when N not in Target_Type]
3724 -- Note: this is by far the most common case, for example all cases of
3725 -- checks on the RHS of assignments are in this category, but not all
3726 -- cases are like this. Notably conversions can involve two types.
3728 if Source_Base_Type
= Target_Base_Type
then
3730 Make_Raise_Constraint_Error
(Loc
,
3733 Left_Opnd
=> Duplicate_Subexpr
(N
),
3734 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
3737 -- Next test for the case where the target type is within the bounds
3738 -- of the base type of the source type, since in this case we can
3739 -- simply convert these bounds to the base type of T to do the test.
3741 -- [constraint_error when N not in
3742 -- Source_Base_Type (Target_Type'First)
3744 -- Source_Base_Type(Target_Type'Last))]
3746 -- The conversions will always work and need no check.
3748 elsif In_Subrange_Of
(Target_Type
, Source_Base_Type
) then
3750 Make_Raise_Constraint_Error
(Loc
,
3753 Left_Opnd
=> Duplicate_Subexpr
(N
),
3758 Convert_To
(Source_Base_Type
,
3759 Make_Attribute_Reference
(Loc
,
3761 New_Occurrence_Of
(Target_Type
, Loc
),
3762 Attribute_Name
=> Name_First
)),
3765 Convert_To
(Source_Base_Type
,
3766 Make_Attribute_Reference
(Loc
,
3768 New_Occurrence_Of
(Target_Type
, Loc
),
3769 Attribute_Name
=> Name_Last
)))),
3772 -- Note that at this stage we now that the Target_Base_Type is
3773 -- not in the range of the Source_Base_Type (since even the
3774 -- Target_Type itself is not in this range). It could still be
3775 -- the case that the Source_Type is in range of the target base
3776 -- type, since we have not checked that case.
3778 -- If that is the case, we can freely convert the source to the
3779 -- target, and then test the target result against the bounds.
3781 elsif In_Subrange_Of
(Source_Type
, Target_Base_Type
) then
3783 -- We make a temporary to hold the value of the converted
3784 -- value (converted to the base type), and then we will
3785 -- do the test against this temporary.
3787 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
3788 -- [constraint_error when Tnn not in Target_Type]
3790 -- Then the conversion itself is replaced by an occurrence of Tnn
3793 Tnn
: constant Entity_Id
:=
3794 Make_Defining_Identifier
(Loc
,
3795 Chars
=> New_Internal_Name
('T'));
3798 Insert_Actions
(N
, New_List
(
3799 Make_Object_Declaration
(Loc
,
3800 Defining_Identifier
=> Tnn
,
3801 Object_Definition
=>
3802 New_Occurrence_Of
(Target_Base_Type
, Loc
),
3803 Constant_Present
=> True,
3805 Make_Type_Conversion
(Loc
,
3806 Subtype_Mark
=> New_Occurrence_Of
(Target_Base_Type
, Loc
),
3807 Expression
=> Duplicate_Subexpr
(N
))),
3809 Make_Raise_Constraint_Error
(Loc
,
3812 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
3813 Right_Opnd
=> New_Occurrence_Of
(Target_Type
, Loc
)),
3815 Reason
=> Reason
)));
3817 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
3820 -- At this stage, we know that we have two scalar types, which are
3821 -- directly convertible, and where neither scalar type has a base
3822 -- range that is in the range of the other scalar type.
3824 -- The only way this can happen is with a signed and unsigned type.
3825 -- So test for these two cases:
3828 -- Case of the source is unsigned and the target is signed
3830 if Is_Unsigned_Type
(Source_Base_Type
)
3831 and then not Is_Unsigned_Type
(Target_Base_Type
)
3833 -- If the source is unsigned and the target is signed, then we
3834 -- know that the source is not shorter than the target (otherwise
3835 -- the source base type would be in the target base type range).
3837 -- In other words, the unsigned type is either the same size
3838 -- as the target, or it is larger. It cannot be smaller.
3841 (Esize
(Source_Base_Type
) >= Esize
(Target_Base_Type
));
3843 -- We only need to check the low bound if the low bound of the
3844 -- target type is non-negative. If the low bound of the target
3845 -- type is negative, then we know that we will fit fine.
3847 -- If the high bound of the target type is negative, then we
3848 -- know we have a constraint error, since we can't possibly
3849 -- have a negative source.
3851 -- With these two checks out of the way, we can do the check
3852 -- using the source type safely
3854 -- This is definitely the most annoying case!
3856 -- [constraint_error
3857 -- when (Target_Type'First >= 0
3859 -- N < Source_Base_Type (Target_Type'First))
3860 -- or else Target_Type'Last < 0
3861 -- or else N > Source_Base_Type (Target_Type'Last)];
3863 -- We turn off all checks since we know that the conversions
3864 -- will work fine, given the guards for negative values.
3867 Make_Raise_Constraint_Error
(Loc
,
3873 Left_Opnd
=> Make_Op_Ge
(Loc
,
3875 Make_Attribute_Reference
(Loc
,
3877 New_Occurrence_Of
(Target_Type
, Loc
),
3878 Attribute_Name
=> Name_First
),
3879 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
3883 Left_Opnd
=> Duplicate_Subexpr
(N
),
3885 Convert_To
(Source_Base_Type
,
3886 Make_Attribute_Reference
(Loc
,
3888 New_Occurrence_Of
(Target_Type
, Loc
),
3889 Attribute_Name
=> Name_First
)))),
3894 Make_Attribute_Reference
(Loc
,
3895 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
3896 Attribute_Name
=> Name_Last
),
3897 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
))),
3901 Left_Opnd
=> Duplicate_Subexpr
(N
),
3903 Convert_To
(Source_Base_Type
,
3904 Make_Attribute_Reference
(Loc
,
3905 Prefix
=> New_Occurrence_Of
(Target_Type
, Loc
),
3906 Attribute_Name
=> Name_Last
)))),
3909 Suppress
=> All_Checks
);
3911 -- Only remaining possibility is that the source is signed and
3912 -- the target is unsigned
3915 pragma Assert
(not Is_Unsigned_Type
(Source_Base_Type
)
3916 and then Is_Unsigned_Type
(Target_Base_Type
));
3918 -- If the source is signed and the target is unsigned, then
3919 -- we know that the target is not shorter than the source
3920 -- (otherwise the target base type would be in the source
3921 -- base type range).
3923 -- In other words, the unsigned type is either the same size
3924 -- as the target, or it is larger. It cannot be smaller.
3926 -- Clearly we have an error if the source value is negative
3927 -- since no unsigned type can have negative values. If the
3928 -- source type is non-negative, then the check can be done
3929 -- using the target type.
3931 -- Tnn : constant Target_Base_Type (N) := Target_Type;
3933 -- [constraint_error
3934 -- when N < 0 or else Tnn not in Target_Type];
3936 -- We turn off all checks for the conversion of N to the
3937 -- target base type, since we generate the explicit check
3938 -- to ensure that the value is non-negative
3941 Tnn
: constant Entity_Id
:=
3942 Make_Defining_Identifier
(Loc
,
3943 Chars
=> New_Internal_Name
('T'));
3946 Insert_Actions
(N
, New_List
(
3947 Make_Object_Declaration
(Loc
,
3948 Defining_Identifier
=> Tnn
,
3949 Object_Definition
=>
3950 New_Occurrence_Of
(Target_Base_Type
, Loc
),
3951 Constant_Present
=> True,
3953 Make_Type_Conversion
(Loc
,
3955 New_Occurrence_Of
(Target_Base_Type
, Loc
),
3956 Expression
=> Duplicate_Subexpr
(N
))),
3958 Make_Raise_Constraint_Error
(Loc
,
3963 Left_Opnd
=> Duplicate_Subexpr
(N
),
3964 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
3968 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
3970 New_Occurrence_Of
(Target_Type
, Loc
))),
3973 Suppress
=> All_Checks
);
3975 -- Set the Etype explicitly, because Insert_Actions may
3976 -- have placed the declaration in the freeze list for an
3977 -- enclosing construct, and thus it is not analyzed yet.
3979 Set_Etype
(Tnn
, Target_Base_Type
);
3980 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
3984 end Generate_Range_Check
;
3986 ---------------------
3987 -- Get_Discriminal --
3988 ---------------------
3990 function Get_Discriminal
(E
: Entity_Id
; Bound
: Node_Id
) return Node_Id
is
3991 Loc
: constant Source_Ptr
:= Sloc
(E
);
3996 -- The entity E is the type of a private component of the protected
3997 -- type, or the type of a renaming of that component within a protected
3998 -- operation of that type.
4002 if Ekind
(Sc
) /= E_Protected_Type
then
4005 if Ekind
(Sc
) /= E_Protected_Type
then
4010 D
:= First_Discriminant
(Sc
);
4013 and then Chars
(D
) /= Chars
(Bound
)
4015 Next_Discriminant
(D
);
4018 return New_Occurrence_Of
(Discriminal
(D
), Loc
);
4019 end Get_Discriminal
;
4025 function Guard_Access
4032 if Nkind
(Cond
) = N_Or_Else
then
4033 Set_Paren_Count
(Cond
, 1);
4036 if Nkind
(Ck_Node
) = N_Allocator
then
4043 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Ck_Node
),
4044 Right_Opnd
=> Make_Null
(Loc
)),
4045 Right_Opnd
=> Cond
);
4049 -----------------------------
4050 -- Index_Checks_Suppressed --
4051 -----------------------------
4053 function Index_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4055 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4056 return Is_Check_Suppressed
(E
, Index_Check
);
4058 return Scope_Suppress
(Index_Check
);
4060 end Index_Checks_Suppressed
;
4066 procedure Initialize
is
4068 for J
in Determine_Range_Cache_N
'Range loop
4069 Determine_Range_Cache_N
(J
) := Empty
;
4073 -------------------------
4074 -- Insert_Range_Checks --
4075 -------------------------
4077 procedure Insert_Range_Checks
4078 (Checks
: Check_Result
;
4080 Suppress_Typ
: Entity_Id
;
4081 Static_Sloc
: Source_Ptr
:= No_Location
;
4082 Flag_Node
: Node_Id
:= Empty
;
4083 Do_Before
: Boolean := False)
4085 Internal_Flag_Node
: Node_Id
:= Flag_Node
;
4086 Internal_Static_Sloc
: Source_Ptr
:= Static_Sloc
;
4088 Check_Node
: Node_Id
;
4089 Checks_On
: constant Boolean :=
4090 (not Index_Checks_Suppressed
(Suppress_Typ
))
4092 (not Range_Checks_Suppressed
(Suppress_Typ
));
4095 -- For now we just return if Checks_On is false, however this should
4096 -- be enhanced to check for an always True value in the condition
4097 -- and to generate a compilation warning???
4099 if not Expander_Active
or else not Checks_On
then
4103 if Static_Sloc
= No_Location
then
4104 Internal_Static_Sloc
:= Sloc
(Node
);
4107 if No
(Flag_Node
) then
4108 Internal_Flag_Node
:= Node
;
4111 for J
in 1 .. 2 loop
4112 exit when No
(Checks
(J
));
4114 if Nkind
(Checks
(J
)) = N_Raise_Constraint_Error
4115 and then Present
(Condition
(Checks
(J
)))
4117 if not Has_Dynamic_Range_Check
(Internal_Flag_Node
) then
4118 Check_Node
:= Checks
(J
);
4119 Mark_Rewrite_Insertion
(Check_Node
);
4122 Insert_Before_And_Analyze
(Node
, Check_Node
);
4124 Insert_After_And_Analyze
(Node
, Check_Node
);
4127 Set_Has_Dynamic_Range_Check
(Internal_Flag_Node
);
4132 Make_Raise_Constraint_Error
(Internal_Static_Sloc
,
4133 Reason
=> CE_Range_Check_Failed
);
4134 Mark_Rewrite_Insertion
(Check_Node
);
4137 Insert_Before_And_Analyze
(Node
, Check_Node
);
4139 Insert_After_And_Analyze
(Node
, Check_Node
);
4143 end Insert_Range_Checks
;
4145 ------------------------
4146 -- Insert_Valid_Check --
4147 ------------------------
4149 procedure Insert_Valid_Check
(Expr
: Node_Id
) is
4150 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
4154 -- Do not insert if checks off, or if not checking validity
4156 if Range_Checks_Suppressed
(Etype
(Expr
))
4157 or else (not Validity_Checks_On
)
4162 -- If we have a checked conversion, then validity check applies to
4163 -- the expression inside the conversion, not the result, since if
4164 -- the expression inside is valid, then so is the conversion result.
4167 while Nkind
(Exp
) = N_Type_Conversion
loop
4168 Exp
:= Expression
(Exp
);
4171 -- Insert the validity check. Note that we do this with validity
4172 -- checks turned off, to avoid recursion, we do not want validity
4173 -- checks on the validity checking code itself!
4175 Validity_Checks_On
:= False;
4178 Make_Raise_Constraint_Error
(Loc
,
4182 Make_Attribute_Reference
(Loc
,
4184 Duplicate_Subexpr_No_Checks
(Exp
, Name_Req
=> True),
4185 Attribute_Name
=> Name_Valid
)),
4186 Reason
=> CE_Invalid_Data
),
4187 Suppress
=> All_Checks
);
4188 Validity_Checks_On
:= True;
4189 end Insert_Valid_Check
;
4191 --------------------------
4192 -- Install_Static_Check --
4193 --------------------------
4195 procedure Install_Static_Check
(R_Cno
: Node_Id
; Loc
: Source_Ptr
) is
4196 Stat
: constant Boolean := Is_Static_Expression
(R_Cno
);
4197 Typ
: constant Entity_Id
:= Etype
(R_Cno
);
4201 Make_Raise_Constraint_Error
(Loc
,
4202 Reason
=> CE_Range_Check_Failed
));
4203 Set_Analyzed
(R_Cno
);
4204 Set_Etype
(R_Cno
, Typ
);
4205 Set_Raises_Constraint_Error
(R_Cno
);
4206 Set_Is_Static_Expression
(R_Cno
, Stat
);
4207 end Install_Static_Check
;
4209 ---------------------
4210 -- Kill_All_Checks --
4211 ---------------------
4213 procedure Kill_All_Checks
is
4215 if Debug_Flag_CC
then
4216 w
("Kill_All_Checks");
4219 -- We reset the number of saved checks to zero, and also modify
4220 -- all stack entries for statement ranges to indicate that the
4221 -- number of checks at each level is now zero.
4223 Num_Saved_Checks
:= 0;
4225 for J
in 1 .. Saved_Checks_TOS
loop
4226 Saved_Checks_Stack
(J
) := 0;
4228 end Kill_All_Checks
;
4234 procedure Kill_Checks
(V
: Entity_Id
) is
4236 if Debug_Flag_CC
then
4237 w
("Kill_Checks for entity", Int
(V
));
4240 for J
in 1 .. Num_Saved_Checks
loop
4241 if Saved_Checks
(J
).Entity
= V
then
4242 if Debug_Flag_CC
then
4243 w
(" Checks killed for saved check ", J
);
4246 Saved_Checks
(J
).Killed
:= True;
4251 ------------------------------
4252 -- Length_Checks_Suppressed --
4253 ------------------------------
4255 function Length_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4257 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4258 return Is_Check_Suppressed
(E
, Length_Check
);
4260 return Scope_Suppress
(Length_Check
);
4262 end Length_Checks_Suppressed
;
4264 --------------------------------
4265 -- Overflow_Checks_Suppressed --
4266 --------------------------------
4268 function Overflow_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4270 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
4271 return Is_Check_Suppressed
(E
, Overflow_Check
);
4273 return Scope_Suppress
(Overflow_Check
);
4275 end Overflow_Checks_Suppressed
;
4281 function Range_Check
4283 Target_Typ
: Entity_Id
;
4284 Source_Typ
: Entity_Id
:= Empty
;
4285 Warn_Node
: Node_Id
:= Empty
)
4289 return Selected_Range_Checks
4290 (Ck_Node
, Target_Typ
, Source_Typ
, Warn_Node
);
4293 -----------------------------
4294 -- Range_Checks_Suppressed --
4295 -----------------------------
4297 function Range_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
4301 -- Note: for now we always suppress range checks on Vax float types,
4302 -- since Gigi does not know how to generate these checks.
4304 if Vax_Float
(E
) then
4306 elsif Kill_Range_Checks
(E
) then
4308 elsif Checks_May_Be_Suppressed
(E
) then
4309 return Is_Check_Suppressed
(E
, Range_Check
);
4313 return Scope_Suppress
(Range_Check
);
4314 end Range_Checks_Suppressed
;
4320 procedure Remove_Checks
(Expr
: Node_Id
) is
4321 Discard
: Traverse_Result
;
4322 pragma Warnings
(Off
, Discard
);
4324 function Process
(N
: Node_Id
) return Traverse_Result
;
4325 -- Process a single node during the traversal
4327 function Traverse
is new Traverse_Func
(Process
);
4328 -- The traversal function itself
4334 function Process
(N
: Node_Id
) return Traverse_Result
is
4336 if Nkind
(N
) not in N_Subexpr
then
4340 Set_Do_Range_Check
(N
, False);
4344 Discard
:= Traverse
(Left_Opnd
(N
));
4347 when N_Attribute_Reference
=>
4348 Set_Do_Overflow_Check
(N
, False);
4350 when N_Function_Call
=>
4351 Set_Do_Tag_Check
(N
, False);
4354 Set_Do_Overflow_Check
(N
, False);
4358 Set_Do_Division_Check
(N
, False);
4361 Set_Do_Length_Check
(N
, False);
4364 Set_Do_Division_Check
(N
, False);
4367 Set_Do_Length_Check
(N
, False);
4370 Set_Do_Division_Check
(N
, False);
4373 Set_Do_Length_Check
(N
, False);
4380 Discard
:= Traverse
(Left_Opnd
(N
));
4383 when N_Selected_Component
=>
4384 Set_Do_Discriminant_Check
(N
, False);
4386 when N_Type_Conversion
=>
4387 Set_Do_Length_Check
(N
, False);
4388 Set_Do_Tag_Check
(N
, False);
4389 Set_Do_Overflow_Check
(N
, False);
4398 -- Start of processing for Remove_Checks
4401 Discard
:= Traverse
(Expr
);
4404 ----------------------------
4405 -- Selected_Length_Checks --
4406 ----------------------------
4408 function Selected_Length_Checks
4410 Target_Typ
: Entity_Id
;
4411 Source_Typ
: Entity_Id
;
4412 Warn_Node
: Node_Id
)
4415 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
4418 Expr_Actual
: Node_Id
;
4420 Cond
: Node_Id
:= Empty
;
4421 Do_Access
: Boolean := False;
4422 Wnode
: Node_Id
:= Warn_Node
;
4423 Ret_Result
: Check_Result
:= (Empty
, Empty
);
4424 Num_Checks
: Natural := 0;
4426 procedure Add_Check
(N
: Node_Id
);
4427 -- Adds the action given to Ret_Result if N is non-Empty
4429 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
;
4430 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
4432 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean;
4433 -- True for equal literals and for nodes that denote the same constant
4434 -- entity, even if its value is not a static constant. This includes the
4435 -- case of a discriminal reference within an init proc. Removes some
4436 -- obviously superfluous checks.
4438 function Length_E_Cond
4439 (Exptyp
: Entity_Id
;
4443 -- Returns expression to compute:
4444 -- Typ'Length /= Exptyp'Length
4446 function Length_N_Cond
4451 -- Returns expression to compute:
4452 -- Typ'Length /= Expr'Length
4458 procedure Add_Check
(N
: Node_Id
) is
4462 -- For now, ignore attempt to place more than 2 checks ???
4464 if Num_Checks
= 2 then
4468 pragma Assert
(Num_Checks
<= 1);
4469 Num_Checks
:= Num_Checks
+ 1;
4470 Ret_Result
(Num_Checks
) := N
;
4478 function Get_E_Length
(E
: Entity_Id
; Indx
: Nat
) return Node_Id
is
4479 Pt
: constant Entity_Id
:= Scope
(Scope
(E
));
4481 E1
: Entity_Id
:= E
;
4484 if Ekind
(Scope
(E
)) = E_Record_Type
4485 and then Has_Discriminants
(Scope
(E
))
4487 N
:= Build_Discriminal_Subtype_Of_Component
(E
);
4490 Insert_Action
(Ck_Node
, N
);
4491 E1
:= Defining_Identifier
(N
);
4495 if Ekind
(E1
) = E_String_Literal_Subtype
then
4497 Make_Integer_Literal
(Loc
,
4498 Intval
=> String_Literal_Length
(E1
));
4500 elsif Ekind
(Pt
) = E_Protected_Type
4501 and then Has_Discriminants
(Pt
)
4502 and then Has_Completion
(Pt
)
4503 and then not Inside_Init_Proc
4506 -- If the type whose length is needed is a private component
4507 -- constrained by a discriminant, we must expand the 'Length
4508 -- attribute into an explicit computation, using the discriminal
4509 -- of the current protected operation. This is because the actual
4510 -- type of the prival is constructed after the protected opera-
4511 -- tion has been fully expanded.
4514 Indx_Type
: Node_Id
;
4517 Do_Expand
: Boolean := False;
4520 Indx_Type
:= First_Index
(E
);
4522 for J
in 1 .. Indx
- 1 loop
4523 Next_Index
(Indx_Type
);
4526 Get_Index_Bounds
(Indx_Type
, Lo
, Hi
);
4528 if Nkind
(Lo
) = N_Identifier
4529 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
4531 Lo
:= Get_Discriminal
(E
, Lo
);
4535 if Nkind
(Hi
) = N_Identifier
4536 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
4538 Hi
:= Get_Discriminal
(E
, Hi
);
4543 if not Is_Entity_Name
(Lo
) then
4544 Lo
:= Duplicate_Subexpr_No_Checks
(Lo
);
4547 if not Is_Entity_Name
(Hi
) then
4548 Lo
:= Duplicate_Subexpr_No_Checks
(Hi
);
4554 Make_Op_Subtract
(Loc
,
4558 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1));
4563 Make_Attribute_Reference
(Loc
,
4564 Attribute_Name
=> Name_Length
,
4566 New_Occurrence_Of
(E1
, Loc
));
4569 Set_Expressions
(N
, New_List
(
4570 Make_Integer_Literal
(Loc
, Indx
)));
4579 Make_Attribute_Reference
(Loc
,
4580 Attribute_Name
=> Name_Length
,
4582 New_Occurrence_Of
(E1
, Loc
));
4585 Set_Expressions
(N
, New_List
(
4586 Make_Integer_Literal
(Loc
, Indx
)));
4598 function Get_N_Length
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
4601 Make_Attribute_Reference
(Loc
,
4602 Attribute_Name
=> Name_Length
,
4604 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
4605 Expressions
=> New_List
(
4606 Make_Integer_Literal
(Loc
, Indx
)));
4614 function Length_E_Cond
4615 (Exptyp
: Entity_Id
;
4623 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
4624 Right_Opnd
=> Get_E_Length
(Exptyp
, Indx
));
4632 function Length_N_Cond
4641 Left_Opnd
=> Get_E_Length
(Typ
, Indx
),
4642 Right_Opnd
=> Get_N_Length
(Expr
, Indx
));
4646 function Same_Bounds
(L
: Node_Id
; R
: Node_Id
) return Boolean is
4649 (Nkind
(L
) = N_Integer_Literal
4650 and then Nkind
(R
) = N_Integer_Literal
4651 and then Intval
(L
) = Intval
(R
))
4655 and then Ekind
(Entity
(L
)) = E_Constant
4656 and then ((Is_Entity_Name
(R
)
4657 and then Entity
(L
) = Entity
(R
))
4659 (Nkind
(R
) = N_Type_Conversion
4660 and then Is_Entity_Name
(Expression
(R
))
4661 and then Entity
(L
) = Entity
(Expression
(R
)))))
4665 and then Ekind
(Entity
(R
)) = E_Constant
4666 and then Nkind
(L
) = N_Type_Conversion
4667 and then Is_Entity_Name
(Expression
(L
))
4668 and then Entity
(R
) = Entity
(Expression
(L
)))
4672 and then Is_Entity_Name
(R
)
4673 and then Entity
(L
) = Entity
(R
)
4674 and then Ekind
(Entity
(L
)) = E_In_Parameter
4675 and then Inside_Init_Proc
);
4678 -- Start of processing for Selected_Length_Checks
4681 if not Expander_Active
then
4685 if Target_Typ
= Any_Type
4686 or else Target_Typ
= Any_Composite
4687 or else Raises_Constraint_Error
(Ck_Node
)
4696 T_Typ
:= Target_Typ
;
4698 if No
(Source_Typ
) then
4699 S_Typ
:= Etype
(Ck_Node
);
4701 S_Typ
:= Source_Typ
;
4704 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
4708 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
4709 S_Typ
:= Designated_Type
(S_Typ
);
4710 T_Typ
:= Designated_Type
(T_Typ
);
4713 -- A simple optimization
4715 if Nkind
(Ck_Node
) = N_Null
then
4720 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
4721 if Is_Constrained
(T_Typ
) then
4723 -- The checking code to be generated will freeze the
4724 -- corresponding array type. However, we must freeze the
4725 -- type now, so that the freeze node does not appear within
4726 -- the generated condional expression, but ahead of it.
4728 Freeze_Before
(Ck_Node
, T_Typ
);
4730 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
4731 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
4733 if Is_Access_Type
(Exptyp
) then
4734 Exptyp
:= Designated_Type
(Exptyp
);
4737 -- String_Literal case. This needs to be handled specially be-
4738 -- cause no index types are available for string literals. The
4739 -- condition is simply:
4741 -- T_Typ'Length = string-literal-length
4743 if Nkind
(Expr_Actual
) = N_String_Literal
4744 and then Ekind
(Etype
(Expr_Actual
)) = E_String_Literal_Subtype
4748 Left_Opnd
=> Get_E_Length
(T_Typ
, 1),
4750 Make_Integer_Literal
(Loc
,
4752 String_Literal_Length
(Etype
(Expr_Actual
))));
4754 -- General array case. Here we have a usable actual subtype for
4755 -- the expression, and the condition is built from the two types
4758 -- T_Typ'Length /= Exptyp'Length or else
4759 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
4760 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
4763 elsif Is_Constrained
(Exptyp
) then
4765 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
4779 -- At the library level, we need to ensure that the
4780 -- type of the object is elaborated before the check
4781 -- itself is emitted. This is only done if the object
4782 -- is in the current compilation unit, otherwise the
4783 -- type is frozen and elaborated in its unit.
4785 if Is_Itype
(Exptyp
)
4787 Ekind
(Cunit_Entity
(Current_Sem_Unit
)) = E_Package
4789 not In_Package_Body
(Cunit_Entity
(Current_Sem_Unit
))
4790 and then In_Open_Scopes
(Scope
(Exptyp
))
4792 Ref_Node
:= Make_Itype_Reference
(Sloc
(Ck_Node
));
4793 Set_Itype
(Ref_Node
, Exptyp
);
4794 Insert_Action
(Ck_Node
, Ref_Node
);
4797 L_Index
:= First_Index
(T_Typ
);
4798 R_Index
:= First_Index
(Exptyp
);
4800 for Indx
in 1 .. Ndims
loop
4801 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
4803 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
4805 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
4806 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
4808 -- Deal with compile time length check. Note that we
4809 -- skip this in the access case, because the access
4810 -- value may be null, so we cannot know statically.
4813 and then Compile_Time_Known_Value
(L_Low
)
4814 and then Compile_Time_Known_Value
(L_High
)
4815 and then Compile_Time_Known_Value
(R_Low
)
4816 and then Compile_Time_Known_Value
(R_High
)
4818 if Expr_Value
(L_High
) >= Expr_Value
(L_Low
) then
4819 L_Length
:= Expr_Value
(L_High
) -
4820 Expr_Value
(L_Low
) + 1;
4822 L_Length
:= UI_From_Int
(0);
4825 if Expr_Value
(R_High
) >= Expr_Value
(R_Low
) then
4826 R_Length
:= Expr_Value
(R_High
) -
4827 Expr_Value
(R_Low
) + 1;
4829 R_Length
:= UI_From_Int
(0);
4832 if L_Length
> R_Length
then
4834 (Compile_Time_Constraint_Error
4835 (Wnode
, "too few elements for}?", T_Typ
));
4837 elsif L_Length
< R_Length
then
4839 (Compile_Time_Constraint_Error
4840 (Wnode
, "too many elements for}?", T_Typ
));
4843 -- The comparison for an individual index subtype
4844 -- is omitted if the corresponding index subtypes
4845 -- statically match, since the result is known to
4846 -- be true. Note that this test is worth while even
4847 -- though we do static evaluation, because non-static
4848 -- subtypes can statically match.
4851 Subtypes_Statically_Match
4852 (Etype
(L_Index
), Etype
(R_Index
))
4855 (Same_Bounds
(L_Low
, R_Low
)
4856 and then Same_Bounds
(L_High
, R_High
))
4859 (Cond
, Length_E_Cond
(Exptyp
, T_Typ
, Indx
));
4868 -- Handle cases where we do not get a usable actual subtype that
4869 -- is constrained. This happens for example in the function call
4870 -- and explicit dereference cases. In these cases, we have to get
4871 -- the length or range from the expression itself, making sure we
4872 -- do not evaluate it more than once.
4874 -- Here Ck_Node is the original expression, or more properly the
4875 -- result of applying Duplicate_Expr to the original tree,
4876 -- forcing the result to be a name.
4880 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
4883 -- Build the condition for the explicit dereference case
4885 for Indx
in 1 .. Ndims
loop
4887 (Cond
, Length_N_Cond
(Ck_Node
, T_Typ
, Indx
));
4894 -- Construct the test and insert into the tree
4896 if Present
(Cond
) then
4898 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
4902 (Make_Raise_Constraint_Error
(Loc
,
4904 Reason
=> CE_Length_Check_Failed
));
4908 end Selected_Length_Checks
;
4910 ---------------------------
4911 -- Selected_Range_Checks --
4912 ---------------------------
4914 function Selected_Range_Checks
4916 Target_Typ
: Entity_Id
;
4917 Source_Typ
: Entity_Id
;
4918 Warn_Node
: Node_Id
)
4921 Loc
: constant Source_Ptr
:= Sloc
(Ck_Node
);
4924 Expr_Actual
: Node_Id
;
4926 Cond
: Node_Id
:= Empty
;
4927 Do_Access
: Boolean := False;
4928 Wnode
: Node_Id
:= Warn_Node
;
4929 Ret_Result
: Check_Result
:= (Empty
, Empty
);
4930 Num_Checks
: Integer := 0;
4932 procedure Add_Check
(N
: Node_Id
);
4933 -- Adds the action given to Ret_Result if N is non-Empty
4935 function Discrete_Range_Cond
4939 -- Returns expression to compute:
4940 -- Low_Bound (Expr) < Typ'First
4942 -- High_Bound (Expr) > Typ'Last
4944 function Discrete_Expr_Cond
4948 -- Returns expression to compute:
4953 function Get_E_First_Or_Last
4958 -- Returns expression to compute:
4959 -- E'First or E'Last
4961 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
4962 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
;
4963 -- Returns expression to compute:
4964 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
4966 function Range_E_Cond
4967 (Exptyp
: Entity_Id
;
4971 -- Returns expression to compute:
4972 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
4974 function Range_Equal_E_Cond
4975 (Exptyp
: Entity_Id
;
4979 -- Returns expression to compute:
4980 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
4982 function Range_N_Cond
4987 -- Return expression to compute:
4988 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
4994 procedure Add_Check
(N
: Node_Id
) is
4998 -- For now, ignore attempt to place more than 2 checks ???
5000 if Num_Checks
= 2 then
5004 pragma Assert
(Num_Checks
<= 1);
5005 Num_Checks
:= Num_Checks
+ 1;
5006 Ret_Result
(Num_Checks
) := N
;
5010 -------------------------
5011 -- Discrete_Expr_Cond --
5012 -------------------------
5014 function Discrete_Expr_Cond
5025 Convert_To
(Base_Type
(Typ
),
5026 Duplicate_Subexpr_No_Checks
(Expr
)),
5028 Convert_To
(Base_Type
(Typ
),
5029 Get_E_First_Or_Last
(Typ
, 0, Name_First
))),
5034 Convert_To
(Base_Type
(Typ
),
5035 Duplicate_Subexpr_No_Checks
(Expr
)),
5039 Get_E_First_Or_Last
(Typ
, 0, Name_Last
))));
5040 end Discrete_Expr_Cond
;
5042 -------------------------
5043 -- Discrete_Range_Cond --
5044 -------------------------
5046 function Discrete_Range_Cond
5051 LB
: Node_Id
:= Low_Bound
(Expr
);
5052 HB
: Node_Id
:= High_Bound
(Expr
);
5054 Left_Opnd
: Node_Id
;
5055 Right_Opnd
: Node_Id
;
5058 if Nkind
(LB
) = N_Identifier
5059 and then Ekind
(Entity
(LB
)) = E_Discriminant
then
5060 LB
:= New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
5063 if Nkind
(HB
) = N_Identifier
5064 and then Ekind
(Entity
(HB
)) = E_Discriminant
then
5065 HB
:= New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
5072 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(LB
)),
5076 (Base_Type
(Typ
), Get_E_First_Or_Last
(Typ
, 0, Name_First
)));
5078 if Base_Type
(Typ
) = Typ
then
5081 elsif Compile_Time_Known_Value
(High_Bound
(Scalar_Range
(Typ
)))
5083 Compile_Time_Known_Value
(High_Bound
(Scalar_Range
5086 if Is_Floating_Point_Type
(Typ
) then
5087 if Expr_Value_R
(High_Bound
(Scalar_Range
(Typ
))) =
5088 Expr_Value_R
(High_Bound
(Scalar_Range
(Base_Type
(Typ
))))
5094 if Expr_Value
(High_Bound
(Scalar_Range
(Typ
))) =
5095 Expr_Value
(High_Bound
(Scalar_Range
(Base_Type
(Typ
))))
5106 (Base_Type
(Typ
), Duplicate_Subexpr_No_Checks
(HB
)),
5111 Get_E_First_Or_Last
(Typ
, 0, Name_Last
)));
5113 return Make_Or_Else
(Loc
, Left_Opnd
, Right_Opnd
);
5114 end Discrete_Range_Cond
;
5116 -------------------------
5117 -- Get_E_First_Or_Last --
5118 -------------------------
5120 function Get_E_First_Or_Last
5132 if Is_Array_Type
(E
) then
5133 N
:= First_Index
(E
);
5135 for J
in 2 .. Indx
loop
5140 N
:= Scalar_Range
(E
);
5143 if Nkind
(N
) = N_Subtype_Indication
then
5144 LB
:= Low_Bound
(Range_Expression
(Constraint
(N
)));
5145 HB
:= High_Bound
(Range_Expression
(Constraint
(N
)));
5147 elsif Is_Entity_Name
(N
) then
5148 LB
:= Type_Low_Bound
(Etype
(N
));
5149 HB
:= Type_High_Bound
(Etype
(N
));
5152 LB
:= Low_Bound
(N
);
5153 HB
:= High_Bound
(N
);
5156 if Nam
= Name_First
then
5162 if Nkind
(Bound
) = N_Identifier
5163 and then Ekind
(Entity
(Bound
)) = E_Discriminant
5165 -- If this is a task discriminant, and we are the body, we must
5166 -- retrieve the corresponding body discriminal. This is another
5167 -- consequence of the early creation of discriminals, and the
5168 -- need to generate constraint checks before their declarations
5169 -- are made visible.
5171 if Is_Concurrent_Record_Type
(Scope
(Entity
(Bound
))) then
5173 Tsk
: constant Entity_Id
:=
5174 Corresponding_Concurrent_Type
5175 (Scope
(Entity
(Bound
)));
5179 if In_Open_Scopes
(Tsk
)
5180 and then Has_Completion
(Tsk
)
5182 -- Find discriminant of original task, and use its
5183 -- current discriminal, which is the renaming within
5186 Disc
:= First_Discriminant
(Tsk
);
5187 while Present
(Disc
) loop
5188 if Chars
(Disc
) = Chars
(Entity
(Bound
)) then
5189 Set_Scope
(Discriminal
(Disc
), Tsk
);
5190 return New_Occurrence_Of
(Discriminal
(Disc
), Loc
);
5193 Next_Discriminant
(Disc
);
5196 -- That loop should always succeed in finding a matching
5197 -- entry and returning. Fatal error if not.
5199 raise Program_Error
;
5203 New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
5207 return New_Occurrence_Of
(Discriminal
(Entity
(Bound
)), Loc
);
5210 elsif Nkind
(Bound
) = N_Identifier
5211 and then Ekind
(Entity
(Bound
)) = E_In_Parameter
5212 and then not Inside_Init_Proc
5214 return Get_Discriminal
(E
, Bound
);
5216 elsif Nkind
(Bound
) = N_Integer_Literal
then
5217 return Make_Integer_Literal
(Loc
, Intval
(Bound
));
5220 return Duplicate_Subexpr_No_Checks
(Bound
);
5222 end Get_E_First_Or_Last
;
5228 function Get_N_First
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
5231 Make_Attribute_Reference
(Loc
,
5232 Attribute_Name
=> Name_First
,
5234 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
5235 Expressions
=> New_List
(
5236 Make_Integer_Literal
(Loc
, Indx
)));
5244 function Get_N_Last
(N
: Node_Id
; Indx
: Nat
) return Node_Id
is
5247 Make_Attribute_Reference
(Loc
,
5248 Attribute_Name
=> Name_Last
,
5250 Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True),
5251 Expressions
=> New_List
(
5252 Make_Integer_Literal
(Loc
, Indx
)));
5260 function Range_E_Cond
5261 (Exptyp
: Entity_Id
;
5271 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_First
),
5272 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_First
)),
5276 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_Last
),
5277 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_Last
)));
5281 ------------------------
5282 -- Range_Equal_E_Cond --
5283 ------------------------
5285 function Range_Equal_E_Cond
5286 (Exptyp
: Entity_Id
;
5296 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_First
),
5297 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_First
)),
5300 Left_Opnd
=> Get_E_First_Or_Last
(Exptyp
, Indx
, Name_Last
),
5301 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_Last
)));
5302 end Range_Equal_E_Cond
;
5308 function Range_N_Cond
5319 Left_Opnd
=> Get_N_First
(Expr
, Indx
),
5320 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_First
)),
5324 Left_Opnd
=> Get_N_Last
(Expr
, Indx
),
5325 Right_Opnd
=> Get_E_First_Or_Last
(Typ
, Indx
, Name_Last
)));
5328 -- Start of processing for Selected_Range_Checks
5331 if not Expander_Active
then
5335 if Target_Typ
= Any_Type
5336 or else Target_Typ
= Any_Composite
5337 or else Raises_Constraint_Error
(Ck_Node
)
5346 T_Typ
:= Target_Typ
;
5348 if No
(Source_Typ
) then
5349 S_Typ
:= Etype
(Ck_Node
);
5351 S_Typ
:= Source_Typ
;
5354 if S_Typ
= Any_Type
or else S_Typ
= Any_Composite
then
5358 -- The order of evaluating T_Typ before S_Typ seems to be critical
5359 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
5360 -- in, and since Node can be an N_Range node, it might be invalid.
5361 -- Should there be an assert check somewhere for taking the Etype of
5362 -- an N_Range node ???
5364 if Is_Access_Type
(T_Typ
) and then Is_Access_Type
(S_Typ
) then
5365 S_Typ
:= Designated_Type
(S_Typ
);
5366 T_Typ
:= Designated_Type
(T_Typ
);
5369 -- A simple optimization
5371 if Nkind
(Ck_Node
) = N_Null
then
5376 -- For an N_Range Node, check for a null range and then if not
5377 -- null generate a range check action.
5379 if Nkind
(Ck_Node
) = N_Range
then
5381 -- There's no point in checking a range against itself
5383 if Ck_Node
= Scalar_Range
(T_Typ
) then
5388 T_LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
5389 T_HB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
5390 LB
: constant Node_Id
:= Low_Bound
(Ck_Node
);
5391 HB
: constant Node_Id
:= High_Bound
(Ck_Node
);
5392 Null_Range
: Boolean;
5394 Out_Of_Range_L
: Boolean;
5395 Out_Of_Range_H
: Boolean;
5398 -- Check for case where everything is static and we can
5399 -- do the check at compile time. This is skipped if we
5400 -- have an access type, since the access value may be null.
5402 -- ??? This code can be improved since you only need to know
5403 -- that the two respective bounds (LB & T_LB or HB & T_HB)
5404 -- are known at compile time to emit pertinent messages.
5406 if Compile_Time_Known_Value
(LB
)
5407 and then Compile_Time_Known_Value
(HB
)
5408 and then Compile_Time_Known_Value
(T_LB
)
5409 and then Compile_Time_Known_Value
(T_HB
)
5410 and then not Do_Access
5412 -- Floating-point case
5414 if Is_Floating_Point_Type
(S_Typ
) then
5415 Null_Range
:= Expr_Value_R
(HB
) < Expr_Value_R
(LB
);
5417 (Expr_Value_R
(LB
) < Expr_Value_R
(T_LB
))
5419 (Expr_Value_R
(LB
) > Expr_Value_R
(T_HB
));
5422 (Expr_Value_R
(HB
) > Expr_Value_R
(T_HB
))
5424 (Expr_Value_R
(HB
) < Expr_Value_R
(T_LB
));
5426 -- Fixed or discrete type case
5429 Null_Range
:= Expr_Value
(HB
) < Expr_Value
(LB
);
5431 (Expr_Value
(LB
) < Expr_Value
(T_LB
))
5433 (Expr_Value
(LB
) > Expr_Value
(T_HB
));
5436 (Expr_Value
(HB
) > Expr_Value
(T_HB
))
5438 (Expr_Value
(HB
) < Expr_Value
(T_LB
));
5441 if not Null_Range
then
5442 if Out_Of_Range_L
then
5443 if No
(Warn_Node
) then
5445 (Compile_Time_Constraint_Error
5446 (Low_Bound
(Ck_Node
),
5447 "static value out of range of}?", T_Typ
));
5451 (Compile_Time_Constraint_Error
5453 "static range out of bounds of}?", T_Typ
));
5457 if Out_Of_Range_H
then
5458 if No
(Warn_Node
) then
5460 (Compile_Time_Constraint_Error
5461 (High_Bound
(Ck_Node
),
5462 "static value out of range of}?", T_Typ
));
5466 (Compile_Time_Constraint_Error
5468 "static range out of bounds of}?", T_Typ
));
5476 LB
: Node_Id
:= Low_Bound
(Ck_Node
);
5477 HB
: Node_Id
:= High_Bound
(Ck_Node
);
5481 -- If either bound is a discriminant and we are within
5482 -- the record declaration, it is a use of the discriminant
5483 -- in a constraint of a component, and nothing can be
5484 -- checked here. The check will be emitted within the
5485 -- init proc. Before then, the discriminal has no real
5488 if Nkind
(LB
) = N_Identifier
5489 and then Ekind
(Entity
(LB
)) = E_Discriminant
5491 if Current_Scope
= Scope
(Entity
(LB
)) then
5495 New_Occurrence_Of
(Discriminal
(Entity
(LB
)), Loc
);
5499 if Nkind
(HB
) = N_Identifier
5500 and then Ekind
(Entity
(HB
)) = E_Discriminant
5502 if Current_Scope
= Scope
(Entity
(HB
)) then
5506 New_Occurrence_Of
(Discriminal
(Entity
(HB
)), Loc
);
5510 Cond
:= Discrete_Range_Cond
(Ck_Node
, T_Typ
);
5511 Set_Paren_Count
(Cond
, 1);
5517 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(HB
),
5518 Right_Opnd
=> Duplicate_Subexpr_No_Checks
(LB
)),
5519 Right_Opnd
=> Cond
);
5525 elsif Is_Scalar_Type
(S_Typ
) then
5527 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
5528 -- except the above simply sets a flag in the node and lets
5529 -- gigi generate the check base on the Etype of the expression.
5530 -- Sometimes, however we want to do a dynamic check against an
5531 -- arbitrary target type, so we do that here.
5533 if Ekind
(Base_Type
(S_Typ
)) /= Ekind
(Base_Type
(T_Typ
)) then
5534 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
5536 -- For literals, we can tell if the constraint error will be
5537 -- raised at compile time, so we never need a dynamic check, but
5538 -- if the exception will be raised, then post the usual warning,
5539 -- and replace the literal with a raise constraint error
5540 -- expression. As usual, skip this for access types
5542 elsif Compile_Time_Known_Value
(Ck_Node
)
5543 and then not Do_Access
5546 LB
: constant Node_Id
:= Type_Low_Bound
(T_Typ
);
5547 UB
: constant Node_Id
:= Type_High_Bound
(T_Typ
);
5549 Out_Of_Range
: Boolean;
5550 Static_Bounds
: constant Boolean :=
5551 Compile_Time_Known_Value
(LB
)
5552 and Compile_Time_Known_Value
(UB
);
5555 -- Following range tests should use Sem_Eval routine ???
5557 if Static_Bounds
then
5558 if Is_Floating_Point_Type
(S_Typ
) then
5560 (Expr_Value_R
(Ck_Node
) < Expr_Value_R
(LB
))
5562 (Expr_Value_R
(Ck_Node
) > Expr_Value_R
(UB
));
5564 else -- fixed or discrete type
5566 Expr_Value
(Ck_Node
) < Expr_Value
(LB
)
5568 Expr_Value
(Ck_Node
) > Expr_Value
(UB
);
5571 -- Bounds of the type are static and the literal is
5572 -- out of range so make a warning message.
5574 if Out_Of_Range
then
5575 if No
(Warn_Node
) then
5577 (Compile_Time_Constraint_Error
5579 "static value out of range of}?", T_Typ
));
5583 (Compile_Time_Constraint_Error
5585 "static value out of range of}?", T_Typ
));
5590 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
5594 -- Here for the case of a non-static expression, we need a runtime
5595 -- check unless the source type range is guaranteed to be in the
5596 -- range of the target type.
5599 if not In_Subrange_Of
(S_Typ
, T_Typ
) then
5600 Cond
:= Discrete_Expr_Cond
(Ck_Node
, T_Typ
);
5605 if Is_Array_Type
(T_Typ
) and then Is_Array_Type
(S_Typ
) then
5606 if Is_Constrained
(T_Typ
) then
5608 Expr_Actual
:= Get_Referenced_Object
(Ck_Node
);
5609 Exptyp
:= Get_Actual_Subtype
(Expr_Actual
);
5611 if Is_Access_Type
(Exptyp
) then
5612 Exptyp
:= Designated_Type
(Exptyp
);
5615 -- String_Literal case. This needs to be handled specially be-
5616 -- cause no index types are available for string literals. The
5617 -- condition is simply:
5619 -- T_Typ'Length = string-literal-length
5621 if Nkind
(Expr_Actual
) = N_String_Literal
then
5624 -- General array case. Here we have a usable actual subtype for
5625 -- the expression, and the condition is built from the two types
5627 -- T_Typ'First < Exptyp'First or else
5628 -- T_Typ'Last > Exptyp'Last or else
5629 -- T_Typ'First(1) < Exptyp'First(1) or else
5630 -- T_Typ'Last(1) > Exptyp'Last(1) or else
5633 elsif Is_Constrained
(Exptyp
) then
5635 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
5645 L_Index
:= First_Index
(T_Typ
);
5646 R_Index
:= First_Index
(Exptyp
);
5648 for Indx
in 1 .. Ndims
loop
5649 if not (Nkind
(L_Index
) = N_Raise_Constraint_Error
5651 Nkind
(R_Index
) = N_Raise_Constraint_Error
)
5653 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
5654 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
5656 -- Deal with compile time length check. Note that we
5657 -- skip this in the access case, because the access
5658 -- value may be null, so we cannot know statically.
5661 Subtypes_Statically_Match
5662 (Etype
(L_Index
), Etype
(R_Index
))
5664 -- If the target type is constrained then we
5665 -- have to check for exact equality of bounds
5666 -- (required for qualified expressions).
5668 if Is_Constrained
(T_Typ
) then
5671 Range_Equal_E_Cond
(Exptyp
, T_Typ
, Indx
));
5675 (Cond
, Range_E_Cond
(Exptyp
, T_Typ
, Indx
));
5686 -- Handle cases where we do not get a usable actual subtype that
5687 -- is constrained. This happens for example in the function call
5688 -- and explicit dereference cases. In these cases, we have to get
5689 -- the length or range from the expression itself, making sure we
5690 -- do not evaluate it more than once.
5692 -- Here Ck_Node is the original expression, or more properly the
5693 -- result of applying Duplicate_Expr to the original tree,
5694 -- forcing the result to be a name.
5698 Ndims
: constant Nat
:= Number_Dimensions
(T_Typ
);
5701 -- Build the condition for the explicit dereference case
5703 for Indx
in 1 .. Ndims
loop
5705 (Cond
, Range_N_Cond
(Ck_Node
, T_Typ
, Indx
));
5712 -- Generate an Action to check that the bounds of the
5713 -- source value are within the constraints imposed by the
5714 -- target type for a conversion to an unconstrained type.
5717 if Nkind
(Parent
(Ck_Node
)) = N_Type_Conversion
then
5719 Opnd_Index
: Node_Id
;
5720 Targ_Index
: Node_Id
;
5724 := First_Index
(Get_Actual_Subtype
(Ck_Node
));
5725 Targ_Index
:= First_Index
(T_Typ
);
5727 while Opnd_Index
/= Empty
loop
5728 if Nkind
(Opnd_Index
) = N_Range
then
5730 (Low_Bound
(Opnd_Index
), Etype
(Targ_Index
))
5733 (High_Bound
(Opnd_Index
), Etype
(Targ_Index
))
5737 -- If null range, no check needed.
5739 Compile_Time_Known_Value
(High_Bound
(Opnd_Index
))
5741 Compile_Time_Known_Value
(Low_Bound
(Opnd_Index
))
5743 Expr_Value
(High_Bound
(Opnd_Index
)) <
5744 Expr_Value
(Low_Bound
(Opnd_Index
))
5748 elsif Is_Out_Of_Range
5749 (Low_Bound
(Opnd_Index
), Etype
(Targ_Index
))
5752 (High_Bound
(Opnd_Index
), Etype
(Targ_Index
))
5755 (Compile_Time_Constraint_Error
5756 (Wnode
, "value out of range of}?", T_Typ
));
5762 (Opnd_Index
, Etype
(Targ_Index
)));
5766 Next_Index
(Opnd_Index
);
5767 Next_Index
(Targ_Index
);
5774 -- Construct the test and insert into the tree
5776 if Present
(Cond
) then
5778 Cond
:= Guard_Access
(Cond
, Loc
, Ck_Node
);
5782 (Make_Raise_Constraint_Error
(Loc
,
5784 Reason
=> CE_Range_Check_Failed
));
5788 end Selected_Range_Checks
;
5790 -------------------------------
5791 -- Storage_Checks_Suppressed --
5792 -------------------------------
5794 function Storage_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5796 if Present
(E
) and then Checks_May_Be_Suppressed
(E
) then
5797 return Is_Check_Suppressed
(E
, Storage_Check
);
5799 return Scope_Suppress
(Storage_Check
);
5801 end Storage_Checks_Suppressed
;
5803 ---------------------------
5804 -- Tag_Checks_Suppressed --
5805 ---------------------------
5807 function Tag_Checks_Suppressed
(E
: Entity_Id
) return Boolean is
5810 if Kill_Tag_Checks
(E
) then
5812 elsif Checks_May_Be_Suppressed
(E
) then
5813 return Is_Check_Suppressed
(E
, Tag_Check
);
5817 return Scope_Suppress
(Tag_Check
);
5818 end Tag_Checks_Suppressed
;