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)));
1188 DconT := First_Elmt (Discriminant_Constraint (T_Typ));
1190 while Present (Discr) loop
1191 ItemS := Node (DconS);
1192 ItemT := Node (DconT);
1195 not Is_OK_Static_Expression (ItemS)
1197 not Is_OK_Static_Expression (ItemT);
1199 if Expr_Value (ItemS) /= Expr_Value (ItemT) then
1200 if Do_Access then -- needs run-time check.
1203 Apply_Compile_Time_Constraint_Error
1204 (N, "incorrect value for discriminant&?",
1205 CE_Discriminant_Check_Failed, Ent => Discr);
1212 Next_Discriminant (Discr);
1221 -- Here we need a discriminant check. First build the expression
1222 -- for the comparisons of the discriminants:
1224 -- (n.disc1 /= typ.disc1) or else
1225 -- (n.disc2 /= typ.disc2) or else
1227 -- (n.discn /= typ.discn)
1229 Cond := Build_Discriminant_Checks (N, T_Typ);
1231 -- If Lhs is set and is a parameter, then the condition is
1232 -- guarded by: lhs'constrained and then (condition built above)
1234 if Present (Param_Entity (Lhs)) then
1238 Make_Attribute_Reference (Loc,
1239 Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc),
1240 Attribute_Name => Name_Constrained),
1241 Right_Opnd => Cond);
1245 Cond := Guard_Access (Cond, Loc, N);
1249 Make_Raise_Constraint_Error (Loc,
1251 Reason => CE_Discriminant_Check_Failed));
1252 end Apply_Discriminant_Check;
1254 ------------------------
1255 -- Apply_Divide_Check --
1256 ------------------------
1258 procedure Apply_Divide_Check (N : Node_Id) is
1259 Loc : constant Source_Ptr := Sloc (N);
1260 Typ : constant Entity_Id := Etype (N);
1261 Left : constant Node_Id := Left_Opnd (N);
1262 Right : constant Node_Id := Right_Opnd (N);
1274 and not Backend_Divide_Checks_On_Target
1276 Determine_Range (Right, ROK, Rlo, Rhi);
1278 -- See if division by zero possible, and if so generate test. This
1279 -- part of the test is not controlled by the -gnato switch.
1281 if Do_Division_Check (N) then
1283 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
1285 Make_Raise_Constraint_Error (Loc,
1288 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
1289 Right_Opnd => Make_Integer_Literal (Loc, 0)),
1290 Reason => CE_Divide_By_Zero));
1294 -- Test for extremely annoying case of xxx'First divided by -1
1296 if Do_Overflow_Check (N) then
1298 if Nkind (N) = N_Op_Divide
1299 and then Is_Signed_Integer_Type (Typ)
1301 Determine_Range (Left, LOK, Llo, Lhi);
1302 LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
1304 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
1306 ((not LOK) or else (Llo = LLB))
1309 Make_Raise_Constraint_Error (Loc,
1315 Duplicate_Subexpr_Move_Checks (Left),
1316 Right_Opnd => Make_Integer_Literal (Loc, LLB)),
1320 Duplicate_Subexpr (Right),
1322 Make_Integer_Literal (Loc, -1))),
1323 Reason => CE_Overflow_Check_Failed));
1328 end Apply_Divide_Check;
1330 ------------------------
1331 -- Apply_Length_Check --
1332 ------------------------
1334 procedure Apply_Length_Check
1336 Target_Typ : Entity_Id;
1337 Source_Typ : Entity_Id := Empty)
1340 Apply_Selected_Length_Checks
1341 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1342 end Apply_Length_Check;
1344 -----------------------
1345 -- Apply_Range_Check --
1346 -----------------------
1348 procedure Apply_Range_Check
1350 Target_Typ : Entity_Id;
1351 Source_Typ : Entity_Id := Empty)
1354 Apply_Selected_Range_Checks
1355 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1356 end Apply_Range_Check;
1358 ------------------------------
1359 -- Apply_Scalar_Range_Check --
1360 ------------------------------
1362 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check
1363 -- flag off if it is already set on.
1365 procedure Apply_Scalar_Range_Check
1367 Target_Typ : Entity_Id;
1368 Source_Typ : Entity_Id := Empty;
1369 Fixed_Int : Boolean := False)
1371 Parnt : constant Node_Id := Parent (Expr);
1373 Arr : Node_Id := Empty; -- initialize to prevent warning
1374 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning
1377 Is_Subscr_Ref : Boolean;
1378 -- Set true if Expr is a subscript
1380 Is_Unconstrained_Subscr_Ref : Boolean;
1381 -- Set true if Expr is a subscript of an unconstrained array. In this
1382 -- case we do not attempt to do an analysis of the value against the
1383 -- range of the subscript, since we don't know the actual subtype.
1386 -- Set to True if Expr should be regarded as a real value
1387 -- even though the type of Expr might be discrete.
1389 procedure Bad_Value;
1390 -- Procedure called if value is determined to be out of range
1396 procedure Bad_Value is
1398 Apply_Compile_Time_Constraint_Error
1399 (Expr, "value not in range of}?", CE_Range_Check_Failed,
1404 -- Start of processing for Apply_Scalar_Range_Check
1407 if Inside_A_Generic then
1410 -- Return if check obviously not needed. Note that we do not check
1411 -- for the expander being inactive, since this routine does not
1412 -- insert any code, but it does generate useful warnings sometimes,
1413 -- which we would like even if we are in semantics only mode.
1415 elsif Target_Typ = Any_Type
1416 or else not Is_Scalar_Type (Target_Typ)
1417 or else Raises_Constraint_Error (Expr)
1422 -- Now, see if checks are suppressed
1425 Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component;
1427 if Is_Subscr_Ref then
1428 Arr := Prefix (Parnt);
1429 Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
1432 if not Do_Range_Check (Expr) then
1434 -- Subscript reference. Check for Index_Checks suppressed
1436 if Is_Subscr_Ref then
1438 -- Check array type and its base type
1440 if Index_Checks_Suppressed (Arr_Typ)
1441 or else Index_Checks_Suppressed (Base_Type (Arr_Typ))
1445 -- Check array itself if it is an entity name
1447 elsif Is_Entity_Name (Arr)
1448 and then Index_Checks_Suppressed (Entity (Arr))
1452 -- Check expression itself if it is an entity name
1454 elsif Is_Entity_Name (Expr)
1455 and then Index_Checks_Suppressed (Entity (Expr))
1460 -- All other cases, check for Range_Checks suppressed
1463 -- Check target type and its base type
1465 if Range_Checks_Suppressed (Target_Typ)
1466 or else Range_Checks_Suppressed (Base_Type (Target_Typ))
1470 -- Check expression itself if it is an entity name
1472 elsif Is_Entity_Name (Expr)
1473 and then Range_Checks_Suppressed (Entity (Expr))
1477 -- If Expr is part of an assignment statement, then check
1478 -- left side of assignment if it is an entity name.
1480 elsif Nkind (Parnt) = N_Assignment_Statement
1481 and then Is_Entity_Name (Name (Parnt))
1482 and then Range_Checks_Suppressed (Entity (Name (Parnt)))
1489 -- Do not set range checks if they are killed
1491 if Nkind (Expr) = N_Unchecked_Type_Conversion
1492 and then Kill_Range_Check (Expr)
1497 -- Do not set range checks for any values from System.Scalar_Values
1498 -- since the whole idea of such values is to avoid checking them!
1500 if Is_Entity_Name (Expr)
1501 and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values)
1506 -- Now see if we need a check
1508 if No (Source_Typ) then
1509 S_Typ := Etype (Expr);
1511 S_Typ := Source_Typ;
1514 if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then
1518 Is_Unconstrained_Subscr_Ref :=
1519 Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
1521 -- Always do a range check if the source type includes infinities
1522 -- and the target type does not include infinities. We do not do
1523 -- this if range checks are killed.
1525 if Is_Floating_Point_Type (S_Typ)
1526 and then Has_Infinities (S_Typ)
1527 and then not Has_Infinities (Target_Typ)
1529 Enable_Range_Check (Expr);
1532 -- Return if we know expression is definitely in the range of
1533 -- the target type as determined by Determine_Range. Right now
1534 -- we only do this for discrete types, and not fixed-point or
1535 -- floating-point types.
1537 -- The additional less-precise tests below catch these cases.
1539 -- Note: skip this if we are given a source_typ, since the point
1540 -- of supplying a Source_Typ is to stop us looking at the expression.
1541 -- could sharpen this test to be out parameters only ???
1543 if Is_Discrete_Type (Target_Typ)
1544 and then Is_Discrete_Type (Etype (Expr))
1545 and then not Is_Unconstrained_Subscr_Ref
1546 and then No (Source_Typ)
1549 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
1550 Thi : constant Node_Id := Type_High_Bound (Target_Typ);
1555 if Compile_Time_Known_Value (Tlo)
1556 and then Compile_Time_Known_Value (Thi)
1559 Lov : constant Uint := Expr_Value (Tlo);
1560 Hiv : constant Uint := Expr_Value (Thi);
1563 -- If range is null, we for sure have a constraint error
1564 -- (we don't even need to look at the value involved,
1565 -- since all possible values will raise CE).
1572 -- Otherwise determine range of value
1574 Determine_Range (Expr, OK, Lo, Hi);
1578 -- If definitely in range, all OK
1580 if Lo >= Lov and then Hi <= Hiv then
1583 -- If definitely not in range, warn
1585 elsif Lov > Hi or else Hiv < Lo then
1589 -- Otherwise we don't know
1601 Is_Floating_Point_Type (S_Typ)
1602 or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
1604 -- Check if we can determine at compile time whether Expr is in the
1605 -- range of the target type. Note that if S_Typ is within the bounds
1606 -- of Target_Typ then this must be the case. This check is meaningful
1607 -- only if this is not a conversion between integer and real types.
1609 if not Is_Unconstrained_Subscr_Ref
1611 Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
1613 (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
1615 Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real))
1619 elsif Is_Out_Of_Range (Expr, Target_Typ, Fixed_Int, Int_Real) then
1623 -- In the floating-point case, we only do range checks if the
1624 -- type is constrained. We definitely do NOT want range checks
1625 -- for unconstrained types, since we want to have infinities
1627 elsif Is_Floating_Point_Type (S_Typ) then
1628 if Is_Constrained (S_Typ) then
1629 Enable_Range_Check (Expr);
1632 -- For all other cases we enable a range check unconditionally
1635 Enable_Range_Check (Expr);
1638 end Apply_Scalar_Range_Check;
1640 ----------------------------------
1641 -- Apply_Selected_Length_Checks --
1642 ----------------------------------
1644 procedure Apply_Selected_Length_Checks
1646 Target_Typ : Entity_Id;
1647 Source_Typ : Entity_Id;
1648 Do_Static : Boolean)
1651 R_Result : Check_Result;
1654 Loc : constant Source_Ptr := Sloc (Ck_Node);
1655 Checks_On : constant Boolean :=
1656 (not Index_Checks_Suppressed (Target_Typ))
1658 (not Length_Checks_Suppressed (Target_Typ));
1661 if not Expander_Active then
1666 Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
1668 for J in 1 .. 2 loop
1669 R_Cno := R_Result (J);
1670 exit when No (R_Cno);
1672 -- A length check may mention an Itype which is attached to a
1673 -- subsequent node. At the top level in a package this can cause
1674 -- an order-of-elaboration problem, so we make sure that the itype
1675 -- is referenced now.
1677 if Ekind (Current_Scope) = E_Package
1678 and then Is_Compilation_Unit (Current_Scope)
1680 Ensure_Defined (Target_Typ, Ck_Node);
1682 if Present (Source_Typ) then
1683 Ensure_Defined (Source_Typ, Ck_Node);
1685 elsif Is_Itype (Etype (Ck_Node)) then
1686 Ensure_Defined (Etype (Ck_Node), Ck_Node);
1690 -- If the item is a conditional raise of constraint error,
1691 -- then have a look at what check is being performed and
1694 if Nkind (R_Cno) = N_Raise_Constraint_Error
1695 and then Present (Condition (R_Cno))
1697 Cond := Condition (R_Cno);
1699 if not Has_Dynamic_Length_Check (Ck_Node)
1702 Insert_Action (Ck_Node, R_Cno);
1704 if not Do_Static then
1705 Set_Has_Dynamic_Length_Check (Ck_Node);
1709 -- Output a warning if the condition is known to be True
1711 if Is_Entity_Name (Cond)
1712 and then Entity (Cond) = Standard_True
1714 Apply_Compile_Time_Constraint_Error
1715 (Ck_Node, "wrong length for array of}?",
1716 CE_Length_Check_Failed,
1720 -- If we were only doing a static check, or if checks are not
1721 -- on, then we want to delete the check, since it is not needed.
1722 -- We do this by replacing the if statement by a null statement
1724 elsif Do_Static or else not Checks_On then
1725 Rewrite (R_Cno, Make_Null_Statement (Loc));
1729 Install_Static_Check (R_Cno, Loc);
1734 end Apply_Selected_Length_Checks;
1736 ---------------------------------
1737 -- Apply_Selected_Range_Checks --
1738 ---------------------------------
1740 procedure Apply_Selected_Range_Checks
1742 Target_Typ : Entity_Id;
1743 Source_Typ : Entity_Id;
1744 Do_Static : Boolean)
1747 R_Result : Check_Result;
1750 Loc : constant Source_Ptr := Sloc (Ck_Node);
1751 Checks_On : constant Boolean :=
1752 (not Index_Checks_Suppressed (Target_Typ))
1754 (not Range_Checks_Suppressed (Target_Typ));
1757 if not Expander_Active or else not Checks_On then
1762 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
1764 for J in 1 .. 2 loop
1766 R_Cno := R_Result (J);
1767 exit when No (R_Cno);
1769 -- If the item is a conditional raise of constraint error,
1770 -- then have a look at what check is being performed and
1773 if Nkind (R_Cno) = N_Raise_Constraint_Error
1774 and then Present (Condition (R_Cno))
1776 Cond := Condition (R_Cno);
1778 if not Has_Dynamic_Range_Check (Ck_Node) then
1779 Insert_Action (Ck_Node, R_Cno);
1781 if not Do_Static then
1782 Set_Has_Dynamic_Range_Check (Ck_Node);
1786 -- Output a warning if the condition is known to be True
1788 if Is_Entity_Name (Cond)
1789 and then Entity (Cond) = Standard_True
1791 -- Since an N_Range is technically not an expression, we
1792 -- have to set one of the bounds to C_E and then just flag
1793 -- the N_Range. The warning message will point to the
1794 -- lower bound and complain about a range, which seems OK.
1796 if Nkind (Ck_Node) = N_Range then
1797 Apply_Compile_Time_Constraint_Error
1798 (Low_Bound (Ck_Node), "static range out of bounds of}?",
1799 CE_Range_Check_Failed,
1803 Set_Raises_Constraint_Error (Ck_Node);
1806 Apply_Compile_Time_Constraint_Error
1807 (Ck_Node, "static value out of range of}?",
1808 CE_Range_Check_Failed,
1813 -- If we were only doing a static check, or if checks are not
1814 -- on, then we want to delete the check, since it is not needed.
1815 -- We do this by replacing the if statement by a null statement
1817 elsif Do_Static or else not Checks_On then
1818 Rewrite (R_Cno, Make_Null_Statement (Loc));
1822 Install_Static_Check (R_Cno, Loc);
1825 end Apply_Selected_Range_Checks;
1827 -------------------------------
1828 -- Apply_Static_Length_Check --
1829 -------------------------------
1831 procedure Apply_Static_Length_Check
1833 Target_Typ : Entity_Id;
1834 Source_Typ : Entity_Id := Empty)
1837 Apply_Selected_Length_Checks
1838 (Expr, Target_Typ, Source_Typ, Do_Static => True);
1839 end Apply_Static_Length_Check;
1841 -------------------------------------
1842 -- Apply_Subscript_Validity_Checks --
1843 -------------------------------------
1845 procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
1849 pragma Assert (Nkind (Expr) = N_Indexed_Component);
1851 -- Loop through subscripts
1853 Sub := First (Expressions (Expr));
1854 while Present (Sub) loop
1856 -- Check one subscript. Note that we do not worry about
1857 -- enumeration type with holes, since we will convert the
1858 -- value to a Pos value for the subscript, and that convert
1859 -- will do the necessary validity check.
1861 Ensure_Valid (Sub, Holes_OK => True);
1863 -- Move to next subscript
1867 end Apply_Subscript_Validity_Checks;
1869 ----------------------------------
1870 -- Apply_Type_Conversion_Checks --
1871 ----------------------------------
1873 procedure Apply_Type_Conversion_Checks (N : Node_Id) is
1874 Target_Type : constant Entity_Id := Etype (N);
1875 Target_Base : constant Entity_Id := Base_Type (Target_Type);
1876 Expr : constant Node_Id := Expression (N);
1877 Expr_Type : constant Entity_Id := Etype (Expr);
1880 if Inside_A_Generic then
1883 -- Skip these checks if serious errors detected, there are some nasty
1884 -- situations of incomplete trees that blow things up.
1886 elsif Serious_Errors_Detected > 0 then
1889 -- Scalar type conversions of the form Target_Type (Expr) require
1890 -- a range check if we cannot be sure that Expr is in the base type
1891 -- of Target_Typ and also that Expr is in the range of Target_Typ.
1892 -- These are not quite the same condition from an implementation
1893 -- point of view, but clearly the second includes the first.
1895 elsif Is_Scalar_Type (Target_Type) then
1897 Conv_OK : constant Boolean := Conversion_OK (N);
1898 -- If the Conversion_OK flag on the type conversion is set
1899 -- and no floating point type is involved in the type conversion
1900 -- then fixed point values must be read as integral values.
1903 if not Overflow_Checks_Suppressed (Target_Base)
1904 and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
1906 Set_Do_Overflow_Check (N);
1909 if not Range_Checks_Suppressed (Target_Type)
1910 and then not Range_Checks_Suppressed (Expr_Type)
1912 Apply_Scalar_Range_Check
1913 (Expr, Target_Type, Fixed_Int => Conv_OK);
1917 elsif Comes_From_Source (N)
1918 and then Is_Record_Type (Target_Type)
1919 and then Is_Derived_Type (Target_Type)
1920 and then not Is_Tagged_Type (Target_Type)
1921 and then not Is_Constrained (Target_Type)
1922 and then Present (Stored_Constraint (Target_Type))
1924 -- An unconstrained derived type may have inherited discriminant
1925 -- Build an actual discriminant constraint list using the stored
1926 -- constraint, to verify that the expression of the parent type
1927 -- satisfies the constraints imposed by the (unconstrained!)
1928 -- derived type. This applies to value conversions, not to view
1929 -- conversions of tagged types.
1932 Loc : constant Source_Ptr := Sloc (N);
1934 Constraint : Elmt_Id;
1935 Discr_Value : Node_Id;
1938 New_Constraints : constant Elist_Id := New_Elmt_List;
1939 Old_Constraints : constant Elist_Id :=
1940 Discriminant_Constraint (Expr_Type);
1943 Constraint := First_Elmt (Stored_Constraint (Target_Type));
1945 while Present (Constraint) loop
1946 Discr_Value := Node (Constraint);
1948 if Is_Entity_Name (Discr_Value)
1949 and then Ekind (Entity (Discr_Value)) = E_Discriminant
1951 Discr := Corresponding_Discriminant (Entity (Discr_Value));
1954 and then Scope (Discr) = Base_Type (Expr_Type)
1956 -- Parent is constrained by new discriminant. Obtain
1957 -- Value of original discriminant in expression. If
1958 -- the new discriminant has been used to constrain more
1959 -- than one of the stored discriminants, this will
1960 -- provide the required consistency check.
1963 Make_Selected_Component (Loc,
1965 Duplicate_Subexpr_No_Checks
1966 (Expr, Name_Req => True),
1968 Make_Identifier (Loc, Chars (Discr))),
1972 -- Discriminant of more remote ancestor ???
1977 -- Derived type definition has an explicit value for
1978 -- this stored discriminant.
1982 (Duplicate_Subexpr_No_Checks (Discr_Value),
1986 Next_Elmt (Constraint);
1989 -- Use the unconstrained expression type to retrieve the
1990 -- discriminants of the parent, and apply momentarily the
1991 -- discriminant constraint synthesized above.
1993 Set_Discriminant_Constraint (Expr_Type, New_Constraints);
1994 Cond := Build_Discriminant_Checks (Expr, Expr_Type);
1995 Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
1998 Make_Raise_Constraint_Error (Loc,
2000 Reason => CE_Discriminant_Check_Failed));
2003 -- For arrays, conversions are applied during expansion, to take
2004 -- into accounts changes of representation. The checks become range
2005 -- checks on the base type or length checks on the subtype, depending
2006 -- on whether the target type is unconstrained or constrained.
2011 end Apply_Type_Conversion_Checks;
2013 ----------------------------------------------
2014 -- Apply_Universal_Integer_Attribute_Checks --
2015 ----------------------------------------------
2017 procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is
2018 Loc : constant Source_Ptr := Sloc (N);
2019 Typ : constant Entity_Id := Etype (N);
2022 if Inside_A_Generic then
2025 -- Nothing to do if checks are suppressed
2027 elsif Range_Checks_Suppressed (Typ)
2028 and then Overflow_Checks_Suppressed (Typ)
2032 -- Nothing to do if the attribute does not come from source. The
2033 -- internal attributes we generate of this type do not need checks,
2034 -- and furthermore the attempt to check them causes some circular
2035 -- elaboration orders when dealing with packed types.
2037 elsif not Comes_From_Source (N) then
2040 -- If the prefix is a selected component that depends on a discriminant
2041 -- the check may improperly expose a discriminant instead of using
2042 -- the bounds of the object itself. Set the type of the attribute to
2043 -- the base type of the context, so that a check will be imposed when
2044 -- needed (e.g. if the node appears as an index).
2046 elsif Nkind (Prefix (N)) = N_Selected_Component
2047 and then Ekind (Typ) = E_Signed_Integer_Subtype
2048 and then Depends_On_Discriminant (Scalar_Range (Typ))
2050 Set_Etype (N, Base_Type (Typ));
2052 -- Otherwise, replace the attribute node with a type conversion
2053 -- node whose expression is the attribute, retyped to universal
2054 -- integer, and whose subtype mark is the target type. The call
2055 -- to analyze this conversion will set range and overflow checks
2056 -- as required for proper detection of an out of range value.
2059 Set_Etype (N, Universal_Integer);
2060 Set_Analyzed (N, True);
2063 Make_Type_Conversion (Loc,
2064 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
2065 Expression => Relocate_Node (N)));
2067 Analyze_And_Resolve (N, Typ);
2071 end Apply_Universal_Integer_Attribute_Checks;
2073 -------------------------------
2074 -- Build_Discriminant_Checks --
2075 -------------------------------
2077 function Build_Discriminant_Checks
2082 Loc : constant Source_Ptr := Sloc (N);
2085 Disc_Ent : Entity_Id;
2091 Disc := First_Elmt (Discriminant_Constraint (T_Typ));
2093 -- For a fully private type, use the discriminants of the parent type
2095 if Is_Private_Type (T_Typ)
2096 and then No (Full_View (T_Typ))
2098 Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ)));
2100 Disc_Ent := First_Discriminant (T_Typ);
2103 while Present (Disc) loop
2104 Dval := Node (Disc);
2106 if Nkind (Dval) = N_Identifier
2107 and then Ekind (Entity (Dval)) = E_Discriminant
2109 Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
2111 Dval := Duplicate_Subexpr_No_Checks (Dval);
2115 Make_Selected_Component (Loc,
2117 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
2119 Make_Identifier (Loc, Chars (Disc_Ent)));
2121 Set_Is_In_Discriminant_Check (Dref);
2123 Evolve_Or_Else (Cond,
2126 Right_Opnd => Dval));
2129 Next_Discriminant (Disc_Ent);
2133 end Build_Discriminant_Checks;
2135 -----------------------------------
2136 -- Check_Valid_Lvalue_Subscripts --
2137 -----------------------------------
2139 procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is
2141 -- Skip this if range checks are suppressed
2143 if Range_Checks_Suppressed (Etype (Expr)) then
2146 -- Only do this check for expressions that come from source. We
2147 -- assume that expander generated assignments explicitly include
2148 -- any necessary checks. Note that this is not just an optimization,
2149 -- it avoids infinite recursions!
2151 elsif not Comes_From_Source (Expr) then
2154 -- For a selected component, check the prefix
2156 elsif Nkind (Expr) = N_Selected_Component then
2157 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
2160 -- Case of indexed component
2162 elsif Nkind (Expr) = N_Indexed_Component then
2163 Apply_Subscript_Validity_Checks (Expr);
2165 -- Prefix may itself be or contain an indexed component, and
2166 -- these subscripts need checking as well
2168 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
2170 end Check_Valid_Lvalue_Subscripts;
2172 ----------------------------------
2173 -- Conditional_Statements_Begin --
2174 ----------------------------------
2176 procedure Conditional_Statements_Begin is
2178 Saved_Checks_TOS := Saved_Checks_TOS + 1;
2180 -- If stack overflows, kill all checks, that way we know to
2181 -- simply reset the number of saved checks to zero on return.
2182 -- This should never occur in practice.
2184 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
2187 -- In the normal case, we just make a new stack entry saving
2188 -- the current number of saved checks for a later restore.
2191 Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks;
2193 if Debug_Flag_CC then
2194 w ("Conditional_Statements_Begin: Num_Saved_Checks = ",
2198 end Conditional_Statements_Begin;
2200 --------------------------------
2201 -- Conditional_Statements_End --
2202 --------------------------------
2204 procedure Conditional_Statements_End is
2206 pragma Assert (Saved_Checks_TOS > 0);
2208 -- If the saved checks stack overflowed, then we killed all
2209 -- checks, so setting the number of saved checks back to
2210 -- zero is correct. This should never occur in practice.
2212 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
2213 Num_Saved_Checks := 0;
2215 -- In the normal case, restore the number of saved checks
2216 -- from the top stack entry.
2219 Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
2220 if Debug_Flag_CC then
2221 w ("Conditional_Statements_End: Num_Saved_Checks = ",
2226 Saved_Checks_TOS := Saved_Checks_TOS - 1;
2227 end Conditional_Statements_End;
2229 ---------------------
2230 -- Determine_Range --
2231 ---------------------
2233 Cache_Size : constant := 2 ** 10;
2234 type Cache_Index is range 0 .. Cache_Size - 1;
2235 -- Determine size of below cache (power of 2 is more efficient!)
2237 Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
2238 Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
2239 Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
2240 -- The above arrays are used to implement a small direct cache
2241 -- for Determine_Range calls. Because of the way Determine_Range
2242 -- recursively traces subexpressions, and because overflow checking
2243 -- calls the routine on the way up the tree, a quadratic behavior
2244 -- can otherwise be encountered in large expressions. The cache
2245 -- entry for node N is stored in the (N mod Cache_Size) entry, and
2246 -- can be validated by checking the actual node value stored there.
2248 procedure Determine_Range
2254 Typ : constant Entity_Id := Etype (N);
2258 -- Lo and Hi bounds of left operand
2262 -- Lo and Hi bounds of right (or only) operand
2265 -- Temp variable used to hold a bound node
2268 -- High bound of base type of expression
2272 -- Refined values for low and high bounds, after tightening
2275 -- Used in lower level calls to indicate if call succeeded
2277 Cindex : Cache_Index;
2278 -- Used to search cache
2280 function OK_Operands return Boolean;
2281 -- Used for binary operators. Determines the ranges of the left and
2282 -- right operands, and if they are both OK, returns True, and puts
2283 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left
2289 function OK_Operands return Boolean is
2291 Determine_Range (Left_Opnd (N), OK1, Lo_Left, Hi_Left);
2297 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
2301 -- Start of processing for Determine_Range
2304 -- Prevent junk warnings by initializing range variables
2311 -- If the type is not discrete, or is undefined, then we can't
2312 -- do anything about determining the range.
2314 if No (Typ) or else not Is_Discrete_Type (Typ)
2315 or else Error_Posted (N)
2321 -- For all other cases, we can determine the range
2325 -- If value is compile time known, then the possible range is the
2326 -- one value that we know this expression definitely has!
2328 if Compile_Time_Known_Value (N) then
2329 Lo := Expr_Value (N);
2334 -- Return if already in the cache
2336 Cindex := Cache_Index (N mod Cache_Size);
2338 if Determine_Range_Cache_N (Cindex) = N then
2339 Lo := Determine_Range_Cache_Lo (Cindex);
2340 Hi := Determine_Range_Cache_Hi (Cindex);
2344 -- Otherwise, start by finding the bounds of the type of the
2345 -- expression, the value cannot be outside this range (if it
2346 -- is, then we have an overflow situation, which is a separate
2347 -- check, we are talking here only about the expression value).
2349 -- We use the actual bound unless it is dynamic, in which case
2350 -- use the corresponding base type bound if possible. If we can't
2351 -- get a bound then we figure we can't determine the range (a
2352 -- peculiar case, that perhaps cannot happen, but there is no
2353 -- point in bombing in this optimization circuit.
2355 -- First the low bound
2357 Bound := Type_Low_Bound (Typ);
2359 if Compile_Time_Known_Value (Bound) then
2360 Lo := Expr_Value (Bound);
2362 elsif Compile_Time_Known_Value (Type_Low_Bound (Base_Type (Typ))) then
2363 Lo := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
2370 -- Now the high bound
2372 Bound := Type_High_Bound (Typ);
2374 -- We need the high bound of the base type later on, and this should
2375 -- always be compile time known. Again, it is not clear that this
2376 -- can ever be false, but no point in bombing.
2378 if Compile_Time_Known_Value (Type_High_Bound (Base_Type (Typ))) then
2379 Hbound := Expr_Value (Type_High_Bound (Base_Type (Typ)));
2387 -- If we have a static subtype, then that may have a tighter bound
2388 -- so use the upper bound of the subtype instead in this case.
2390 if Compile_Time_Known_Value (Bound) then
2391 Hi := Expr_Value (Bound);
2394 -- We may be able to refine this value in certain situations. If
2395 -- refinement is possible, then Lor and Hir are set to possibly
2396 -- tighter bounds, and OK1 is set to True.
2400 -- For unary plus, result is limited by range of operand
2403 Determine_Range (Right_Opnd (N), OK1, Lor, Hir);
2405 -- For unary minus, determine range of operand, and negate it
2408 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
2415 -- For binary addition, get range of each operand and do the
2416 -- addition to get the result range.
2420 Lor := Lo_Left + Lo_Right;
2421 Hir := Hi_Left + Hi_Right;
2424 -- Division is tricky. The only case we consider is where the
2425 -- right operand is a positive constant, and in this case we
2426 -- simply divide the bounds of the left operand
2430 if Lo_Right = Hi_Right
2431 and then Lo_Right > 0
2433 Lor := Lo_Left / Lo_Right;
2434 Hir := Hi_Left / Lo_Right;
2441 -- For binary subtraction, get range of each operand and do
2442 -- the worst case subtraction to get the result range.
2444 when N_Op_Subtract =>
2446 Lor := Lo_Left - Hi_Right;
2447 Hir := Hi_Left - Lo_Right;
2450 -- For MOD, if right operand is a positive constant, then
2451 -- result must be in the allowable range of mod results.
2455 if Lo_Right = Hi_Right
2456 and then Lo_Right /= 0
2458 if Lo_Right > 0 then
2460 Hir := Lo_Right - 1;
2462 else -- Lo_Right < 0
2463 Lor := Lo_Right + 1;
2472 -- For REM, if right operand is a positive constant, then
2473 -- result must be in the allowable range of mod results.
2477 if Lo_Right = Hi_Right
2478 and then Lo_Right /= 0
2481 Dval : constant Uint := (abs Lo_Right) - 1;
2484 -- The sign of the result depends on the sign of the
2485 -- dividend (but not on the sign of the divisor, hence
2486 -- the abs operation above).
2506 -- Attribute reference cases
2508 when N_Attribute_Reference =>
2509 case Attribute_Name (N) is
2511 -- For Pos/Val attributes, we can refine the range using the
2512 -- possible range of values of the attribute expression
2514 when Name_Pos | Name_Val =>
2515 Determine_Range (First (Expressions (N)), OK1, Lor, Hir);
2517 -- For Length attribute, use the bounds of the corresponding
2518 -- index type to refine the range.
2522 Atyp : Entity_Id := Etype (Prefix (N));
2530 if Is_Access_Type (Atyp) then
2531 Atyp := Designated_Type (Atyp);
2534 -- For string literal, we know exact value
2536 if Ekind (Atyp) = E_String_Literal_Subtype then
2538 Lo := String_Literal_Length (Atyp);
2539 Hi := String_Literal_Length (Atyp);
2543 -- Otherwise check for expression given
2545 if No (Expressions (N)) then
2549 UI_To_Int (Expr_Value (First (Expressions (N))));
2552 Indx := First_Index (Atyp);
2553 for J in 2 .. Inum loop
2554 Indx := Next_Index (Indx);
2558 (Type_Low_Bound (Etype (Indx)), OK1, LL, LU);
2562 (Type_High_Bound (Etype (Indx)), OK1, UL, UU);
2566 -- The maximum value for Length is the biggest
2567 -- possible gap between the values of the bounds.
2568 -- But of course, this value cannot be negative.
2570 Hir := UI_Max (Uint_0, UU - LL);
2572 -- For constrained arrays, the minimum value for
2573 -- Length is taken from the actual value of the
2574 -- bounds, since the index will be exactly of
2577 if Is_Constrained (Atyp) then
2578 Lor := UI_Max (Uint_0, UL - LU);
2580 -- For an unconstrained array, the minimum value
2581 -- for length is always zero.
2590 -- No special handling for other attributes
2591 -- Probably more opportunities exist here ???
2598 -- For type conversion from one discrete type to another, we
2599 -- can refine the range using the converted value.
2601 when N_Type_Conversion =>
2602 Determine_Range (Expression (N), OK1, Lor, Hir);
2604 -- Nothing special to do for all other expression kinds
2612 -- At this stage, if OK1 is true, then we know that the actual
2613 -- result of the computed expression is in the range Lor .. Hir.
2614 -- We can use this to restrict the possible range of results.
2618 -- If the refined value of the low bound is greater than the
2619 -- type high bound, then reset it to the more restrictive
2620 -- value. However, we do NOT do this for the case of a modular
2621 -- type where the possible upper bound on the value is above the
2622 -- base type high bound, because that means the result could wrap.
2625 and then not (Is_Modular_Integer_Type (Typ)
2626 and then Hir > Hbound)
2631 -- Similarly, if the refined value of the high bound is less
2632 -- than the value so far, then reset it to the more restrictive
2633 -- value. Again, we do not do this if the refined low bound is
2634 -- negative for a modular type, since this would wrap.
2637 and then not (Is_Modular_Integer_Type (Typ)
2638 and then Lor < Uint_0)
2644 -- Set cache entry for future call and we are all done
2646 Determine_Range_Cache_N (Cindex) := N;
2647 Determine_Range_Cache_Lo (Cindex) := Lo;
2648 Determine_Range_Cache_Hi (Cindex) := Hi;
2651 -- If any exception occurs, it means that we have some bug in the compiler
2652 -- possibly triggered by a previous error, or by some unforseen peculiar
2653 -- occurrence. However, this is only an optimization attempt, so there is
2654 -- really no point in crashing the compiler. Instead we just decide, too
2655 -- bad, we can't figure out a range in this case after all.
2660 -- Debug flag K disables this behavior (useful for debugging)
2662 if Debug_Flag_K then
2670 end Determine_Range;
2672 ------------------------------------
2673 -- Discriminant_Checks_Suppressed --
2674 ------------------------------------
2676 function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
2679 if Is_Unchecked_Union (E) then
2681 elsif Checks_May_Be_Suppressed (E) then
2682 return Is_Check_Suppressed (E, Discriminant_Check);
2686 return Scope_Suppress (Discriminant_Check);
2687 end Discriminant_Checks_Suppressed;
2689 --------------------------------
2690 -- Division_Checks_Suppressed --
2691 --------------------------------
2693 function Division_Checks_Suppressed (E : Entity_Id) return Boolean is
2695 if Present (E) and then Checks_May_Be_Suppressed (E) then
2696 return Is_Check_Suppressed (E, Division_Check);
2698 return Scope_Suppress (Division_Check);
2700 end Division_Checks_Suppressed;
2702 -----------------------------------
2703 -- Elaboration_Checks_Suppressed --
2704 -----------------------------------
2706 function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
2709 if Kill_Elaboration_Checks (E) then
2711 elsif Checks_May_Be_Suppressed (E) then
2712 return Is_Check_Suppressed (E, Elaboration_Check);
2716 return Scope_Suppress (Elaboration_Check);
2717 end Elaboration_Checks_Suppressed;
2719 ---------------------------
2720 -- Enable_Overflow_Check --
2721 ---------------------------
2723 procedure Enable_Overflow_Check (N : Node_Id) is
2724 Typ : constant Entity_Id := Base_Type (Etype (N));
2733 if Debug_Flag_CC then
2734 w ("Enable_Overflow_Check for node ", Int (N));
2735 Write_Str (" Source location = ");
2740 -- Nothing to do if the range of the result is known OK. We skip
2741 -- this for conversions, since the caller already did the check,
2742 -- and in any case the condition for deleting the check for a
2743 -- type conversion is different in any case.
2745 if Nkind (N) /= N_Type_Conversion then
2746 Determine_Range (N, OK, Lo, Hi);
2748 -- Note in the test below that we assume that if a bound of the
2749 -- range is equal to that of the type. That's not quite accurate
2750 -- but we do this for the following reasons:
2752 -- a) The way that Determine_Range works, it will typically report
2753 -- the bounds of the value as being equal to the bounds of the
2754 -- type, because it either can't tell anything more precise, or
2755 -- does not think it is worth the effort to be more precise.
2757 -- b) It is very unusual to have a situation in which this would
2758 -- generate an unnecessary overflow check (an example would be
2759 -- a subtype with a range 0 .. Integer'Last - 1 to which the
2760 -- literal value one is added.
2762 -- c) The alternative is a lot of special casing in this routine
2763 -- which would partially duplicate Determine_Range processing.
2766 and then Lo > Expr_Value (Type_Low_Bound (Typ))
2767 and then Hi < Expr_Value (Type_High_Bound (Typ))
2769 if Debug_Flag_CC then
2770 w ("No overflow check required");
2777 -- If not in optimizing mode, set flag and we are done. We are also
2778 -- done (and just set the flag) if the type is not a discrete type,
2779 -- since it is not worth the effort to eliminate checks for other
2780 -- than discrete types. In addition, we take this same path if we
2781 -- have stored the maximum number of checks possible already (a
2782 -- very unlikely situation, but we do not want to blow up!)
2784 if Optimization_Level = 0
2785 or else not Is_Discrete_Type (Etype (N))
2786 or else Num_Saved_Checks = Saved_Checks'Last
2788 Set_Do_Overflow_Check (N, True);
2790 if Debug_Flag_CC then
2791 w ("Optimization off");
2797 -- Otherwise evaluate and check the expression
2802 Target_Type => Empty,
2808 if Debug_Flag_CC then
2809 w ("Called Find_Check");
2813 w (" Check_Num = ", Chk);
2814 w (" Ent = ", Int (Ent));
2815 Write_Str (" Ofs = ");
2820 -- If check is not of form to optimize, then set flag and we are done
2823 Set_Do_Overflow_Check (N, True);
2827 -- If check is already performed, then return without setting flag
2830 if Debug_Flag_CC then
2831 w ("Check suppressed!");
2837 -- Here we will make a new entry for the new check
2839 Set_Do_Overflow_Check (N, True);
2840 Num_Saved_Checks := Num_Saved_Checks + 1;
2841 Saved_Checks (Num_Saved_Checks) :=
2846 Target_Type => Empty);
2848 if Debug_Flag_CC then
2849 w ("Make new entry, check number = ", Num_Saved_Checks);
2850 w (" Entity = ", Int (Ent));
2851 Write_Str (" Offset = ");
2853 w (" Check_Type = O");
2854 w (" Target_Type = Empty");
2857 -- If we get an exception, then something went wrong, probably because
2858 -- of an error in the structure of the tree due to an incorrect program.
2859 -- Or it may be a bug in the optimization circuit. In either case the
2860 -- safest thing is simply to set the check flag unconditionally.
2864 Set_Do_Overflow_Check (N, True);
2866 if Debug_Flag_CC then
2867 w (" exception occurred, overflow flag set");
2871 end Enable_Overflow_Check;
2873 ------------------------
2874 -- Enable_Range_Check --
2875 ------------------------
2877 procedure Enable_Range_Check (N : Node_Id) is
2886 -- Return if unchecked type conversion with range check killed.
2887 -- In this case we never set the flag (that's what Kill_Range_Check
2890 if Nkind (N) = N_Unchecked_Type_Conversion
2891 and then Kill_Range_Check (N)
2896 -- Debug trace output
2898 if Debug_Flag_CC then
2899 w ("Enable_Range_Check for node ", Int (N));
2900 Write_Str (" Source location = ");
2905 -- If not in optimizing mode, set flag and we are done. We are also
2906 -- done (and just set the flag) if the type is not a discrete type,
2907 -- since it is not worth the effort to eliminate checks for other
2908 -- than discrete types. In addition, we take this same path if we
2909 -- have stored the maximum number of checks possible already (a
2910 -- very unlikely situation, but we do not want to blow up!)
2912 if Optimization_Level = 0
2913 or else No (Etype (N))
2914 or else not Is_Discrete_Type (Etype (N))
2915 or else Num_Saved_Checks = Saved_Checks'Last
2917 Set_Do_Range_Check (N, True);
2919 if Debug_Flag_CC then
2920 w ("Optimization off");
2926 -- Otherwise find out the target type
2930 -- For assignment, use left side subtype
2932 if Nkind (P) = N_Assignment_Statement
2933 and then Expression (P) = N
2935 Ttyp := Etype (Name (P));
2937 -- For indexed component, use subscript subtype
2939 elsif Nkind (P) = N_Indexed_Component then
2946 Atyp := Etype (Prefix (P));
2948 if Is_Access_Type (Atyp) then
2949 Atyp := Designated_Type (Atyp);
2952 Indx := First_Index (Atyp);
2953 Subs := First (Expressions (P));
2956 Ttyp := Etype (Indx);
2965 -- For now, ignore all other cases, they are not so interesting
2968 if Debug_Flag_CC then
2969 w (" target type not found, flag set");
2972 Set_Do_Range_Check (N, True);
2976 -- Evaluate and check the expression
2981 Target_Type => Ttyp,
2987 if Debug_Flag_CC then
2988 w ("Called Find_Check");
2989 w ("Target_Typ = ", Int (Ttyp));
2993 w (" Check_Num = ", Chk);
2994 w (" Ent = ", Int (Ent));
2995 Write_Str (" Ofs = ");
3000 -- If check is not of form to optimize, then set flag and we are done
3003 if Debug_Flag_CC then
3004 w (" expression not of optimizable type, flag set");
3007 Set_Do_Range_Check (N, True);
3011 -- If check is already performed, then return without setting flag
3014 if Debug_Flag_CC then
3015 w ("Check suppressed!");
3021 -- Here we will make a new entry for the new check
3023 Set_Do_Range_Check (N, True);
3024 Num_Saved_Checks := Num_Saved_Checks + 1;
3025 Saved_Checks (Num_Saved_Checks) :=
3030 Target_Type => Ttyp);
3032 if Debug_Flag_CC then
3033 w ("Make new entry, check number = ", Num_Saved_Checks);
3034 w (" Entity = ", Int (Ent));
3035 Write_Str (" Offset = ");
3037 w (" Check_Type = R");
3038 w (" Target_Type = ", Int (Ttyp));
3042 -- If we get an exception, then something went wrong, probably because
3043 -- of an error in the structure of the tree due to an incorrect program.
3044 -- Or it may be a bug in the optimization circuit. In either case the
3045 -- safest thing is simply to set the check flag unconditionally.
3049 Set_Do_Range_Check (N, True);
3051 if Debug_Flag_CC then
3052 w (" exception occurred, range flag set");
3056 end Enable_Range_Check;
3062 procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False) is
3063 Typ : constant Entity_Id := Etype (Expr);
3066 -- Ignore call if we are not doing any validity checking
3068 if not Validity_Checks_On then
3071 -- Ignore call if range checks suppressed on entity in question
3073 elsif Is_Entity_Name (Expr)
3074 and then Range_Checks_Suppressed (Entity (Expr))
3078 -- No check required if expression is from the expander, we assume
3079 -- the expander will generate whatever checks are needed. Note that
3080 -- this is not just an optimization, it avoids infinite recursions!
3082 -- Unchecked conversions must be checked, unless they are initialized
3083 -- scalar values, as in a component assignment in an init proc.
3085 -- In addition, we force a check if Force_Validity_Checks is set
3087 elsif not Comes_From_Source (Expr)
3088 and then not Force_Validity_Checks
3089 and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
3090 or else Kill_Range_Check (Expr))
3094 -- No check required if expression is known to have valid value
3096 elsif Expr_Known_Valid (Expr) then
3099 -- No check required if checks off
3101 elsif Range_Checks_Suppressed (Typ) then
3104 -- Ignore case of enumeration with holes where the flag is set not
3105 -- to worry about holes, since no special validity check is needed
3107 elsif Is_Enumeration_Type (Typ)
3108 and then Has_Non_Standard_Rep (Typ)
3113 -- No check required on the left-hand side of an assignment.
3115 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
3116 and then Expr = Name (Parent (Expr))
3120 -- An annoying special case. If this is an out parameter of a scalar
3121 -- type, then the value is not going to be accessed, therefore it is
3122 -- inappropriate to do any validity check at the call site.
3125 -- Only need to worry about scalar types
3127 if Is_Scalar_Type (Typ) then
3137 -- Find actual argument (which may be a parameter association)
3138 -- and the parent of the actual argument (the call statement)
3143 if Nkind (P) = N_Parameter_Association then
3148 -- Only need to worry if we are argument of a procedure
3149 -- call since functions don't have out parameters. If this
3150 -- is an indirect or dispatching call, get signature from
3151 -- the subprogram type.
3153 if Nkind (P) = N_Procedure_Call_Statement then
3154 L := Parameter_Associations (P);
3156 if Is_Entity_Name (Name (P)) then
3157 E := Entity (Name (P));
3159 pragma Assert (Nkind (Name (P)) = N_Explicit_Dereference);
3160 E := Etype (Name (P));
3163 -- Only need to worry if there are indeed actuals, and
3164 -- if this could be a procedure call, otherwise we cannot
3165 -- get a match (either we are not an argument, or the
3166 -- mode of the formal is not OUT). This test also filters
3167 -- out the generic case.
3169 if Is_Non_Empty_List (L)
3170 and then Is_Subprogram (E)
3172 -- This is the loop through parameters, looking to
3173 -- see if there is an OUT parameter for which we are
3176 F := First_Formal (E);
3179 while Present (F) loop
3180 if Ekind (F) = E_Out_Parameter and then A = N then
3193 -- If we fall through, a validity check is required. Note that it would
3194 -- not be good to set Do_Range_Check, even in contexts where this is
3195 -- permissible, since this flag causes checking against the target type,
3196 -- not the source type in contexts such as assignments
3198 Insert_Valid_Check (Expr);
3201 ----------------------
3202 -- Expr_Known_Valid --
3203 ----------------------
3205 function Expr_Known_Valid (Expr : Node_Id) return Boolean is
3206 Typ : constant Entity_Id := Etype (Expr);
3209 -- Non-scalar types are always consdered valid, since they never
3210 -- give rise to the issues of erroneous or bounded error behavior
3211 -- that are the concern. In formal reference manual terms the
3212 -- notion of validity only applies to scalar types.
3214 if not Is_Scalar_Type (Typ) then
3217 -- If no validity checking, then everything is considered valid
3219 elsif not Validity_Checks_On then
3222 -- Floating-point types are considered valid unless floating-point
3223 -- validity checks have been specifically turned on.
3225 elsif Is_Floating_Point_Type (Typ)
3226 and then not Validity_Check_Floating_Point
3230 -- If the expression is the value of an object that is known to
3231 -- be valid, then clearly the expression value itself is valid.
3233 elsif Is_Entity_Name (Expr)
3234 and then Is_Known_Valid (Entity (Expr))
3238 -- If the type is one for which all values are known valid, then
3239 -- we are sure that the value is valid except in the slightly odd
3240 -- case where the expression is a reference to a variable whose size
3241 -- has been explicitly set to a value greater than the object size.
3243 elsif Is_Known_Valid (Typ) then
3244 if Is_Entity_Name (Expr)
3245 and then Ekind (Entity (Expr)) = E_Variable
3246 and then Esize (Entity (Expr)) > Esize (Typ)
3253 -- Integer and character literals always have valid values, where
3254 -- appropriate these will be range checked in any case.
3256 elsif Nkind (Expr) = N_Integer_Literal
3258 Nkind (Expr) = N_Character_Literal
3262 -- If we have a type conversion or a qualification of a known valid
3263 -- value, then the result will always be valid.
3265 elsif Nkind (Expr) = N_Type_Conversion
3267 Nkind (Expr) = N_Qualified_Expression
3269 return Expr_Known_Valid (Expression (Expr));
3271 -- The result of any function call or operator is always considered
3272 -- valid, since we assume the necessary checks are done by the call.
3274 elsif Nkind (Expr) in N_Binary_Op
3276 Nkind (Expr) in N_Unary_Op
3278 Nkind (Expr) = N_Function_Call
3282 -- For all other cases, we do not know the expression is valid
3287 end Expr_Known_Valid;
3293 procedure Find_Check
3295 Check_Type : Character;
3296 Target_Type : Entity_Id;
3297 Entry_OK : out Boolean;
3298 Check_Num : out Nat;
3299 Ent : out Entity_Id;
3302 function Within_Range_Of
3303 (Target_Type : Entity_Id;
3304 Check_Type : Entity_Id)
3306 -- Given a requirement for checking a range against Target_Type, and
3307 -- and a range Check_Type against which a check has already been made,
3308 -- determines if the check against check type is sufficient to ensure
3309 -- that no check against Target_Type is required.
3311 ---------------------
3312 -- Within_Range_Of --
3313 ---------------------
3315 function Within_Range_Of
3316 (Target_Type : Entity_Id;
3317 Check_Type : Entity_Id)
3321 if Target_Type = Check_Type then
3326 Tlo : constant Node_Id := Type_Low_Bound (Target_Type);
3327 Thi : constant Node_Id := Type_High_Bound (Target_Type);
3328 Clo : constant Node_Id := Type_Low_Bound (Check_Type);
3329 Chi : constant Node_Id := Type_High_Bound (Check_Type);
3333 or else (Compile_Time_Known_Value (Tlo)
3335 Compile_Time_Known_Value (Clo)
3337 Expr_Value (Clo) >= Expr_Value (Tlo)))
3340 or else (Compile_Time_Known_Value (Thi)
3342 Compile_Time_Known_Value (Chi)
3344 Expr_Value (Chi) <= Expr_Value (Clo)))
3352 end Within_Range_Of;
3354 -- Start of processing for Find_Check
3357 -- Establish default, to avoid warnings from GCC.
3361 -- Case of expression is simple entity reference
3363 if Is_Entity_Name (Expr) then
3364 Ent := Entity (Expr);
3367 -- Case of expression is entity + known constant
3369 elsif Nkind (Expr) = N_Op_Add
3370 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3371 and then Is_Entity_Name (Left_Opnd (Expr))
3373 Ent := Entity (Left_Opnd (Expr));
3374 Ofs := Expr_Value (Right_Opnd (Expr));
3376 -- Case of expression is entity - known constant
3378 elsif Nkind (Expr) = N_Op_Subtract
3379 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3380 and then Is_Entity_Name (Left_Opnd (Expr))
3382 Ent := Entity (Left_Opnd (Expr));
3383 Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr)));
3385 -- Any other expression is not of the right form
3394 -- Come here with expression of appropriate form, check if
3395 -- entity is an appropriate one for our purposes.
3397 if (Ekind (Ent) = E_Variable
3399 Ekind (Ent) = E_Constant
3401 Ekind (Ent) = E_Loop_Parameter
3403 Ekind (Ent) = E_In_Parameter)
3404 and then not Is_Library_Level_Entity (Ent)
3412 -- See if there is matching check already
3414 for J in reverse 1 .. Num_Saved_Checks loop
3416 SC : Saved_Check renames Saved_Checks (J);
3419 if SC.Killed = False
3420 and then SC.Entity = Ent
3421 and then SC.Offset = Ofs
3422 and then SC.Check_Type = Check_Type
3423 and then Within_Range_Of (Target_Type, SC.Target_Type)
3431 -- If we fall through entry was not found
3437 ---------------------------------
3438 -- Generate_Discriminant_Check --
3439 ---------------------------------
3441 -- Note: the code for this procedure is derived from the
3442 -- emit_discriminant_check routine a-trans.c v1.659.
3444 procedure Generate_Discriminant_Check (N : Node_Id) is
3445 Loc : constant Source_Ptr := Sloc (N);
3446 Pref : constant Node_Id := Prefix (N);
3447 Sel : constant Node_Id := Selector_Name (N);
3449 Orig_Comp : constant Entity_Id :=
3450 Original_Record_Component (Entity (Sel));
3451 -- The original component to be checked
3453 Discr_Fct : constant Entity_Id :=
3454 Discriminant_Checking_Func (Orig_Comp);
3455 -- The discriminant checking function
3458 -- One discriminant to be checked in the type
3460 Real_Discr : Entity_Id;
3461 -- Actual discriminant in the call
3463 Pref_Type : Entity_Id;
3464 -- Type of relevant prefix (ignoring private/access stuff)
3467 -- List of arguments for function call
3470 -- Keep track of the formal corresponding to the actual we build
3471 -- for each discriminant, in order to be able to perform the
3472 -- necessary type conversions.
3475 -- Selected component reference for checking function argument
3478 Pref_Type := Etype (Pref);
3480 -- Force evaluation of the prefix, so that it does not get evaluated
3481 -- twice (once for the check, once for the actual reference). Such a
3482 -- double evaluation is always a potential source of inefficiency,
3483 -- and is functionally incorrect in the volatile case, or when the
3484 -- prefix may have side-effects. An entity or a component of an
3485 -- entity requires no evaluation.
3487 if Is_Entity_Name (Pref) then
3488 if Treat_As_Volatile (Entity (Pref)) then
3489 Force_Evaluation (Pref, Name_Req => True);
3492 elsif Treat_As_Volatile (Etype (Pref)) then
3493 Force_Evaluation (Pref, Name_Req => True);
3495 elsif Nkind (Pref) = N_Selected_Component
3496 and then Is_Entity_Name (Prefix (Pref))
3501 Force_Evaluation (Pref, Name_Req => True);
3504 -- For a tagged type, use the scope of the original component to
3505 -- obtain the type, because ???
3507 if Is_Tagged_Type (Scope (Orig_Comp)) then
3508 Pref_Type := Scope (Orig_Comp);
3510 -- For an untagged derived type, use the discriminants of the
3511 -- parent which have been renamed in the derivation, possibly
3512 -- by a one-to-many discriminant constraint.
3513 -- For non-tagged type, initially get the Etype of the prefix
3516 if Is_Derived_Type (Pref_Type)
3517 and then Number_Discriminants (Pref_Type) /=
3518 Number_Discriminants (Etype (Base_Type (Pref_Type)))
3520 Pref_Type := Etype (Base_Type (Pref_Type));
3524 -- We definitely should have a checking function, This routine should
3525 -- not be called if no discriminant checking function is present.
3527 pragma Assert (Present (Discr_Fct));
3529 -- Create the list of the actual parameters for the call. This list
3530 -- is the list of the discriminant fields of the record expression to
3531 -- be discriminant checked.
3534 Formal := First_Formal (Discr_Fct);
3535 Discr := First_Discriminant (Pref_Type);
3536 while Present (Discr) loop
3538 -- If we have a corresponding discriminant field, and a parent
3539 -- subtype is present, then we want to use the corresponding
3540 -- discriminant since this is the one with the useful value.
3542 if Present (Corresponding_Discriminant (Discr))
3543 and then Ekind (Pref_Type) = E_Record_Type
3544 and then Present (Parent_Subtype (Pref_Type))
3546 Real_Discr := Corresponding_Discriminant (Discr);
3548 Real_Discr := Discr;
3551 -- Construct the reference to the discriminant
3554 Make_Selected_Component (Loc,
3556 Unchecked_Convert_To (Pref_Type,
3557 Duplicate_Subexpr (Pref)),
3558 Selector_Name => New_Occurrence_Of (Real_Discr, Loc));
3560 -- Manually analyze and resolve this selected component. We really
3561 -- want it just as it appears above, and do not want the expander
3562 -- playing discriminal games etc with this reference. Then we
3563 -- append the argument to the list we are gathering.
3565 Set_Etype (Scomp, Etype (Real_Discr));
3566 Set_Analyzed (Scomp, True);
3567 Append_To (Args, Convert_To (Etype (Formal), Scomp));
3569 Next_Formal_With_Extras (Formal);
3570 Next_Discriminant (Discr);
3573 -- Now build and insert the call
3576 Make_Raise_Constraint_Error (Loc,
3578 Make_Function_Call (Loc,
3579 Name => New_Occurrence_Of (Discr_Fct, Loc),
3580 Parameter_Associations => Args),
3581 Reason => CE_Discriminant_Check_Failed));
3582 end Generate_Discriminant_Check;
3584 ----------------------------
3585 -- Generate_Index_Checks --
3586 ----------------------------
3588 procedure Generate_Index_Checks (N : Node_Id) is
3589 Loc : constant Source_Ptr := Sloc (N);
3590 A : constant Node_Id := Prefix (N);
3596 Sub := First (Expressions (N));
3598 while Present (Sub) loop
3599 if Do_Range_Check (Sub) then
3600 Set_Do_Range_Check (Sub, False);
3602 -- Force evaluation except for the case of a simple name of
3603 -- a non-volatile entity.
3605 if not Is_Entity_Name (Sub)
3606 or else Treat_As_Volatile (Entity (Sub))
3608 Force_Evaluation (Sub);
3611 -- Generate a raise of constraint error with the appropriate
3612 -- reason and a condition of the form:
3614 -- Base_Type(Sub) not in array'range (subscript)
3616 -- Note that the reason we generate the conversion to the
3617 -- base type here is that we definitely want the range check
3618 -- to take place, even if it looks like the subtype is OK.
3619 -- Optimization considerations that allow us to omit the
3620 -- check have already been taken into account in the setting
3621 -- of the Do_Range_Check flag earlier on.
3626 Num := New_List (Make_Integer_Literal (Loc, Ind));
3630 Make_Raise_Constraint_Error (Loc,
3634 Convert_To (Base_Type (Etype (Sub)),
3635 Duplicate_Subexpr_Move_Checks (Sub)),
3637 Make_Attribute_Reference (Loc,
3638 Prefix => Duplicate_Subexpr_Move_Checks (A),
3639 Attribute_Name => Name_Range,
3640 Expressions => Num)),
3641 Reason => CE_Index_Check_Failed));
3647 end Generate_Index_Checks;
3649 --------------------------
3650 -- Generate_Range_Check --
3651 --------------------------
3653 procedure Generate_Range_Check
3655 Target_Type : Entity_Id;
3656 Reason : RT_Exception_Code)
3658 Loc : constant Source_Ptr := Sloc (N);
3659 Source_Type : constant Entity_Id := Etype (N);
3660 Source_Base_Type : constant Entity_Id := Base_Type (Source_Type);
3661 Target_Base_Type : constant Entity_Id := Base_Type (Target_Type);
3664 -- First special case, if the source type is already within the
3665 -- range of the target type, then no check is needed (probably we
3666 -- should have stopped Do_Range_Check from being set in the first
3667 -- place, but better late than later in preventing junk code!
3669 -- We do NOT apply this if the source node is a literal, since in
3670 -- this case the literal has already been labeled as having the
3671 -- subtype of the target.
3673 if In_Subrange_Of (Source_Type, Target_Type)
3675 (Nkind (N) = N_Integer_Literal
3677 Nkind (N) = N_Real_Literal
3679 Nkind (N) = N_Character_Literal
3682 and then Ekind (Entity (N)) = E_Enumeration_Literal))
3687 -- We need a check, so force evaluation of the node, so that it does
3688 -- not get evaluated twice (once for the check, once for the actual
3689 -- reference). Such a double evaluation is always a potential source
3690 -- of inefficiency, and is functionally incorrect in the volatile case.
3692 if not Is_Entity_Name (N)
3693 or else Treat_As_Volatile (Entity (N))
3695 Force_Evaluation (N);
3698 -- The easiest case is when Source_Base_Type and Target_Base_Type
3699 -- are the same since in this case we can simply do a direct
3700 -- check of the value of N against the bounds of Target_Type.
3702 -- [constraint_error when N not in Target_Type]
3704 -- Note: this is by far the most common case, for example all cases of
3705 -- checks on the RHS of assignments are in this category, but not all
3706 -- cases are like this. Notably conversions can involve two types.
3708 if Source_Base_Type = Target_Base_Type then
3710 Make_Raise_Constraint_Error (Loc,
3713 Left_Opnd => Duplicate_Subexpr (N),
3714 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
3717 -- Next test for the case where the target type is within the bounds
3718 -- of the base type of the source type, since in this case we can
3719 -- simply convert these bounds to the base type of T to do the test.
3721 -- [constraint_error when N not in
3722 -- Source_Base_Type (Target_Type'First)
3724 -- Source_Base_Type(Target_Type'Last))]
3726 -- The conversions will always work and need no check.
3728 elsif In_Subrange_Of (Target_Type, Source_Base_Type) then
3730 Make_Raise_Constraint_Error (Loc,
3733 Left_Opnd => Duplicate_Subexpr (N),
3738 Convert_To (Source_Base_Type,
3739 Make_Attribute_Reference (Loc,
3741 New_Occurrence_Of (Target_Type, Loc),
3742 Attribute_Name => Name_First)),
3745 Convert_To (Source_Base_Type,
3746 Make_Attribute_Reference (Loc,
3748 New_Occurrence_Of (Target_Type, Loc),
3749 Attribute_Name => Name_Last)))),
3752 -- Note that at this stage we now that the Target_Base_Type is
3753 -- not in the range of the Source_Base_Type (since even the
3754 -- Target_Type itself is not in this range). It could still be
3755 -- the case that the Source_Type is in range of the target base
3756 -- type, since we have not checked that case.
3758 -- If that is the case, we can freely convert the source to the
3759 -- target, and then test the target result against the bounds.
3761 elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
3763 -- We make a temporary to hold the value of the converted
3764 -- value (converted to the base type), and then we will
3765 -- do the test against this temporary.
3767 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
3768 -- [constraint_error when Tnn not in Target_Type]
3770 -- Then the conversion itself is replaced by an occurrence of Tnn
3773 Tnn : constant Entity_Id :=
3774 Make_Defining_Identifier (Loc,
3775 Chars => New_Internal_Name ('T'));
3778 Insert_Actions (N, New_List (
3779 Make_Object_Declaration (Loc,
3780 Defining_Identifier => Tnn,
3781 Object_Definition =>
3782 New_Occurrence_Of (Target_Base_Type, Loc),
3783 Constant_Present => True,
3785 Make_Type_Conversion (Loc,
3786 Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
3787 Expression => Duplicate_Subexpr (N))),
3789 Make_Raise_Constraint_Error (Loc,
3792 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
3793 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
3795 Reason => Reason)));
3797 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
3800 -- At this stage, we know that we have two scalar types, which are
3801 -- directly convertible, and where neither scalar type has a base
3802 -- range that is in the range of the other scalar type.
3804 -- The only way this can happen is with a signed and unsigned type.
3805 -- So test for these two cases:
3808 -- Case of the source is unsigned and the target is signed
3810 if Is_Unsigned_Type (Source_Base_Type)
3811 and then not Is_Unsigned_Type (Target_Base_Type)
3813 -- If the source is unsigned and the target is signed, then we
3814 -- know that the source is not shorter than the target (otherwise
3815 -- the source base type would be in the target base type range).
3817 -- In other words, the unsigned type is either the same size
3818 -- as the target, or it is larger. It cannot be smaller.
3821 (Esize (Source_Base_Type) >= Esize (Target_Base_Type));
3823 -- We only need to check the low bound if the low bound of the
3824 -- target type is non-negative. If the low bound of the target
3825 -- type is negative, then we know that we will fit fine.
3827 -- If the high bound of the target type is negative, then we
3828 -- know we have a constraint error, since we can't possibly
3829 -- have a negative source.
3831 -- With these two checks out of the way, we can do the check
3832 -- using the source type safely
3834 -- This is definitely the most annoying case!
3836 -- [constraint_error
3837 -- when (Target_Type'First >= 0
3839 -- N < Source_Base_Type (Target_Type'First))
3840 -- or else Target_Type'Last < 0
3841 -- or else N > Source_Base_Type (Target_Type'Last)];
3843 -- We turn off all checks since we know that the conversions
3844 -- will work fine, given the guards for negative values.
3847 Make_Raise_Constraint_Error (Loc,
3853 Left_Opnd => Make_Op_Ge (Loc,
3855 Make_Attribute_Reference (Loc,
3857 New_Occurrence_Of (Target_Type, Loc),
3858 Attribute_Name => Name_First),
3859 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3863 Left_Opnd => Duplicate_Subexpr (N),
3865 Convert_To (Source_Base_Type,
3866 Make_Attribute_Reference (Loc,
3868 New_Occurrence_Of (Target_Type, Loc),
3869 Attribute_Name => Name_First)))),
3874 Make_Attribute_Reference (Loc,
3875 Prefix => New_Occurrence_Of (Target_Type, Loc),
3876 Attribute_Name => Name_Last),
3877 Right_Opnd => Make_Integer_Literal (Loc, Uint_0))),
3881 Left_Opnd => Duplicate_Subexpr (N),
3883 Convert_To (Source_Base_Type,
3884 Make_Attribute_Reference (Loc,
3885 Prefix => New_Occurrence_Of (Target_Type, Loc),
3886 Attribute_Name => Name_Last)))),
3889 Suppress => All_Checks);
3891 -- Only remaining possibility is that the source is signed and
3892 -- the target is unsigned
3895 pragma Assert (not Is_Unsigned_Type (Source_Base_Type)
3896 and then Is_Unsigned_Type (Target_Base_Type));
3898 -- If the source is signed and the target is unsigned, then
3899 -- we know that the target is not shorter than the source
3900 -- (otherwise the target base type would be in the source
3901 -- base type range).
3903 -- In other words, the unsigned type is either the same size
3904 -- as the target, or it is larger. It cannot be smaller.
3906 -- Clearly we have an error if the source value is negative
3907 -- since no unsigned type can have negative values. If the
3908 -- source type is non-negative, then the check can be done
3909 -- using the target type.
3911 -- Tnn : constant Target_Base_Type (N) := Target_Type;
3913 -- [constraint_error
3914 -- when N < 0 or else Tnn not in Target_Type];
3916 -- We turn off all checks for the conversion of N to the
3917 -- target base type, since we generate the explicit check
3918 -- to ensure that the value is non-negative
3921 Tnn : constant Entity_Id :=
3922 Make_Defining_Identifier (Loc,
3923 Chars => New_Internal_Name ('T'));
3926 Insert_Actions (N, New_List (
3927 Make_Object_Declaration (Loc,
3928 Defining_Identifier => Tnn,
3929 Object_Definition =>
3930 New_Occurrence_Of (Target_Base_Type, Loc),
3931 Constant_Present => True,
3933 Make_Type_Conversion (Loc,
3935 New_Occurrence_Of (Target_Base_Type, Loc),
3936 Expression => Duplicate_Subexpr (N))),
3938 Make_Raise_Constraint_Error (Loc,
3943 Left_Opnd => Duplicate_Subexpr (N),
3944 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3948 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
3950 New_Occurrence_Of (Target_Type, Loc))),
3953 Suppress => All_Checks);
3955 -- Set the Etype explicitly, because Insert_Actions may
3956 -- have placed the declaration in the freeze list for an
3957 -- enclosing construct, and thus it is not analyzed yet.
3959 Set_Etype (Tnn, Target_Base_Type);
3960 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
3964 end Generate_Range_Check;
3966 ---------------------
3967 -- Get_Discriminal --
3968 ---------------------
3970 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is
3971 Loc : constant Source_Ptr := Sloc (E);
3976 -- The entity E is the type of a private component of the protected
3977 -- type, or the type of a renaming of that component within a protected
3978 -- operation of that type.
3982 if Ekind (Sc) /= E_Protected_Type then
3985 if Ekind (Sc) /= E_Protected_Type then
3990 D := First_Discriminant (Sc);
3993 and then Chars (D) /= Chars (Bound)
3995 Next_Discriminant (D);
3998 return New_Occurrence_Of (Discriminal (D), Loc);
3999 end Get_Discriminal;
4005 function Guard_Access
4012 if Nkind (Cond) = N_Or_Else then
4013 Set_Paren_Count (Cond, 1);
4016 if Nkind (Ck_Node) = N_Allocator then
4023 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
4024 Right_Opnd => Make_Null (Loc)),
4025 Right_Opnd => Cond);
4029 -----------------------------
4030 -- Index_Checks_Suppressed --
4031 -----------------------------
4033 function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
4035 if Present (E) and then Checks_May_Be_Suppressed (E) then
4036 return Is_Check_Suppressed (E, Index_Check);
4038 return Scope_Suppress (Index_Check);
4040 end Index_Checks_Suppressed;
4046 procedure Initialize is
4048 for J in Determine_Range_Cache_N'Range loop
4049 Determine_Range_Cache_N (J) := Empty;
4053 -------------------------
4054 -- Insert_Range_Checks --
4055 -------------------------
4057 procedure Insert_Range_Checks
4058 (Checks : Check_Result;
4060 Suppress_Typ : Entity_Id;
4061 Static_Sloc : Source_Ptr := No_Location;
4062 Flag_Node : Node_Id := Empty;
4063 Do_Before : Boolean := False)
4065 Internal_Flag_Node : Node_Id := Flag_Node;
4066 Internal_Static_Sloc : Source_Ptr := Static_Sloc;
4068 Check_Node : Node_Id;
4069 Checks_On : constant Boolean :=
4070 (not Index_Checks_Suppressed (Suppress_Typ))
4072 (not Range_Checks_Suppressed (Suppress_Typ));
4075 -- For now we just return if Checks_On is false, however this should
4076 -- be enhanced to check for an always True value in the condition
4077 -- and to generate a compilation warning???
4079 if not Expander_Active or else not Checks_On then
4083 if Static_Sloc = No_Location then
4084 Internal_Static_Sloc := Sloc (Node);
4087 if No (Flag_Node) then
4088 Internal_Flag_Node := Node;
4091 for J in 1 .. 2 loop
4092 exit when No (Checks (J));
4094 if Nkind (Checks (J)) = N_Raise_Constraint_Error
4095 and then Present (Condition (Checks (J)))
4097 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
4098 Check_Node := Checks (J);
4099 Mark_Rewrite_Insertion (Check_Node);
4102 Insert_Before_And_Analyze (Node, Check_Node);
4104 Insert_After_And_Analyze (Node, Check_Node);
4107 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
4112 Make_Raise_Constraint_Error (Internal_Static_Sloc,
4113 Reason => CE_Range_Check_Failed);
4114 Mark_Rewrite_Insertion (Check_Node);
4117 Insert_Before_And_Analyze (Node, Check_Node);
4119 Insert_After_And_Analyze (Node, Check_Node);
4123 end Insert_Range_Checks;
4125 ------------------------
4126 -- Insert_Valid_Check --
4127 ------------------------
4129 procedure Insert_Valid_Check (Expr : Node_Id) is
4130 Loc : constant Source_Ptr := Sloc (Expr);
4134 -- Do not insert if checks off, or if not checking validity
4136 if Range_Checks_Suppressed (Etype (Expr))
4137 or else (not Validity_Checks_On)
4142 -- If we have a checked conversion, then validity check applies to
4143 -- the expression inside the conversion, not the result, since if
4144 -- the expression inside is valid, then so is the conversion result.
4147 while Nkind (Exp) = N_Type_Conversion loop
4148 Exp := Expression (Exp);
4151 -- Insert the validity check. Note that we do this with validity
4152 -- checks turned off, to avoid recursion, we do not want validity
4153 -- checks on the validity checking code itself!
4155 Validity_Checks_On := False;
4158 Make_Raise_Constraint_Error (Loc,
4162 Make_Attribute_Reference (Loc,
4164 Duplicate_Subexpr_No_Checks (Exp, Name_Req => True),
4165 Attribute_Name => Name_Valid)),
4166 Reason => CE_Invalid_Data),
4167 Suppress => All_Checks);
4168 Validity_Checks_On := True;
4169 end Insert_Valid_Check;
4171 --------------------------
4172 -- Install_Static_Check --
4173 --------------------------
4175 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
4176 Stat : constant Boolean := Is_Static_Expression (R_Cno);
4177 Typ : constant Entity_Id := Etype (R_Cno);
4181 Make_Raise_Constraint_Error (Loc,
4182 Reason => CE_Range_Check_Failed));
4183 Set_Analyzed (R_Cno);
4184 Set_Etype (R_Cno, Typ);
4185 Set_Raises_Constraint_Error (R_Cno);
4186 Set_Is_Static_Expression (R_Cno, Stat);
4187 end Install_Static_Check;
4189 ---------------------
4190 -- Kill_All_Checks --
4191 ---------------------
4193 procedure Kill_All_Checks is
4195 if Debug_Flag_CC then
4196 w ("Kill_All_Checks");
4199 -- We reset the number of saved checks to zero, and also modify
4200 -- all stack entries for statement ranges to indicate that the
4201 -- number of checks at each level is now zero.
4203 Num_Saved_Checks := 0;
4205 for J in 1 .. Saved_Checks_TOS loop
4206 Saved_Checks_Stack (J) := 0;
4208 end Kill_All_Checks;
4214 procedure Kill_Checks (V : Entity_Id) is
4216 if Debug_Flag_CC then
4217 w ("Kill_Checks for entity", Int (V));
4220 for J in 1 .. Num_Saved_Checks loop
4221 if Saved_Checks (J).Entity = V then
4222 if Debug_Flag_CC then
4223 w (" Checks killed for saved check ", J);
4226 Saved_Checks (J).Killed := True;
4231 ------------------------------
4232 -- Length_Checks_Suppressed --
4233 ------------------------------
4235 function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
4237 if Present (E) and then Checks_May_Be_Suppressed (E) then
4238 return Is_Check_Suppressed (E, Length_Check);
4240 return Scope_Suppress (Length_Check);
4242 end Length_Checks_Suppressed;
4244 --------------------------------
4245 -- Overflow_Checks_Suppressed --
4246 --------------------------------
4248 function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
4250 if Present (E) and then Checks_May_Be_Suppressed (E) then
4251 return Is_Check_Suppressed (E, Overflow_Check);
4253 return Scope_Suppress (Overflow_Check);
4255 end Overflow_Checks_Suppressed;
4261 function Range_Check
4263 Target_Typ : Entity_Id;
4264 Source_Typ : Entity_Id := Empty;
4265 Warn_Node : Node_Id := Empty)
4269 return Selected_Range_Checks
4270 (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
4273 -----------------------------
4274 -- Range_Checks_Suppressed --
4275 -----------------------------
4277 function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
4281 -- Note: for now we always suppress range checks on Vax float types,
4282 -- since Gigi does not know how to generate these checks.
4284 if Vax_Float (E) then
4286 elsif Kill_Range_Checks (E) then
4288 elsif Checks_May_Be_Suppressed (E) then
4289 return Is_Check_Suppressed (E, Range_Check);
4293 return Scope_Suppress (Range_Check);
4294 end Range_Checks_Suppressed;
4300 procedure Remove_Checks (Expr : Node_Id) is
4301 Discard : Traverse_Result;
4302 pragma Warnings (Off, Discard);
4304 function Process (N : Node_Id) return Traverse_Result;
4305 -- Process a single node during the traversal
4307 function Traverse is new Traverse_Func (Process);
4308 -- The traversal function itself
4314 function Process (N : Node_Id) return Traverse_Result is
4316 if Nkind (N) not in N_Subexpr then
4320 Set_Do_Range_Check (N, False);
4324 Discard := Traverse (Left_Opnd (N));
4327 when N_Attribute_Reference =>
4328 Set_Do_Overflow_Check (N, False);
4330 when N_Function_Call =>
4331 Set_Do_Tag_Check (N, False);
4334 Set_Do_Overflow_Check (N, False);
4338 Set_Do_Division_Check (N, False);
4341 Set_Do_Length_Check (N, False);
4344 Set_Do_Division_Check (N, False);
4347 Set_Do_Length_Check (N, False);
4350 Set_Do_Division_Check (N, False);
4353 Set_Do_Length_Check (N, False);
4360 Discard := Traverse (Left_Opnd (N));
4363 when N_Selected_Component =>
4364 Set_Do_Discriminant_Check (N, False);
4366 when N_Type_Conversion =>
4367 Set_Do_Length_Check (N, False);
4368 Set_Do_Tag_Check (N, False);
4369 Set_Do_Overflow_Check (N, False);
4378 -- Start of processing for Remove_Checks
4381 Discard := Traverse (Expr);
4384 ----------------------------
4385 -- Selected_Length_Checks --
4386 ----------------------------
4388 function Selected_Length_Checks
4390 Target_Typ : Entity_Id;
4391 Source_Typ : Entity_Id;
4392 Warn_Node : Node_Id)
4395 Loc : constant Source_Ptr := Sloc (Ck_Node);
4398 Expr_Actual : Node_Id;
4400 Cond : Node_Id := Empty;
4401 Do_Access : Boolean := False;
4402 Wnode : Node_Id := Warn_Node;
4403 Ret_Result : Check_Result := (Empty, Empty);
4404 Num_Checks : Natural := 0;
4406 procedure Add_Check (N : Node_Id);
4407 -- Adds the action given to Ret_Result if N is non-Empty
4409 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
4410 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
4412 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
4413 -- True for equal literals and for nodes that denote the same constant
4414 -- entity, even if its value is not a static constant. This includes the
4415 -- case of a discriminal reference within an init proc. Removes some
4416 -- obviously superfluous checks.
4418 function Length_E_Cond
4419 (Exptyp : Entity_Id;
4423 -- Returns expression to compute:
4424 -- Typ'Length /= Exptyp'Length
4426 function Length_N_Cond
4431 -- Returns expression to compute:
4432 -- Typ'Length /= Expr'Length
4438 procedure Add_Check (N : Node_Id) is
4442 -- For now, ignore attempt to place more than 2 checks ???
4444 if Num_Checks = 2 then
4448 pragma Assert (Num_Checks <= 1);
4449 Num_Checks := Num_Checks + 1;
4450 Ret_Result (Num_Checks) := N;
4458 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
4459 Pt : constant Entity_Id := Scope (Scope (E));
4461 E1 : Entity_Id := E;
4464 if Ekind (Scope (E)) = E_Record_Type
4465 and then Has_Discriminants (Scope (E))
4467 N := Build_Discriminal_Subtype_Of_Component (E);
4470 Insert_Action (Ck_Node, N);
4471 E1 := Defining_Identifier (N);
4475 if Ekind (E1) = E_String_Literal_Subtype then
4477 Make_Integer_Literal (Loc,
4478 Intval => String_Literal_Length (E1));
4480 elsif Ekind (Pt) = E_Protected_Type
4481 and then Has_Discriminants (Pt)
4482 and then Has_Completion (Pt)
4483 and then not Inside_Init_Proc
4486 -- If the type whose length is needed is a private component
4487 -- constrained by a discriminant, we must expand the 'Length
4488 -- attribute into an explicit computation, using the discriminal
4489 -- of the current protected operation. This is because the actual
4490 -- type of the prival is constructed after the protected opera-
4491 -- tion has been fully expanded.
4494 Indx_Type : Node_Id;
4497 Do_Expand : Boolean := False;
4500 Indx_Type := First_Index (E);
4502 for J in 1 .. Indx - 1 loop
4503 Next_Index (Indx_Type);
4506 Get_Index_Bounds (Indx_Type, Lo, Hi);
4508 if Nkind (Lo) = N_Identifier
4509 and then Ekind (Entity (Lo)) = E_In_Parameter
4511 Lo := Get_Discriminal (E, Lo);
4515 if Nkind (Hi) = N_Identifier
4516 and then Ekind (Entity (Hi)) = E_In_Parameter
4518 Hi := Get_Discriminal (E, Hi);
4523 if not Is_Entity_Name (Lo) then
4524 Lo := Duplicate_Subexpr_No_Checks (Lo);
4527 if not Is_Entity_Name (Hi) then
4528 Lo := Duplicate_Subexpr_No_Checks (Hi);
4534 Make_Op_Subtract (Loc,
4538 Right_Opnd => Make_Integer_Literal (Loc, 1));
4543 Make_Attribute_Reference (Loc,
4544 Attribute_Name => Name_Length,
4546 New_Occurrence_Of (E1, Loc));
4549 Set_Expressions (N, New_List (
4550 Make_Integer_Literal (Loc, Indx)));
4559 Make_Attribute_Reference (Loc,
4560 Attribute_Name => Name_Length,
4562 New_Occurrence_Of (E1, Loc));
4565 Set_Expressions (N, New_List (
4566 Make_Integer_Literal (Loc, Indx)));
4578 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is
4581 Make_Attribute_Reference (Loc,
4582 Attribute_Name => Name_Length,
4584 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
4585 Expressions => New_List (
4586 Make_Integer_Literal (Loc, Indx)));
4594 function Length_E_Cond
4595 (Exptyp : Entity_Id;
4603 Left_Opnd => Get_E_Length (Typ, Indx),
4604 Right_Opnd => Get_E_Length (Exptyp, Indx));
4612 function Length_N_Cond
4621 Left_Opnd => Get_E_Length (Typ, Indx),
4622 Right_Opnd => Get_N_Length (Expr, Indx));
4626 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is
4629 (Nkind (L) = N_Integer_Literal
4630 and then Nkind (R) = N_Integer_Literal
4631 and then Intval (L) = Intval (R))
4635 and then Ekind (Entity (L)) = E_Constant
4636 and then ((Is_Entity_Name (R)
4637 and then Entity (L) = Entity (R))
4639 (Nkind (R) = N_Type_Conversion
4640 and then Is_Entity_Name (Expression (R))
4641 and then Entity (L) = Entity (Expression (R)))))
4645 and then Ekind (Entity (R)) = E_Constant
4646 and then Nkind (L) = N_Type_Conversion
4647 and then Is_Entity_Name (Expression (L))
4648 and then Entity (R) = Entity (Expression (L)))
4652 and then Is_Entity_Name (R)
4653 and then Entity (L) = Entity (R)
4654 and then Ekind (Entity (L)) = E_In_Parameter
4655 and then Inside_Init_Proc);
4658 -- Start of processing for Selected_Length_Checks
4661 if not Expander_Active then
4665 if Target_Typ = Any_Type
4666 or else Target_Typ = Any_Composite
4667 or else Raises_Constraint_Error (Ck_Node)
4676 T_Typ := Target_Typ;
4678 if No (Source_Typ) then
4679 S_Typ := Etype (Ck_Node);
4681 S_Typ := Source_Typ;
4684 if S_Typ = Any_Type or else S_Typ = Any_Composite then
4688 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
4689 S_Typ := Designated_Type (S_Typ);
4690 T_Typ := Designated_Type (T_Typ);
4693 -- A simple optimization
4695 if Nkind (Ck_Node) = N_Null then
4700 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
4701 if Is_Constrained (T_Typ) then
4703 -- The checking code to be generated will freeze the
4704 -- corresponding array type. However, we must freeze the
4705 -- type now, so that the freeze node does not appear within
4706 -- the generated condional expression, but ahead of it.
4708 Freeze_Before (Ck_Node, T_Typ);
4710 Expr_Actual := Get_Referenced_Object (Ck_Node);
4711 Exptyp := Get_Actual_Subtype (Expr_Actual);
4713 if Is_Access_Type (Exptyp) then
4714 Exptyp := Designated_Type (Exptyp);
4717 -- String_Literal case. This needs to be handled specially be-
4718 -- cause no index types are available for string literals. The
4719 -- condition is simply:
4721 -- T_Typ'Length = string-literal-length
4723 if Nkind (Expr_Actual) = N_String_Literal
4724 and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype
4728 Left_Opnd => Get_E_Length (T_Typ, 1),
4730 Make_Integer_Literal (Loc,
4732 String_Literal_Length (Etype (Expr_Actual))));
4734 -- General array case. Here we have a usable actual subtype for
4735 -- the expression, and the condition is built from the two types
4738 -- T_Typ'Length /= Exptyp'Length or else
4739 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
4740 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
4743 elsif Is_Constrained (Exptyp) then
4745 Ndims : constant Nat := Number_Dimensions (T_Typ);
4759 -- At the library level, we need to ensure that the
4760 -- type of the object is elaborated before the check
4761 -- itself is emitted.
4763 if Is_Itype (Exptyp)
4765 Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package
4767 not In_Package_Body (Cunit_Entity (Current_Sem_Unit))
4769 Ref_Node := Make_Itype_Reference (Sloc (Ck_Node));
4770 Set_Itype (Ref_Node, Exptyp);
4771 Insert_Action (Ck_Node, Ref_Node);
4774 L_Index := First_Index (T_Typ);
4775 R_Index := First_Index (Exptyp);
4777 for Indx in 1 .. Ndims loop
4778 if not (Nkind (L_Index) = N_Raise_Constraint_Error
4780 Nkind (R_Index) = N_Raise_Constraint_Error)
4782 Get_Index_Bounds (L_Index, L_Low, L_High);
4783 Get_Index_Bounds (R_Index, R_Low, R_High);
4785 -- Deal with compile time length check. Note that we
4786 -- skip this in the access case, because the access
4787 -- value may be null, so we cannot know statically.
4790 and then Compile_Time_Known_Value (L_Low)
4791 and then Compile_Time_Known_Value (L_High)
4792 and then Compile_Time_Known_Value (R_Low)
4793 and then Compile_Time_Known_Value (R_High)
4795 if Expr_Value (L_High) >= Expr_Value (L_Low) then
4796 L_Length := Expr_Value (L_High) -
4797 Expr_Value (L_Low) + 1;
4799 L_Length := UI_From_Int (0);
4802 if Expr_Value (R_High) >= Expr_Value (R_Low) then
4803 R_Length := Expr_Value (R_High) -
4804 Expr_Value (R_Low) + 1;
4806 R_Length := UI_From_Int (0);
4809 if L_Length > R_Length then
4811 (Compile_Time_Constraint_Error
4812 (Wnode, "too few elements for}?", T_Typ));
4814 elsif L_Length < R_Length then
4816 (Compile_Time_Constraint_Error
4817 (Wnode, "too many elements for}?", T_Typ));
4820 -- The comparison for an individual index subtype
4821 -- is omitted if the corresponding index subtypes
4822 -- statically match, since the result is known to
4823 -- be true. Note that this test is worth while even
4824 -- though we do static evaluation, because non-static
4825 -- subtypes can statically match.
4828 Subtypes_Statically_Match
4829 (Etype (L_Index), Etype (R_Index))
4832 (Same_Bounds (L_Low, R_Low)
4833 and then Same_Bounds (L_High, R_High))
4836 (Cond, Length_E_Cond (Exptyp, T_Typ, Indx));
4845 -- Handle cases where we do not get a usable actual subtype that
4846 -- is constrained. This happens for example in the function call
4847 -- and explicit dereference cases. In these cases, we have to get
4848 -- the length or range from the expression itself, making sure we
4849 -- do not evaluate it more than once.
4851 -- Here Ck_Node is the original expression, or more properly the
4852 -- result of applying Duplicate_Expr to the original tree,
4853 -- forcing the result to be a name.
4857 Ndims : constant Nat := Number_Dimensions (T_Typ);
4860 -- Build the condition for the explicit dereference case
4862 for Indx in 1 .. Ndims loop
4864 (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx));
4871 -- Construct the test and insert into the tree
4873 if Present (Cond) then
4875 Cond := Guard_Access (Cond, Loc, Ck_Node);
4879 (Make_Raise_Constraint_Error (Loc,
4881 Reason => CE_Length_Check_Failed));
4885 end Selected_Length_Checks;
4887 ---------------------------
4888 -- Selected_Range_Checks --
4889 ---------------------------
4891 function Selected_Range_Checks
4893 Target_Typ : Entity_Id;
4894 Source_Typ : Entity_Id;
4895 Warn_Node : Node_Id)
4898 Loc : constant Source_Ptr := Sloc (Ck_Node);
4901 Expr_Actual : Node_Id;
4903 Cond : Node_Id := Empty;
4904 Do_Access : Boolean := False;
4905 Wnode : Node_Id := Warn_Node;
4906 Ret_Result : Check_Result := (Empty, Empty);
4907 Num_Checks : Integer := 0;
4909 procedure Add_Check (N : Node_Id);
4910 -- Adds the action given to Ret_Result if N is non-Empty
4912 function Discrete_Range_Cond
4916 -- Returns expression to compute:
4917 -- Low_Bound (Expr) < Typ'First
4919 -- High_Bound (Expr) > Typ'Last
4921 function Discrete_Expr_Cond
4925 -- Returns expression to compute:
4930 function Get_E_First_Or_Last
4935 -- Returns expression to compute:
4936 -- E'First or E'Last
4938 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
4939 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id;
4940 -- Returns expression to compute:
4941 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
4943 function Range_E_Cond
4944 (Exptyp : Entity_Id;
4948 -- Returns expression to compute:
4949 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
4951 function Range_Equal_E_Cond
4952 (Exptyp : Entity_Id;
4956 -- Returns expression to compute:
4957 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
4959 function Range_N_Cond
4964 -- Return expression to compute:
4965 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
4971 procedure Add_Check (N : Node_Id) is
4975 -- For now, ignore attempt to place more than 2 checks ???
4977 if Num_Checks = 2 then
4981 pragma Assert (Num_Checks <= 1);
4982 Num_Checks := Num_Checks + 1;
4983 Ret_Result (Num_Checks) := N;
4987 -------------------------
4988 -- Discrete_Expr_Cond --
4989 -------------------------
4991 function Discrete_Expr_Cond
5002 Convert_To (Base_Type (Typ),
5003 Duplicate_Subexpr_No_Checks (Expr)),
5005 Convert_To (Base_Type (Typ),
5006 Get_E_First_Or_Last (Typ, 0, Name_First))),
5011 Convert_To (Base_Type (Typ),
5012 Duplicate_Subexpr_No_Checks (Expr)),
5016 Get_E_First_Or_Last (Typ, 0, Name_Last))));
5017 end Discrete_Expr_Cond;
5019 -------------------------
5020 -- Discrete_Range_Cond --
5021 -------------------------
5023 function Discrete_Range_Cond
5028 LB : Node_Id := Low_Bound (Expr);
5029 HB : Node_Id := High_Bound (Expr);
5031 Left_Opnd : Node_Id;
5032 Right_Opnd : Node_Id;
5035 if Nkind (LB) = N_Identifier
5036 and then Ekind (Entity (LB)) = E_Discriminant then
5037 LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
5040 if Nkind (HB) = N_Identifier
5041 and then Ekind (Entity (HB)) = E_Discriminant then
5042 HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
5049 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)),
5053 (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First)));
5055 if Base_Type (Typ) = Typ then
5058 elsif Compile_Time_Known_Value (High_Bound (Scalar_Range (Typ)))
5060 Compile_Time_Known_Value (High_Bound (Scalar_Range
5063 if Is_Floating_Point_Type (Typ) then
5064 if Expr_Value_R (High_Bound (Scalar_Range (Typ))) =
5065 Expr_Value_R (High_Bound (Scalar_Range (Base_Type (Typ))))
5071 if Expr_Value (High_Bound (Scalar_Range (Typ))) =
5072 Expr_Value (High_Bound (Scalar_Range (Base_Type (Typ))))
5083 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)),
5088 Get_E_First_Or_Last (Typ, 0, Name_Last)));
5090 return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
5091 end Discrete_Range_Cond;
5093 -------------------------
5094 -- Get_E_First_Or_Last --
5095 -------------------------
5097 function Get_E_First_Or_Last
5109 if Is_Array_Type (E) then
5110 N := First_Index (E);
5112 for J in 2 .. Indx loop
5117 N := Scalar_Range (E);
5120 if Nkind (N) = N_Subtype_Indication then
5121 LB := Low_Bound (Range_Expression (Constraint (N)));
5122 HB := High_Bound (Range_Expression (Constraint (N)));
5124 elsif Is_Entity_Name (N) then
5125 LB := Type_Low_Bound (Etype (N));
5126 HB := Type_High_Bound (Etype (N));
5129 LB := Low_Bound (N);
5130 HB := High_Bound (N);
5133 if Nam = Name_First then
5139 if Nkind (Bound) = N_Identifier
5140 and then Ekind (Entity (Bound)) = E_Discriminant
5142 -- If this is a task discriminant, and we are the body, we must
5143 -- retrieve the corresponding body discriminal. This is another
5144 -- consequence of the early creation of discriminals, and the
5145 -- need to generate constraint checks before their declarations
5146 -- are made visible.
5148 if Is_Concurrent_Record_Type (Scope (Entity (Bound))) then
5150 Tsk : constant Entity_Id :=
5151 Corresponding_Concurrent_Type
5152 (Scope (Entity (Bound)));
5156 if In_Open_Scopes (Tsk)
5157 and then Has_Completion (Tsk)
5159 -- Find discriminant of original task, and use its
5160 -- current discriminal, which is the renaming within
5163 Disc := First_Discriminant (Tsk);
5164 while Present (Disc) loop
5165 if Chars (Disc) = Chars (Entity (Bound)) then
5166 Set_Scope (Discriminal (Disc), Tsk);
5167 return New_Occurrence_Of (Discriminal (Disc), Loc);
5170 Next_Discriminant (Disc);
5173 -- That loop should always succeed in finding a matching
5174 -- entry and returning. Fatal error if not.
5176 raise Program_Error;
5180 New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
5184 return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
5187 elsif Nkind (Bound) = N_Identifier
5188 and then Ekind (Entity (Bound)) = E_In_Parameter
5189 and then not Inside_Init_Proc
5191 return Get_Discriminal (E, Bound);
5193 elsif Nkind (Bound) = N_Integer_Literal then
5194 return Make_Integer_Literal (Loc, Intval (Bound));
5197 return Duplicate_Subexpr_No_Checks (Bound);
5199 end Get_E_First_Or_Last;
5205 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is
5208 Make_Attribute_Reference (Loc,
5209 Attribute_Name => Name_First,
5211 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
5212 Expressions => New_List (
5213 Make_Integer_Literal (Loc, Indx)));
5221 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is
5224 Make_Attribute_Reference (Loc,
5225 Attribute_Name => Name_Last,
5227 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
5228 Expressions => New_List (
5229 Make_Integer_Literal (Loc, Indx)));
5237 function Range_E_Cond
5238 (Exptyp : Entity_Id;
5248 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
5249 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
5253 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
5254 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
5258 ------------------------
5259 -- Range_Equal_E_Cond --
5260 ------------------------
5262 function Range_Equal_E_Cond
5263 (Exptyp : Entity_Id;
5273 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
5274 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
5277 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
5278 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
5279 end Range_Equal_E_Cond;
5285 function Range_N_Cond
5296 Left_Opnd => Get_N_First (Expr, Indx),
5297 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
5301 Left_Opnd => Get_N_Last (Expr, Indx),
5302 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
5305 -- Start of processing for Selected_Range_Checks
5308 if not Expander_Active then
5312 if Target_Typ = Any_Type
5313 or else Target_Typ = Any_Composite
5314 or else Raises_Constraint_Error (Ck_Node)
5323 T_Typ := Target_Typ;
5325 if No (Source_Typ) then
5326 S_Typ := Etype (Ck_Node);
5328 S_Typ := Source_Typ;
5331 if S_Typ = Any_Type or else S_Typ = Any_Composite then
5335 -- The order of evaluating T_Typ before S_Typ seems to be critical
5336 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
5337 -- in, and since Node can be an N_Range node, it might be invalid.
5338 -- Should there be an assert check somewhere for taking the Etype of
5339 -- an N_Range node ???
5341 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
5342 S_Typ := Designated_Type (S_Typ);
5343 T_Typ := Designated_Type (T_Typ);
5346 -- A simple optimization
5348 if Nkind (Ck_Node) = N_Null then
5353 -- For an N_Range Node, check for a null range and then if not
5354 -- null generate a range check action.
5356 if Nkind (Ck_Node) = N_Range then
5358 -- There's no point in checking a range against itself
5360 if Ck_Node = Scalar_Range (T_Typ) then
5365 T_LB : constant Node_Id := Type_Low_Bound (T_Typ);
5366 T_HB : constant Node_Id := Type_High_Bound (T_Typ);
5367 LB : constant Node_Id := Low_Bound (Ck_Node);
5368 HB : constant Node_Id := High_Bound (Ck_Node);
5369 Null_Range : Boolean;
5371 Out_Of_Range_L : Boolean;
5372 Out_Of_Range_H : Boolean;
5375 -- Check for case where everything is static and we can
5376 -- do the check at compile time. This is skipped if we
5377 -- have an access type, since the access value may be null.
5379 -- ??? This code can be improved since you only need to know
5380 -- that the two respective bounds (LB & T_LB or HB & T_HB)
5381 -- are known at compile time to emit pertinent messages.
5383 if Compile_Time_Known_Value (LB)
5384 and then Compile_Time_Known_Value (HB)
5385 and then Compile_Time_Known_Value (T_LB)
5386 and then Compile_Time_Known_Value (T_HB)
5387 and then not Do_Access
5389 -- Floating-point case
5391 if Is_Floating_Point_Type (S_Typ) then
5392 Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
5394 (Expr_Value_R (LB) < Expr_Value_R (T_LB))
5396 (Expr_Value_R (LB) > Expr_Value_R (T_HB));
5399 (Expr_Value_R (HB) > Expr_Value_R (T_HB))
5401 (Expr_Value_R (HB) < Expr_Value_R (T_LB));
5403 -- Fixed or discrete type case
5406 Null_Range := Expr_Value (HB) < Expr_Value (LB);
5408 (Expr_Value (LB) < Expr_Value (T_LB))
5410 (Expr_Value (LB) > Expr_Value (T_HB));
5413 (Expr_Value (HB) > Expr_Value (T_HB))
5415 (Expr_Value (HB) < Expr_Value (T_LB));
5418 if not Null_Range then
5419 if Out_Of_Range_L then
5420 if No (Warn_Node) then
5422 (Compile_Time_Constraint_Error
5423 (Low_Bound (Ck_Node),
5424 "static value out of range of}?", T_Typ));
5428 (Compile_Time_Constraint_Error
5430 "static range out of bounds of}?", T_Typ));
5434 if Out_Of_Range_H then
5435 if No (Warn_Node) then
5437 (Compile_Time_Constraint_Error
5438 (High_Bound (Ck_Node),
5439 "static value out of range of}?", T_Typ));
5443 (Compile_Time_Constraint_Error
5445 "static range out of bounds of}?", T_Typ));
5453 LB : Node_Id := Low_Bound (Ck_Node);
5454 HB : Node_Id := High_Bound (Ck_Node);
5458 -- If either bound is a discriminant and we are within
5459 -- the record declaration, it is a use of the discriminant
5460 -- in a constraint of a component, and nothing can be
5461 -- checked here. The check will be emitted within the
5462 -- init proc. Before then, the discriminal has no real
5465 if Nkind (LB) = N_Identifier
5466 and then Ekind (Entity (LB)) = E_Discriminant
5468 if Current_Scope = Scope (Entity (LB)) then
5472 New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
5476 if Nkind (HB) = N_Identifier
5477 and then Ekind (Entity (HB)) = E_Discriminant
5479 if Current_Scope = Scope (Entity (HB)) then
5483 New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
5487 Cond := Discrete_Range_Cond (Ck_Node, T_Typ);
5488 Set_Paren_Count (Cond, 1);
5494 Left_Opnd => Duplicate_Subexpr_No_Checks (HB),
5495 Right_Opnd => Duplicate_Subexpr_No_Checks (LB)),
5496 Right_Opnd => Cond);
5502 elsif Is_Scalar_Type (S_Typ) then
5504 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
5505 -- except the above simply sets a flag in the node and lets
5506 -- gigi generate the check base on the Etype of the expression.
5507 -- Sometimes, however we want to do a dynamic check against an
5508 -- arbitrary target type, so we do that here.
5510 if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then
5511 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
5513 -- For literals, we can tell if the constraint error will be
5514 -- raised at compile time, so we never need a dynamic check, but
5515 -- if the exception will be raised, then post the usual warning,
5516 -- and replace the literal with a raise constraint error
5517 -- expression. As usual, skip this for access types
5519 elsif Compile_Time_Known_Value (Ck_Node)
5520 and then not Do_Access
5523 LB : constant Node_Id := Type_Low_Bound (T_Typ);
5524 UB : constant Node_Id := Type_High_Bound (T_Typ);
5526 Out_Of_Range : Boolean;
5527 Static_Bounds : constant Boolean :=
5528 Compile_Time_Known_Value (LB)
5529 and Compile_Time_Known_Value (UB);
5532 -- Following range tests should use Sem_Eval routine ???
5534 if Static_Bounds then
5535 if Is_Floating_Point_Type (S_Typ) then
5537 (Expr_Value_R (Ck_Node) < Expr_Value_R (LB))
5539 (Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
5541 else -- fixed or discrete type
5543 Expr_Value (Ck_Node) < Expr_Value (LB)
5545 Expr_Value (Ck_Node) > Expr_Value (UB);
5548 -- Bounds of the type are static and the literal is
5549 -- out of range so make a warning message.
5551 if Out_Of_Range then
5552 if No (Warn_Node) then
5554 (Compile_Time_Constraint_Error
5556 "static value out of range of}?", T_Typ));
5560 (Compile_Time_Constraint_Error
5562 "static value out of range of}?", T_Typ));
5567 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
5571 -- Here for the case of a non-static expression, we need a runtime
5572 -- check unless the source type range is guaranteed to be in the
5573 -- range of the target type.
5576 if not In_Subrange_Of (S_Typ, T_Typ) then
5577 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
5582 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
5583 if Is_Constrained (T_Typ) then
5585 Expr_Actual := Get_Referenced_Object (Ck_Node);
5586 Exptyp := Get_Actual_Subtype (Expr_Actual);
5588 if Is_Access_Type (Exptyp) then
5589 Exptyp := Designated_Type (Exptyp);
5592 -- String_Literal case. This needs to be handled specially be-
5593 -- cause no index types are available for string literals. The
5594 -- condition is simply:
5596 -- T_Typ'Length = string-literal-length
5598 if Nkind (Expr_Actual) = N_String_Literal then
5601 -- General array case. Here we have a usable actual subtype for
5602 -- the expression, and the condition is built from the two types
5604 -- T_Typ'First < Exptyp'First or else
5605 -- T_Typ'Last > Exptyp'Last or else
5606 -- T_Typ'First(1) < Exptyp'First(1) or else
5607 -- T_Typ'Last(1) > Exptyp'Last(1) or else
5610 elsif Is_Constrained (Exptyp) then
5612 Ndims : constant Nat := Number_Dimensions (T_Typ);
5622 L_Index := First_Index (T_Typ);
5623 R_Index := First_Index (Exptyp);
5625 for Indx in 1 .. Ndims loop
5626 if not (Nkind (L_Index) = N_Raise_Constraint_Error
5628 Nkind (R_Index) = N_Raise_Constraint_Error)
5630 Get_Index_Bounds (L_Index, L_Low, L_High);
5631 Get_Index_Bounds (R_Index, R_Low, R_High);
5633 -- Deal with compile time length check. Note that we
5634 -- skip this in the access case, because the access
5635 -- value may be null, so we cannot know statically.
5638 Subtypes_Statically_Match
5639 (Etype (L_Index), Etype (R_Index))
5641 -- If the target type is constrained then we
5642 -- have to check for exact equality of bounds
5643 -- (required for qualified expressions).
5645 if Is_Constrained (T_Typ) then
5648 Range_Equal_E_Cond (Exptyp, T_Typ, Indx));
5652 (Cond, Range_E_Cond (Exptyp, T_Typ, Indx));
5663 -- Handle cases where we do not get a usable actual subtype that
5664 -- is constrained. This happens for example in the function call
5665 -- and explicit dereference cases. In these cases, we have to get
5666 -- the length or range from the expression itself, making sure we
5667 -- do not evaluate it more than once.
5669 -- Here Ck_Node is the original expression, or more properly the
5670 -- result of applying Duplicate_Expr to the original tree,
5671 -- forcing the result to be a name.
5675 Ndims : constant Nat := Number_Dimensions (T_Typ);
5678 -- Build the condition for the explicit dereference case
5680 for Indx in 1 .. Ndims loop
5682 (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
5689 -- Generate an Action to check that the bounds of the
5690 -- source value are within the constraints imposed by the
5691 -- target type for a conversion to an unconstrained type.
5694 if Nkind (Parent (Ck_Node)) = N_Type_Conversion then
5696 Opnd_Index : Node_Id;
5697 Targ_Index : Node_Id;
5701 := First_Index (Get_Actual_Subtype (Ck_Node));
5702 Targ_Index := First_Index (T_Typ);
5704 while Opnd_Index /= Empty loop
5705 if Nkind (Opnd_Index) = N_Range then
5707 (Low_Bound (Opnd_Index), Etype (Targ_Index))
5710 (High_Bound (Opnd_Index), Etype (Targ_Index))
5714 -- If null range, no check needed.
5716 Compile_Time_Known_Value (High_Bound (Opnd_Index))
5718 Compile_Time_Known_Value (Low_Bound (Opnd_Index))
5720 Expr_Value (High_Bound (Opnd_Index)) <
5721 Expr_Value (Low_Bound (Opnd_Index))
5725 elsif Is_Out_Of_Range
5726 (Low_Bound (Opnd_Index), Etype (Targ_Index))
5729 (High_Bound (Opnd_Index), Etype (Targ_Index))
5732 (Compile_Time_Constraint_Error
5733 (Wnode, "value out of range of}?", T_Typ));
5739 (Opnd_Index, Etype (Targ_Index)));
5743 Next_Index (Opnd_Index);
5744 Next_Index (Targ_Index);
5751 -- Construct the test and insert into the tree
5753 if Present (Cond) then
5755 Cond := Guard_Access (Cond, Loc, Ck_Node);
5759 (Make_Raise_Constraint_Error (Loc,
5761 Reason => CE_Range_Check_Failed));
5765 end Selected_Range_Checks;
5767 -------------------------------
5768 -- Storage_Checks_Suppressed --
5769 -------------------------------
5771 function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is
5773 if Present (E) and then Checks_May_Be_Suppressed (E) then
5774 return Is_Check_Suppressed (E, Storage_Check);
5776 return Scope_Suppress (Storage_Check);
5778 end Storage_Checks_Suppressed;
5780 ---------------------------
5781 -- Tag_Checks_Suppressed --
5782 ---------------------------
5784 function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
5787 if Kill_Tag_Checks (E) then
5789 elsif Checks_May_Be_Suppressed (E) then
5790 return Is_Check_Suppressed (E, Tag_Check);
5794 return Scope_Suppress (Tag_Check);
5795 end Tag_Checks_Suppressed;