1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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 Eval_Fat; use Eval_Fat;
35 with Freeze; use Freeze;
37 with Nlists; use Nlists;
38 with Nmake; use Nmake;
40 with Output; use Output;
41 with Restrict; use Restrict;
42 with Rident; use Rident;
43 with Rtsfind; use Rtsfind;
45 with Sem_Eval; use Sem_Eval;
46 with Sem_Ch3; use Sem_Ch3;
47 with Sem_Ch8; use Sem_Ch8;
48 with Sem_Res; use Sem_Res;
49 with Sem_Util; use Sem_Util;
50 with Sem_Warn; use Sem_Warn;
51 with Sinfo; use Sinfo;
52 with Sinput; use Sinput;
53 with Snames; use Snames;
54 with Sprint; use Sprint;
55 with Stand; use Stand;
56 with Targparm; use Targparm;
57 with Tbuild; use Tbuild;
58 with Ttypes; use Ttypes;
59 with Urealp; use Urealp;
60 with Validsw; use Validsw;
62 package body Checks is
64 -- General note: many of these routines are concerned with generating
65 -- checking code to make sure that constraint error is raised at runtime.
66 -- Clearly this code is only needed if the expander is active, since
67 -- otherwise we will not be generating code or going into the runtime
70 -- We therefore disconnect most of these checks if the expander is
71 -- inactive. This has the additional benefit that we do not need to
72 -- worry about the tree being messed up by previous errors (since errors
73 -- turn off expansion anyway).
75 -- There are a few exceptions to the above rule. For instance routines
76 -- such as Apply_Scalar_Range_Check that do not insert any code can be
77 -- safely called even when the Expander is inactive (but Errors_Detected
78 -- is 0). The benefit of executing this code when expansion is off, is
79 -- the ability to emit constraint error warning for static expressions
80 -- even when we are not generating code.
82 -------------------------------------
83 -- Suppression of Redundant Checks --
84 -------------------------------------
86 -- This unit implements a limited circuit for removal of redundant
87 -- checks. The processing is based on a tracing of simple sequential
88 -- flow. For any sequence of statements, we save expressions that are
89 -- marked to be checked, and then if the same expression appears later
90 -- with the same check, then under certain circumstances, the second
91 -- check can be suppressed.
93 -- Basically, we can suppress the check if we know for certain that
94 -- the previous expression has been elaborated (together with its
95 -- check), and we know that the exception frame is the same, and that
96 -- nothing has happened to change the result of the exception.
98 -- Let us examine each of these three conditions in turn to describe
99 -- how we ensure that this condition is met.
101 -- First, we need to know for certain that the previous expression has
102 -- been executed. This is done principly by the mechanism of calling
103 -- Conditional_Statements_Begin at the start of any statement sequence
104 -- and Conditional_Statements_End at the end. The End call causes all
105 -- checks remembered since the Begin call to be discarded. This does
106 -- miss a few cases, notably the case of a nested BEGIN-END block with
107 -- no exception handlers. But the important thing is to be conservative.
108 -- The other protection is that all checks are discarded if a label
109 -- is encountered, since then the assumption of sequential execution
110 -- is violated, and we don't know enough about the flow.
112 -- Second, we need to know that the exception frame is the same. We
113 -- do this by killing all remembered checks when we enter a new frame.
114 -- Again, that's over-conservative, but generally the cases we can help
115 -- with are pretty local anyway (like the body of a loop for example).
117 -- Third, we must be sure to forget any checks which are no longer valid.
118 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
119 -- used to note any changes to local variables. We only attempt to deal
120 -- with checks involving local variables, so we do not need to worry
121 -- about global variables. Second, a call to any non-global procedure
122 -- causes us to abandon all stored checks, since such a all may affect
123 -- the values of any local variables.
125 -- The following define the data structures used to deal with remembering
126 -- checks so that redundant checks can be eliminated as described above.
128 -- Right now, the only expressions that we deal with are of the form of
129 -- simple local objects (either declared locally, or IN parameters) or
130 -- such objects plus/minus a compile time known constant. We can do
131 -- more later on if it seems worthwhile, but this catches many simple
132 -- cases in practice.
134 -- The following record type reflects a single saved check. An entry
135 -- is made in the stack of saved checks if and only if the expression
136 -- has been elaborated with the indicated checks.
138 type Saved_Check is record
140 -- Set True if entry is killed by Kill_Checks
143 -- The entity involved in the expression that is checked
146 -- A compile time value indicating the result of adding or
147 -- subtracting a compile time value. This value is to be
148 -- added to the value of the Entity. A value of zero is
149 -- used for the case of a simple entity reference.
151 Check_Type : Character;
152 -- This is set to 'R' for a range check (in which case Target_Type
153 -- is set to the target type for the range check) or to 'O' for an
154 -- overflow check (in which case Target_Type is set to Empty).
156 Target_Type : Entity_Id;
157 -- Used only if Do_Range_Check is set. Records the target type for
158 -- the check. We need this, because a check is a duplicate only if
159 -- it has a the same target type (or more accurately one with a
160 -- range that is smaller or equal to the stored target type of a
164 -- The following table keeps track of saved checks. Rather than use an
165 -- extensible table. We just use a table of fixed size, and we discard
166 -- any saved checks that do not fit. That's very unlikely to happen and
167 -- this is only an optimization in any case.
169 Saved_Checks : array (Int range 1 .. 200) of Saved_Check;
170 -- Array of saved checks
172 Num_Saved_Checks : Nat := 0;
173 -- Number of saved checks
175 -- The following stack keeps track of statement ranges. It is treated
176 -- as a stack. When Conditional_Statements_Begin is called, an entry
177 -- is pushed onto this stack containing the value of Num_Saved_Checks
178 -- at the time of the call. Then when Conditional_Statements_End is
179 -- called, this value is popped off and used to reset Num_Saved_Checks.
181 -- Note: again, this is a fixed length stack with a size that should
182 -- always be fine. If the value of the stack pointer goes above the
183 -- limit, then we just forget all saved checks.
185 Saved_Checks_Stack : array (Int range 1 .. 100) of Nat;
186 Saved_Checks_TOS : Nat := 0;
188 -----------------------
189 -- Local Subprograms --
190 -----------------------
192 procedure Apply_Float_Conversion_Check
194 Target_Typ : Entity_Id);
195 -- The checks on a conversion from a floating-point type to an integer
196 -- type are delicate. They have to be performed before conversion, they
197 -- have to raise an exception when the operand is a NaN, and rounding must
198 -- be taken into account to determine the safe bounds of the operand.
200 procedure Apply_Selected_Length_Checks
202 Target_Typ : Entity_Id;
203 Source_Typ : Entity_Id;
204 Do_Static : Boolean);
205 -- This is the subprogram that does all the work for Apply_Length_Check
206 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
207 -- described for the above routines. The Do_Static flag indicates that
208 -- only a static check is to be done.
210 procedure Apply_Selected_Range_Checks
212 Target_Typ : Entity_Id;
213 Source_Typ : Entity_Id;
214 Do_Static : Boolean);
215 -- This is the subprogram that does all the work for Apply_Range_Check.
216 -- Expr, Target_Typ and Source_Typ are as described for the above
217 -- routine. The Do_Static flag indicates that only a static check is
222 Check_Type : Character;
223 Target_Type : Entity_Id;
224 Entry_OK : out Boolean;
228 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
229 -- to see if a check is of the form for optimization, and if so, to see
230 -- if it has already been performed. Expr is the expression to check,
231 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
232 -- Target_Type is the target type for a range check, and Empty for an
233 -- overflow check. If the entry is not of the form for optimization,
234 -- then Entry_OK is set to False, and the remaining out parameters
235 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
236 -- entity and offset from the expression. Check_Num is the number of
237 -- a matching saved entry in Saved_Checks, or zero if no such entry
240 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id;
241 -- If a discriminal is used in constraining a prival, Return reference
242 -- to the discriminal of the protected body (which renames the parameter
243 -- of the enclosing protected operation). This clumsy transformation is
244 -- needed because privals are created too late and their actual subtypes
245 -- are not available when analysing the bodies of the protected operations.
246 -- To be cleaned up???
248 function Guard_Access
251 Ck_Node : Node_Id) return Node_Id;
252 -- In the access type case, guard the test with a test to ensure
253 -- that the access value is non-null, since the checks do not
254 -- not apply to null access values.
256 procedure Install_Null_Excluding_Check (N : Node_Id);
257 -- Determines whether an access node requires a runtime access check and
258 -- if so inserts the appropriate run-time check
260 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);
261 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
262 -- Constraint_Error node.
264 function Selected_Length_Checks
266 Target_Typ : Entity_Id;
267 Source_Typ : Entity_Id;
268 Warn_Node : Node_Id) return Check_Result;
269 -- Like Apply_Selected_Length_Checks, except it doesn't modify
270 -- anything, just returns a list of nodes as described in the spec of
271 -- this package for the Range_Check function.
273 function Selected_Range_Checks
275 Target_Typ : Entity_Id;
276 Source_Typ : Entity_Id;
277 Warn_Node : Node_Id) return Check_Result;
278 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
279 -- just returns a list of nodes as described in the spec of this package
280 -- for the Range_Check function.
282 ------------------------------
283 -- Access_Checks_Suppressed --
284 ------------------------------
286 function Access_Checks_Suppressed (E : Entity_Id) return Boolean is
288 if Present (E) and then Checks_May_Be_Suppressed (E) then
289 return Is_Check_Suppressed (E, Access_Check);
291 return Scope_Suppress (Access_Check);
293 end Access_Checks_Suppressed;
295 -------------------------------------
296 -- Accessibility_Checks_Suppressed --
297 -------------------------------------
299 function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
301 if Present (E) and then Checks_May_Be_Suppressed (E) then
302 return Is_Check_Suppressed (E, Accessibility_Check);
304 return Scope_Suppress (Accessibility_Check);
306 end Accessibility_Checks_Suppressed;
308 -------------------------
309 -- Append_Range_Checks --
310 -------------------------
312 procedure Append_Range_Checks
313 (Checks : Check_Result;
315 Suppress_Typ : Entity_Id;
316 Static_Sloc : Source_Ptr;
319 Internal_Flag_Node : constant Node_Id := Flag_Node;
320 Internal_Static_Sloc : constant Source_Ptr := Static_Sloc;
322 Checks_On : constant Boolean :=
323 (not Index_Checks_Suppressed (Suppress_Typ))
325 (not Range_Checks_Suppressed (Suppress_Typ));
328 -- For now we just return if Checks_On is false, however this should
329 -- be enhanced to check for an always True value in the condition
330 -- and to generate a compilation warning???
332 if not Checks_On then
337 exit when No (Checks (J));
339 if Nkind (Checks (J)) = N_Raise_Constraint_Error
340 and then Present (Condition (Checks (J)))
342 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
343 Append_To (Stmts, Checks (J));
344 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
350 Make_Raise_Constraint_Error (Internal_Static_Sloc,
351 Reason => CE_Range_Check_Failed));
354 end Append_Range_Checks;
356 ------------------------
357 -- Apply_Access_Check --
358 ------------------------
360 procedure Apply_Access_Check (N : Node_Id) is
361 P : constant Node_Id := Prefix (N);
364 if Inside_A_Generic then
368 if Is_Entity_Name (P) then
369 Check_Unset_Reference (P);
372 -- We do not need access checks if prefix is known to be non-null
374 if Known_Non_Null (P) then
377 -- We do not need access checks if they are suppressed on the type
379 elsif Access_Checks_Suppressed (Etype (P)) then
382 -- We do not need checks if we are not generating code (i.e. the
383 -- expander is not active). This is not just an optimization, there
384 -- are cases (e.g. with pragma Debug) where generating the checks
385 -- can cause real trouble).
387 elsif not Expander_Active then
391 -- Case where P is an entity name
393 if Is_Entity_Name (P) then
395 Ent : constant Entity_Id := Entity (P);
398 if Access_Checks_Suppressed (Ent) then
402 -- Otherwise we are going to generate an access check, and
403 -- are we have done it, the entity will now be known non null
404 -- But we have to check for safe sequential semantics here!
406 if Safe_To_Capture_Value (N, Ent) then
407 Set_Is_Known_Non_Null (Ent);
412 -- Access check is required
414 Install_Null_Excluding_Check (P);
415 end Apply_Access_Check;
417 -------------------------------
418 -- Apply_Accessibility_Check --
419 -------------------------------
421 procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id) is
422 Loc : constant Source_Ptr := Sloc (N);
423 Param_Ent : constant Entity_Id := Param_Entity (N);
424 Param_Level : Node_Id;
425 Type_Level : Node_Id;
428 if Inside_A_Generic then
431 -- Only apply the run-time check if the access parameter
432 -- has an associated extra access level parameter and
433 -- when the level of the type is less deep than the level
434 -- of the access parameter.
436 elsif Present (Param_Ent)
437 and then Present (Extra_Accessibility (Param_Ent))
438 and then UI_Gt (Object_Access_Level (N),
439 Type_Access_Level (Typ))
440 and then not Accessibility_Checks_Suppressed (Param_Ent)
441 and then not Accessibility_Checks_Suppressed (Typ)
444 New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
447 Make_Integer_Literal (Loc, Type_Access_Level (Typ));
449 -- Raise Program_Error if the accessibility level of the
450 -- the access parameter is deeper than the level of the
451 -- target access type.
454 Make_Raise_Program_Error (Loc,
457 Left_Opnd => Param_Level,
458 Right_Opnd => Type_Level),
459 Reason => PE_Accessibility_Check_Failed));
461 Analyze_And_Resolve (N);
463 end Apply_Accessibility_Check;
465 ---------------------------
466 -- Apply_Alignment_Check --
467 ---------------------------
469 procedure Apply_Alignment_Check (E : Entity_Id; N : Node_Id) is
470 AC : constant Node_Id := Address_Clause (E);
474 Alignment_Required : constant Boolean := Maximum_Alignment > 1;
475 -- Constant to show whether target requires alignment checks
478 -- See if check needed. Note that we never need a check if the
479 -- maximum alignment is one, since the check will always succeed
482 or else not Check_Address_Alignment (AC)
483 or else not Alignment_Required
489 Expr := Expression (AC);
491 if Nkind (Expr) = N_Unchecked_Type_Conversion then
492 Expr := Expression (Expr);
494 elsif Nkind (Expr) = N_Function_Call
495 and then Is_Entity_Name (Name (Expr))
496 and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
498 Expr := First (Parameter_Associations (Expr));
500 if Nkind (Expr) = N_Parameter_Association then
501 Expr := Explicit_Actual_Parameter (Expr);
505 -- Here Expr is the address value. See if we know that the
506 -- value is unacceptable at compile time.
508 if Compile_Time_Known_Value (Expr)
509 and then Known_Alignment (E)
511 if Expr_Value (Expr) mod Alignment (E) /= 0 then
513 Make_Raise_Program_Error (Loc,
514 Reason => PE_Misaligned_Address_Value));
516 ("?specified address for& not " &
517 "consistent with alignment ('R'M 13.3(27))", Expr, E);
520 -- Here we do not know if the value is acceptable, generate
521 -- code to raise PE if alignment is inappropriate.
524 -- Skip generation of this code if we don't want elab code
526 if not Restriction_Active (No_Elaboration_Code) then
527 Insert_After_And_Analyze (N,
528 Make_Raise_Program_Error (Loc,
535 (RTE (RE_Integer_Address),
536 Duplicate_Subexpr_No_Checks (Expr)),
538 Make_Attribute_Reference (Loc,
539 Prefix => New_Occurrence_Of (E, Loc),
540 Attribute_Name => Name_Alignment)),
541 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
542 Reason => PE_Misaligned_Address_Value),
543 Suppress => All_Checks);
550 when RE_Not_Available =>
552 end Apply_Alignment_Check;
554 -------------------------------------
555 -- Apply_Arithmetic_Overflow_Check --
556 -------------------------------------
558 -- This routine is called only if the type is an integer type, and
559 -- a software arithmetic overflow check must be performed for op
560 -- (add, subtract, multiply). The check is performed only if
561 -- Software_Overflow_Checking is enabled and Do_Overflow_Check
562 -- is set. In this case we expand the operation into a more complex
563 -- sequence of tests that ensures that overflow is properly caught.
565 procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
566 Loc : constant Source_Ptr := Sloc (N);
567 Typ : constant Entity_Id := Etype (N);
568 Rtyp : constant Entity_Id := Root_Type (Typ);
569 Siz : constant Int := UI_To_Int (Esize (Rtyp));
570 Dsiz : constant Int := Siz * 2;
577 -- Skip this if overflow checks are done in back end, or the overflow
578 -- flag is not set anyway, or we are not doing code expansion.
580 if Backend_Overflow_Checks_On_Target
581 or else not Do_Overflow_Check (N)
582 or else not Expander_Active
587 -- Otherwise, we generate the full general code for front end overflow
588 -- detection, which works by doing arithmetic in a larger type:
594 -- Typ (Checktyp (x) op Checktyp (y));
596 -- where Typ is the type of the original expression, and Checktyp is
597 -- an integer type of sufficient length to hold the largest possible
600 -- In the case where check type exceeds the size of Long_Long_Integer,
601 -- we use a different approach, expanding to:
603 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
605 -- where xxx is Add, Multiply or Subtract as appropriate
607 -- Find check type if one exists
609 if Dsiz <= Standard_Integer_Size then
610 Ctyp := Standard_Integer;
612 elsif Dsiz <= Standard_Long_Long_Integer_Size then
613 Ctyp := Standard_Long_Long_Integer;
615 -- No check type exists, use runtime call
618 if Nkind (N) = N_Op_Add then
619 Cent := RE_Add_With_Ovflo_Check;
621 elsif Nkind (N) = N_Op_Multiply then
622 Cent := RE_Multiply_With_Ovflo_Check;
625 pragma Assert (Nkind (N) = N_Op_Subtract);
626 Cent := RE_Subtract_With_Ovflo_Check;
631 Make_Function_Call (Loc,
632 Name => New_Reference_To (RTE (Cent), Loc),
633 Parameter_Associations => New_List (
634 OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)),
635 OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
637 Analyze_And_Resolve (N, Typ);
641 -- If we fall through, we have the case where we do the arithmetic in
642 -- the next higher type and get the check by conversion. In these cases
643 -- Ctyp is set to the type to be used as the check type.
645 Opnod := Relocate_Node (N);
647 Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
650 Set_Etype (Opnd, Ctyp);
651 Set_Analyzed (Opnd, True);
652 Set_Left_Opnd (Opnod, Opnd);
654 Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
657 Set_Etype (Opnd, Ctyp);
658 Set_Analyzed (Opnd, True);
659 Set_Right_Opnd (Opnod, Opnd);
661 -- The type of the operation changes to the base type of the check
662 -- type, and we reset the overflow check indication, since clearly
663 -- no overflow is possible now that we are using a double length
664 -- type. We also set the Analyzed flag to avoid a recursive attempt
665 -- to expand the node.
667 Set_Etype (Opnod, Base_Type (Ctyp));
668 Set_Do_Overflow_Check (Opnod, False);
669 Set_Analyzed (Opnod, True);
671 -- Now build the outer conversion
673 Opnd := OK_Convert_To (Typ, Opnod);
675 Set_Etype (Opnd, Typ);
677 -- In the discrete type case, we directly generate the range check
678 -- for the outer operand. This range check will implement the required
681 if Is_Discrete_Type (Typ) then
683 Generate_Range_Check (Expression (N), Typ, CE_Overflow_Check_Failed);
685 -- For other types, we enable overflow checking on the conversion,
686 -- after setting the node as analyzed to prevent recursive attempts
687 -- to expand the conversion node.
690 Set_Analyzed (Opnd, True);
691 Enable_Overflow_Check (Opnd);
696 when RE_Not_Available =>
698 end Apply_Arithmetic_Overflow_Check;
700 ----------------------------
701 -- Apply_Array_Size_Check --
702 ----------------------------
704 -- Note: Really of course this entre check should be in the backend,
705 -- and perhaps this is not quite the right value, but it is good
706 -- enough to catch the normal cases (and the relevant ACVC tests!)
708 -- The situation is as follows. In GNAT 3 (GCC 2.x), the size in bits
709 -- is computed in 32 bits without an overflow check. That's a real
710 -- problem for Ada. So what we do in GNAT 3 is to approximate the
711 -- size of an array by manually multiplying the element size by the
712 -- number of elements, and comparing that against the allowed limits.
714 -- In GNAT 5, the size in byte is still computed in 32 bits without
715 -- an overflow check in the dynamic case, but the size in bits is
716 -- computed in 64 bits. We assume that's good enough, so we use the
717 -- size in bits for the test.
719 procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is
720 Loc : constant Source_Ptr := Sloc (N);
721 Ctyp : constant Entity_Id := Component_Type (Typ);
722 Ent : constant Entity_Id := Defining_Identifier (N);
734 Static : Boolean := True;
735 -- Set false if any index subtye bound is non-static
737 Umark : constant Uintp.Save_Mark := Uintp.Mark;
738 -- We can throw away all the Uint computations here, since they are
739 -- done only to generate boolean test results.
742 -- Size to check against
744 function Is_Address_Or_Import (Decl : Node_Id) return Boolean;
745 -- Determines if Decl is an address clause or Import/Interface pragma
746 -- that references the defining identifier of the current declaration.
748 --------------------------
749 -- Is_Address_Or_Import --
750 --------------------------
752 function Is_Address_Or_Import (Decl : Node_Id) return Boolean is
754 if Nkind (Decl) = N_At_Clause then
755 return Chars (Identifier (Decl)) = Chars (Ent);
757 elsif Nkind (Decl) = N_Attribute_Definition_Clause then
759 Chars (Decl) = Name_Address
761 Nkind (Name (Decl)) = N_Identifier
763 Chars (Name (Decl)) = Chars (Ent);
765 elsif Nkind (Decl) = N_Pragma then
766 if (Chars (Decl) = Name_Import
768 Chars (Decl) = Name_Interface)
769 and then Present (Pragma_Argument_Associations (Decl))
772 F : constant Node_Id :=
773 First (Pragma_Argument_Associations (Decl));
781 Nkind (Expression (Next (F))) = N_Identifier
783 Chars (Expression (Next (F))) = Chars (Ent);
793 end Is_Address_Or_Import;
795 -- Start of processing for Apply_Array_Size_Check
798 -- No need for a check if not expanding
800 if not Expander_Active then
804 -- No need for a check if checks are suppressed
806 if Storage_Checks_Suppressed (Typ) then
810 -- It is pointless to insert this check inside an init proc, because
811 -- that's too late, we have already built the object to be the right
812 -- size, and if it's too large, too bad!
814 if Inside_Init_Proc then
818 -- Look head for pragma interface/import or address clause applying
819 -- to this entity. If found, we suppress the check entirely. For now
820 -- we only look ahead 20 declarations to stop this becoming too slow
821 -- Note that eventually this whole routine gets moved to gigi.
824 for Ctr in 1 .. 20 loop
828 if Is_Address_Or_Import (Decl) then
835 if Opt.GCC_Version = 3 then
837 -- No problem if size is known at compile time (even if the front
838 -- end does not know it) because the back end does do overflow
839 -- checking on the size in bytes if it is compile time known.
841 if Size_Known_At_Compile_Time (Typ) then
846 -- Following code is temporarily deleted, since GCC 3 is returning
847 -- zero for size in bits of large dynamic arrays. ???
849 -- -- Otherwise we check for the size in bits exceeding 2**31-1 * 8.
850 -- -- This is the case in which we could end up with problems from
851 -- -- an unnoticed overflow in computing the size in bytes
853 -- Check_Siz := (Uint_2 ** 31 - Uint_1) * Uint_8;
856 -- Make_Attribute_Reference (Loc,
857 -- Prefix => New_Occurrence_Of (Typ, Loc),
858 -- Attribute_Name => Name_Size);
860 -- GCC 2 case (for now this is for GCC 3 dynamic case as well)
863 -- First step is to calculate the maximum number of elements. For
864 -- this calculation, we use the actual size of the subtype if it is
865 -- static, and if a bound of a subtype is non-static, we go to the
866 -- bound of the base type.
869 Indx := First_Index (Typ);
870 while Present (Indx) loop
871 Xtyp := Etype (Indx);
872 Lo := Type_Low_Bound (Xtyp);
873 Hi := Type_High_Bound (Xtyp);
875 -- If any bound raises constraint error, we will never get this
876 -- far, so there is no need to generate any kind of check.
878 if Raises_Constraint_Error (Lo)
880 Raises_Constraint_Error (Hi)
882 Uintp.Release (Umark);
886 -- Otherwise get bounds values
888 if Is_Static_Expression (Lo) then
889 Lob := Expr_Value (Lo);
891 Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp)));
895 if Is_Static_Expression (Hi) then
896 Hib := Expr_Value (Hi);
898 Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
902 Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0);
906 -- Compute the limit against which we want to check. For subprograms,
907 -- where the array will go on the stack, we use 8*2**24, which (in
908 -- bits) is the size of a 16 megabyte array.
910 if Is_Subprogram (Scope (Ent)) then
911 Check_Siz := Uint_2 ** 27;
913 Check_Siz := Uint_2 ** 31;
916 -- If we have all static bounds and Siz is too large, then we know
917 -- we know we have a storage error right now, so generate message
919 if Static and then Siz >= Check_Siz then
921 Make_Raise_Storage_Error (Loc,
922 Reason => SE_Object_Too_Large));
923 Error_Msg_N ("?Storage_Error will be raised at run-time", N);
924 Uintp.Release (Umark);
928 -- Case of component size known at compile time. If the array
929 -- size is definitely in range, then we do not need a check.
931 if Known_Esize (Ctyp)
932 and then Siz * Esize (Ctyp) < Check_Siz
934 Uintp.Release (Umark);
938 -- Here if a dynamic check is required
940 -- What we do is to build an expression for the size of the array,
941 -- which is computed as the 'Size of the array component, times
942 -- the size of each dimension.
944 Uintp.Release (Umark);
947 Make_Attribute_Reference (Loc,
948 Prefix => New_Occurrence_Of (Ctyp, Loc),
949 Attribute_Name => Name_Size);
951 Indx := First_Index (Typ);
952 for J in 1 .. Number_Dimensions (Typ) loop
953 if Sloc (Etype (Indx)) = Sloc (N) then
954 Ensure_Defined (Etype (Indx), N);
958 Make_Op_Multiply (Loc,
961 Make_Attribute_Reference (Loc,
962 Prefix => New_Occurrence_Of (Typ, Loc),
963 Attribute_Name => Name_Length,
964 Expressions => New_List (
965 Make_Integer_Literal (Loc, J))));
970 -- Common code to actually emit the check
973 Make_Raise_Storage_Error (Loc,
978 Make_Integer_Literal (Loc,
979 Intval => Check_Siz)),
980 Reason => SE_Object_Too_Large);
982 Set_Size_Check_Code (Defining_Identifier (N), Code);
983 Insert_Action (N, Code, Suppress => All_Checks);
984 end Apply_Array_Size_Check;
986 ----------------------------
987 -- Apply_Constraint_Check --
988 ----------------------------
990 procedure Apply_Constraint_Check
993 No_Sliding : Boolean := False)
995 Desig_Typ : Entity_Id;
998 if Inside_A_Generic then
1001 elsif Is_Scalar_Type (Typ) then
1002 Apply_Scalar_Range_Check (N, Typ);
1004 elsif Is_Array_Type (Typ) then
1006 -- A useful optimization: an aggregate with only an Others clause
1007 -- always has the right bounds.
1009 if Nkind (N) = N_Aggregate
1010 and then No (Expressions (N))
1012 (First (Choices (First (Component_Associations (N)))))
1018 if Is_Constrained (Typ) then
1019 Apply_Length_Check (N, Typ);
1022 Apply_Range_Check (N, Typ);
1025 Apply_Range_Check (N, Typ);
1028 elsif (Is_Record_Type (Typ)
1029 or else Is_Private_Type (Typ))
1030 and then Has_Discriminants (Base_Type (Typ))
1031 and then Is_Constrained (Typ)
1033 Apply_Discriminant_Check (N, Typ);
1035 elsif Is_Access_Type (Typ) then
1037 Desig_Typ := Designated_Type (Typ);
1039 -- No checks necessary if expression statically null
1041 if Nkind (N) = N_Null then
1044 -- No sliding possible on access to arrays
1046 elsif Is_Array_Type (Desig_Typ) then
1047 if Is_Constrained (Desig_Typ) then
1048 Apply_Length_Check (N, Typ);
1051 Apply_Range_Check (N, Typ);
1053 elsif Has_Discriminants (Base_Type (Desig_Typ))
1054 and then Is_Constrained (Desig_Typ)
1056 Apply_Discriminant_Check (N, Typ);
1059 if Can_Never_Be_Null (Typ)
1060 and then not Can_Never_Be_Null (Etype (N))
1062 Install_Null_Excluding_Check (N);
1065 end Apply_Constraint_Check;
1067 ------------------------------
1068 -- Apply_Discriminant_Check --
1069 ------------------------------
1071 procedure Apply_Discriminant_Check
1074 Lhs : Node_Id := Empty)
1076 Loc : constant Source_Ptr := Sloc (N);
1077 Do_Access : constant Boolean := Is_Access_Type (Typ);
1078 S_Typ : Entity_Id := Etype (N);
1082 function Is_Aliased_Unconstrained_Component return Boolean;
1083 -- It is possible for an aliased component to have a nominal
1084 -- unconstrained subtype (through instantiation). If this is a
1085 -- discriminated component assigned in the expansion of an aggregate
1086 -- in an initialization, the check must be suppressed. This unusual
1087 -- situation requires a predicate of its own (see 7503-008).
1089 ----------------------------------------
1090 -- Is_Aliased_Unconstrained_Component --
1091 ----------------------------------------
1093 function Is_Aliased_Unconstrained_Component return Boolean is
1098 if Nkind (Lhs) /= N_Selected_Component then
1101 Comp := Entity (Selector_Name (Lhs));
1102 Pref := Prefix (Lhs);
1105 if Ekind (Comp) /= E_Component
1106 or else not Is_Aliased (Comp)
1111 return not Comes_From_Source (Pref)
1112 and then In_Instance
1113 and then not Is_Constrained (Etype (Comp));
1114 end Is_Aliased_Unconstrained_Component;
1116 -- Start of processing for Apply_Discriminant_Check
1120 T_Typ := Designated_Type (Typ);
1125 -- Nothing to do if discriminant checks are suppressed or else no code
1126 -- is to be generated
1128 if not Expander_Active
1129 or else Discriminant_Checks_Suppressed (T_Typ)
1134 -- No discriminant checks necessary for access when expression
1135 -- is statically Null. This is not only an optimization, this is
1136 -- fundamental because otherwise discriminant checks may be generated
1137 -- in init procs for types containing an access to a non-frozen yet
1138 -- record, causing a deadly forward reference.
1140 -- Also, if the expression is of an access type whose designated
1141 -- type is incomplete, then the access value must be null and
1142 -- we suppress the check.
1144 if Nkind (N) = N_Null then
1147 elsif Is_Access_Type (S_Typ) then
1148 S_Typ := Designated_Type (S_Typ);
1150 if Ekind (S_Typ) = E_Incomplete_Type then
1155 -- If an assignment target is present, then we need to generate
1156 -- the actual subtype if the target is a parameter or aliased
1157 -- object with an unconstrained nominal subtype.
1160 and then (Present (Param_Entity (Lhs))
1161 or else (not Is_Constrained (T_Typ)
1162 and then Is_Aliased_View (Lhs)
1163 and then not Is_Aliased_Unconstrained_Component))
1165 T_Typ := Get_Actual_Subtype (Lhs);
1168 -- Nothing to do if the type is unconstrained (this is the case
1169 -- where the actual subtype in the RM sense of N is unconstrained
1170 -- and no check is required).
1172 if not Is_Constrained (T_Typ) then
1176 -- Nothing to do if the type is an Unchecked_Union
1178 if Is_Unchecked_Union (Base_Type (T_Typ)) then
1182 -- Suppress checks if the subtypes are the same.
1183 -- the check must be preserved in an assignment to a formal, because
1184 -- the constraint is given by the actual.
1186 if Nkind (Original_Node (N)) /= N_Allocator
1188 or else not Is_Entity_Name (Lhs)
1189 or else No (Param_Entity (Lhs)))
1192 or else (Do_Access and then Designated_Type (Typ) = S_Typ))
1193 and then not Is_Aliased_View (Lhs)
1198 -- We can also eliminate checks on allocators with a subtype mark
1199 -- that coincides with the context type. The context type may be a
1200 -- subtype without a constraint (common case, a generic actual).
1202 elsif Nkind (Original_Node (N)) = N_Allocator
1203 and then Is_Entity_Name (Expression (Original_Node (N)))
1206 Alloc_Typ : constant Entity_Id :=
1207 Entity (Expression (Original_Node (N)));
1210 if Alloc_Typ = T_Typ
1211 or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration
1212 and then Is_Entity_Name (
1213 Subtype_Indication (Parent (T_Typ)))
1214 and then Alloc_Typ = Base_Type (T_Typ))
1222 -- See if we have a case where the types are both constrained, and
1223 -- all the constraints are constants. In this case, we can do the
1224 -- check successfully at compile time.
1226 -- We skip this check for the case where the node is a rewritten`
1227 -- allocator, because it already carries the context subtype, and
1228 -- extracting the discriminants from the aggregate is messy.
1230 if Is_Constrained (S_Typ)
1231 and then Nkind (Original_Node (N)) /= N_Allocator
1241 -- S_Typ may not have discriminants in the case where it is a
1242 -- private type completed by a default discriminated type. In
1243 -- that case, we need to get the constraints from the
1244 -- underlying_type. If the underlying type is unconstrained (i.e.
1245 -- has no default discriminants) no check is needed.
1247 if Has_Discriminants (S_Typ) then
1248 Discr := First_Discriminant (S_Typ);
1249 DconS := First_Elmt (Discriminant_Constraint (S_Typ));
1252 Discr := First_Discriminant (Underlying_Type (S_Typ));
1255 (Discriminant_Constraint (Underlying_Type (S_Typ)));
1261 -- A further optimization: if T_Typ is derived from S_Typ
1262 -- without imposing a constraint, no check is needed.
1264 if Nkind (Original_Node (Parent (T_Typ))) =
1265 N_Full_Type_Declaration
1268 Type_Def : constant Node_Id :=
1270 (Original_Node (Parent (T_Typ)));
1272 if Nkind (Type_Def) = N_Derived_Type_Definition
1273 and then Is_Entity_Name (Subtype_Indication (Type_Def))
1274 and then Entity (Subtype_Indication (Type_Def)) = S_Typ
1282 DconT := First_Elmt (Discriminant_Constraint (T_Typ));
1284 while Present (Discr) loop
1285 ItemS := Node (DconS);
1286 ItemT := Node (DconT);
1289 not Is_OK_Static_Expression (ItemS)
1291 not Is_OK_Static_Expression (ItemT);
1293 if Expr_Value (ItemS) /= Expr_Value (ItemT) then
1294 if Do_Access then -- needs run-time check.
1297 Apply_Compile_Time_Constraint_Error
1298 (N, "incorrect value for discriminant&?",
1299 CE_Discriminant_Check_Failed, Ent => Discr);
1306 Next_Discriminant (Discr);
1315 -- Here we need a discriminant check. First build the expression
1316 -- for the comparisons of the discriminants:
1318 -- (n.disc1 /= typ.disc1) or else
1319 -- (n.disc2 /= typ.disc2) or else
1321 -- (n.discn /= typ.discn)
1323 Cond := Build_Discriminant_Checks (N, T_Typ);
1325 -- If Lhs is set and is a parameter, then the condition is
1326 -- guarded by: lhs'constrained and then (condition built above)
1328 if Present (Param_Entity (Lhs)) then
1332 Make_Attribute_Reference (Loc,
1333 Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc),
1334 Attribute_Name => Name_Constrained),
1335 Right_Opnd => Cond);
1339 Cond := Guard_Access (Cond, Loc, N);
1343 Make_Raise_Constraint_Error (Loc,
1345 Reason => CE_Discriminant_Check_Failed));
1346 end Apply_Discriminant_Check;
1348 ------------------------
1349 -- Apply_Divide_Check --
1350 ------------------------
1352 procedure Apply_Divide_Check (N : Node_Id) is
1353 Loc : constant Source_Ptr := Sloc (N);
1354 Typ : constant Entity_Id := Etype (N);
1355 Left : constant Node_Id := Left_Opnd (N);
1356 Right : constant Node_Id := Right_Opnd (N);
1368 and not Backend_Divide_Checks_On_Target
1370 Determine_Range (Right, ROK, Rlo, Rhi);
1372 -- See if division by zero possible, and if so generate test. This
1373 -- part of the test is not controlled by the -gnato switch.
1375 if Do_Division_Check (N) then
1376 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
1378 Make_Raise_Constraint_Error (Loc,
1381 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
1382 Right_Opnd => Make_Integer_Literal (Loc, 0)),
1383 Reason => CE_Divide_By_Zero));
1387 -- Test for extremely annoying case of xxx'First divided by -1
1389 if Do_Overflow_Check (N) then
1391 if Nkind (N) = N_Op_Divide
1392 and then Is_Signed_Integer_Type (Typ)
1394 Determine_Range (Left, LOK, Llo, Lhi);
1395 LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
1397 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
1399 ((not LOK) or else (Llo = LLB))
1402 Make_Raise_Constraint_Error (Loc,
1408 Duplicate_Subexpr_Move_Checks (Left),
1409 Right_Opnd => Make_Integer_Literal (Loc, LLB)),
1413 Duplicate_Subexpr (Right),
1415 Make_Integer_Literal (Loc, -1))),
1416 Reason => CE_Overflow_Check_Failed));
1421 end Apply_Divide_Check;
1423 ----------------------------------
1424 -- Apply_Float_Conversion_Check --
1425 ----------------------------------
1427 -- Let F and I be the source and target types of the conversion.
1428 -- The Ada standard specifies that a floating-point value X is rounded
1429 -- to the nearest integer, with halfway cases being rounded away from
1430 -- zero. The rounded value of X is checked against I'Range.
1432 -- The catch in the above paragraph is that there is no good way
1433 -- to know whether the round-to-integer operation resulted in
1434 -- overflow. A remedy is to perform a range check in the floating-point
1435 -- domain instead, however:
1436 -- (1) The bounds may not be known at compile time
1437 -- (2) The check must take into account possible rounding.
1438 -- (3) The range of type I may not be exactly representable in F.
1439 -- (4) The end-points I'First - 0.5 and I'Last + 0.5 may or may
1440 -- not be in range, depending on the sign of I'First and I'Last.
1441 -- (5) X may be a NaN, which will fail any comparison
1443 -- The following steps take care of these issues converting X:
1444 -- (1) If either I'First or I'Last is not known at compile time, use
1445 -- I'Base instead of I in the next three steps and perform a
1446 -- regular range check against I'Range after conversion.
1447 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1448 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1449 -- F'Machine (T) and let Lo_OK be (Lo >= I'First). In other words,
1450 -- take one of the closest floating-point numbers to T, and see if
1451 -- it is in range or not.
1452 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1453 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1454 -- F'Rounding (T) and let Hi_OK be (Hi <= I'Last).
1455 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1456 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1458 procedure Apply_Float_Conversion_Check
1460 Target_Typ : Entity_Id)
1462 LB : constant Node_Id := Type_Low_Bound (Target_Typ);
1463 HB : constant Node_Id := Type_High_Bound (Target_Typ);
1464 Loc : constant Source_Ptr := Sloc (Ck_Node);
1465 Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node));
1466 Target_Base : constant Entity_Id := Implementation_Base_Type
1468 Max_Bound : constant Uint := UI_Expon
1469 (Machine_Radix (Expr_Type),
1470 Machine_Mantissa (Expr_Type) - 1) - 1;
1471 -- Largest bound, so bound plus or minus half is a machine number of F
1474 Ilast : Uint; -- Bounds of integer type
1475 Lo, Hi : Ureal; -- Bounds to check in floating-point domain
1477 Hi_OK : Boolean; -- True iff Lo resp. Hi belongs to I'Range
1480 Hi_Chk : Node_Id; -- Expressions that are False iff check fails
1482 Reason : RT_Exception_Code;
1485 if not Compile_Time_Known_Value (LB)
1486 or not Compile_Time_Known_Value (HB)
1489 -- First check that the value falls in the range of the base
1490 -- type, to prevent overflow during conversion and then
1491 -- perform a regular range check against the (dynamic) bounds.
1493 Par : constant Node_Id := Parent (Ck_Node);
1495 pragma Assert (Target_Base /= Target_Typ);
1496 pragma Assert (Nkind (Par) = N_Type_Conversion);
1498 Temp : constant Entity_Id :=
1499 Make_Defining_Identifier (Loc,
1500 Chars => New_Internal_Name ('T'));
1503 Apply_Float_Conversion_Check (Ck_Node, Target_Base);
1504 Set_Etype (Temp, Target_Base);
1506 Insert_Action (Parent (Par),
1507 Make_Object_Declaration (Loc,
1508 Defining_Identifier => Temp,
1509 Object_Definition => New_Occurrence_Of (Target_Typ, Loc),
1510 Expression => New_Copy_Tree (Par)),
1511 Suppress => All_Checks);
1514 Make_Raise_Constraint_Error (Loc,
1517 Left_Opnd => New_Occurrence_Of (Temp, Loc),
1518 Right_Opnd => New_Occurrence_Of (Target_Typ, Loc)),
1519 Reason => CE_Range_Check_Failed));
1520 Rewrite (Par, New_Occurrence_Of (Temp, Loc));
1526 -- Get the bounds of the target type
1528 Ifirst := Expr_Value (LB);
1529 Ilast := Expr_Value (HB);
1531 -- Check against lower bound
1533 if abs (Ifirst) < Max_Bound then
1534 Lo := UR_From_Uint (Ifirst) - Ureal_Half;
1535 Lo_OK := (Ifirst > 0);
1537 Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
1538 Lo_OK := (Lo >= UR_From_Uint (Ifirst));
1543 -- Lo_Chk := (X >= Lo)
1545 Lo_Chk := Make_Op_Ge (Loc,
1546 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
1547 Right_Opnd => Make_Real_Literal (Loc, Lo));
1550 -- Lo_Chk := (X > Lo)
1552 Lo_Chk := Make_Op_Gt (Loc,
1553 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
1554 Right_Opnd => Make_Real_Literal (Loc, Lo));
1557 -- Check against higher bound
1559 if abs (Ilast) < Max_Bound then
1560 Hi := UR_From_Uint (Ilast) + Ureal_Half;
1561 Hi_OK := (Ilast < 0);
1563 Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Ck_Node);
1564 Hi_OK := (Hi <= UR_From_Uint (Ilast));
1569 -- Hi_Chk := (X <= Hi)
1571 Hi_Chk := Make_Op_Le (Loc,
1572 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
1573 Right_Opnd => Make_Real_Literal (Loc, Hi));
1576 -- Hi_Chk := (X < Hi)
1578 Hi_Chk := Make_Op_Lt (Loc,
1579 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
1580 Right_Opnd => Make_Real_Literal (Loc, Hi));
1583 -- If the bounds of the target type are the same as those of the
1584 -- base type, the check is an overflow check as a range check is
1585 -- not performed in these cases.
1587 if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst
1588 and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast
1590 Reason := CE_Overflow_Check_Failed;
1592 Reason := CE_Range_Check_Failed;
1595 -- Raise CE if either conditions does not hold
1597 Insert_Action (Ck_Node,
1598 Make_Raise_Constraint_Error (Loc,
1599 Condition => Make_Op_Not (Loc, Make_Op_And (Loc, Lo_Chk, Hi_Chk)),
1601 end Apply_Float_Conversion_Check;
1603 ------------------------
1604 -- Apply_Length_Check --
1605 ------------------------
1607 procedure Apply_Length_Check
1609 Target_Typ : Entity_Id;
1610 Source_Typ : Entity_Id := Empty)
1613 Apply_Selected_Length_Checks
1614 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1615 end Apply_Length_Check;
1617 -----------------------
1618 -- Apply_Range_Check --
1619 -----------------------
1621 procedure Apply_Range_Check
1623 Target_Typ : Entity_Id;
1624 Source_Typ : Entity_Id := Empty)
1627 Apply_Selected_Range_Checks
1628 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1629 end Apply_Range_Check;
1631 ------------------------------
1632 -- Apply_Scalar_Range_Check --
1633 ------------------------------
1635 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check
1636 -- flag off if it is already set on.
1638 procedure Apply_Scalar_Range_Check
1640 Target_Typ : Entity_Id;
1641 Source_Typ : Entity_Id := Empty;
1642 Fixed_Int : Boolean := False)
1644 Parnt : constant Node_Id := Parent (Expr);
1646 Arr : Node_Id := Empty; -- initialize to prevent warning
1647 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning
1650 Is_Subscr_Ref : Boolean;
1651 -- Set true if Expr is a subscript
1653 Is_Unconstrained_Subscr_Ref : Boolean;
1654 -- Set true if Expr is a subscript of an unconstrained array. In this
1655 -- case we do not attempt to do an analysis of the value against the
1656 -- range of the subscript, since we don't know the actual subtype.
1659 -- Set to True if Expr should be regarded as a real value
1660 -- even though the type of Expr might be discrete.
1662 procedure Bad_Value;
1663 -- Procedure called if value is determined to be out of range
1669 procedure Bad_Value is
1671 Apply_Compile_Time_Constraint_Error
1672 (Expr, "value not in range of}?", CE_Range_Check_Failed,
1677 -- Start of processing for Apply_Scalar_Range_Check
1680 if Inside_A_Generic then
1683 -- Return if check obviously not needed. Note that we do not check
1684 -- for the expander being inactive, since this routine does not
1685 -- insert any code, but it does generate useful warnings sometimes,
1686 -- which we would like even if we are in semantics only mode.
1688 elsif Target_Typ = Any_Type
1689 or else not Is_Scalar_Type (Target_Typ)
1690 or else Raises_Constraint_Error (Expr)
1695 -- Now, see if checks are suppressed
1698 Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component;
1700 if Is_Subscr_Ref then
1701 Arr := Prefix (Parnt);
1702 Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
1705 if not Do_Range_Check (Expr) then
1707 -- Subscript reference. Check for Index_Checks suppressed
1709 if Is_Subscr_Ref then
1711 -- Check array type and its base type
1713 if Index_Checks_Suppressed (Arr_Typ)
1714 or else Index_Checks_Suppressed (Base_Type (Arr_Typ))
1718 -- Check array itself if it is an entity name
1720 elsif Is_Entity_Name (Arr)
1721 and then Index_Checks_Suppressed (Entity (Arr))
1725 -- Check expression itself if it is an entity name
1727 elsif Is_Entity_Name (Expr)
1728 and then Index_Checks_Suppressed (Entity (Expr))
1733 -- All other cases, check for Range_Checks suppressed
1736 -- Check target type and its base type
1738 if Range_Checks_Suppressed (Target_Typ)
1739 or else Range_Checks_Suppressed (Base_Type (Target_Typ))
1743 -- Check expression itself if it is an entity name
1745 elsif Is_Entity_Name (Expr)
1746 and then Range_Checks_Suppressed (Entity (Expr))
1750 -- If Expr is part of an assignment statement, then check
1751 -- left side of assignment if it is an entity name.
1753 elsif Nkind (Parnt) = N_Assignment_Statement
1754 and then Is_Entity_Name (Name (Parnt))
1755 and then Range_Checks_Suppressed (Entity (Name (Parnt)))
1762 -- Do not set range checks if they are killed
1764 if Nkind (Expr) = N_Unchecked_Type_Conversion
1765 and then Kill_Range_Check (Expr)
1770 -- Do not set range checks for any values from System.Scalar_Values
1771 -- since the whole idea of such values is to avoid checking them!
1773 if Is_Entity_Name (Expr)
1774 and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values)
1779 -- Now see if we need a check
1781 if No (Source_Typ) then
1782 S_Typ := Etype (Expr);
1784 S_Typ := Source_Typ;
1787 if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then
1791 Is_Unconstrained_Subscr_Ref :=
1792 Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
1794 -- Always do a range check if the source type includes infinities
1795 -- and the target type does not include infinities. We do not do
1796 -- this if range checks are killed.
1798 if Is_Floating_Point_Type (S_Typ)
1799 and then Has_Infinities (S_Typ)
1800 and then not Has_Infinities (Target_Typ)
1802 Enable_Range_Check (Expr);
1805 -- Return if we know expression is definitely in the range of
1806 -- the target type as determined by Determine_Range. Right now
1807 -- we only do this for discrete types, and not fixed-point or
1808 -- floating-point types.
1810 -- The additional less-precise tests below catch these cases.
1812 -- Note: skip this if we are given a source_typ, since the point
1813 -- of supplying a Source_Typ is to stop us looking at the expression.
1814 -- could sharpen this test to be out parameters only ???
1816 if Is_Discrete_Type (Target_Typ)
1817 and then Is_Discrete_Type (Etype (Expr))
1818 and then not Is_Unconstrained_Subscr_Ref
1819 and then No (Source_Typ)
1822 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
1823 Thi : constant Node_Id := Type_High_Bound (Target_Typ);
1828 if Compile_Time_Known_Value (Tlo)
1829 and then Compile_Time_Known_Value (Thi)
1832 Lov : constant Uint := Expr_Value (Tlo);
1833 Hiv : constant Uint := Expr_Value (Thi);
1836 -- If range is null, we for sure have a constraint error
1837 -- (we don't even need to look at the value involved,
1838 -- since all possible values will raise CE).
1845 -- Otherwise determine range of value
1847 Determine_Range (Expr, OK, Lo, Hi);
1851 -- If definitely in range, all OK
1853 if Lo >= Lov and then Hi <= Hiv then
1856 -- If definitely not in range, warn
1858 elsif Lov > Hi or else Hiv < Lo then
1862 -- Otherwise we don't know
1874 Is_Floating_Point_Type (S_Typ)
1875 or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
1877 -- Check if we can determine at compile time whether Expr is in the
1878 -- range of the target type. Note that if S_Typ is within the bounds
1879 -- of Target_Typ then this must be the case. This check is meaningful
1880 -- only if this is not a conversion between integer and real types.
1882 if not Is_Unconstrained_Subscr_Ref
1884 Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
1886 (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
1888 Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real))
1892 elsif Is_Out_Of_Range (Expr, Target_Typ, Fixed_Int, Int_Real) then
1896 -- In the floating-point case, we only do range checks if the
1897 -- type is constrained. We definitely do NOT want range checks
1898 -- for unconstrained types, since we want to have infinities
1900 elsif Is_Floating_Point_Type (S_Typ) then
1901 if Is_Constrained (S_Typ) then
1902 Enable_Range_Check (Expr);
1905 -- For all other cases we enable a range check unconditionally
1908 Enable_Range_Check (Expr);
1911 end Apply_Scalar_Range_Check;
1913 ----------------------------------
1914 -- Apply_Selected_Length_Checks --
1915 ----------------------------------
1917 procedure Apply_Selected_Length_Checks
1919 Target_Typ : Entity_Id;
1920 Source_Typ : Entity_Id;
1921 Do_Static : Boolean)
1924 R_Result : Check_Result;
1927 Loc : constant Source_Ptr := Sloc (Ck_Node);
1928 Checks_On : constant Boolean :=
1929 (not Index_Checks_Suppressed (Target_Typ))
1931 (not Length_Checks_Suppressed (Target_Typ));
1934 if not Expander_Active then
1939 Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
1941 for J in 1 .. 2 loop
1942 R_Cno := R_Result (J);
1943 exit when No (R_Cno);
1945 -- A length check may mention an Itype which is attached to a
1946 -- subsequent node. At the top level in a package this can cause
1947 -- an order-of-elaboration problem, so we make sure that the itype
1948 -- is referenced now.
1950 if Ekind (Current_Scope) = E_Package
1951 and then Is_Compilation_Unit (Current_Scope)
1953 Ensure_Defined (Target_Typ, Ck_Node);
1955 if Present (Source_Typ) then
1956 Ensure_Defined (Source_Typ, Ck_Node);
1958 elsif Is_Itype (Etype (Ck_Node)) then
1959 Ensure_Defined (Etype (Ck_Node), Ck_Node);
1963 -- If the item is a conditional raise of constraint error,
1964 -- then have a look at what check is being performed and
1967 if Nkind (R_Cno) = N_Raise_Constraint_Error
1968 and then Present (Condition (R_Cno))
1970 Cond := Condition (R_Cno);
1972 if not Has_Dynamic_Length_Check (Ck_Node)
1975 Insert_Action (Ck_Node, R_Cno);
1977 if not Do_Static then
1978 Set_Has_Dynamic_Length_Check (Ck_Node);
1982 -- Output a warning if the condition is known to be True
1984 if Is_Entity_Name (Cond)
1985 and then Entity (Cond) = Standard_True
1987 Apply_Compile_Time_Constraint_Error
1988 (Ck_Node, "wrong length for array of}?",
1989 CE_Length_Check_Failed,
1993 -- If we were only doing a static check, or if checks are not
1994 -- on, then we want to delete the check, since it is not needed.
1995 -- We do this by replacing the if statement by a null statement
1997 elsif Do_Static or else not Checks_On then
1998 Rewrite (R_Cno, Make_Null_Statement (Loc));
2002 Install_Static_Check (R_Cno, Loc);
2007 end Apply_Selected_Length_Checks;
2009 ---------------------------------
2010 -- Apply_Selected_Range_Checks --
2011 ---------------------------------
2013 procedure Apply_Selected_Range_Checks
2015 Target_Typ : Entity_Id;
2016 Source_Typ : Entity_Id;
2017 Do_Static : Boolean)
2020 R_Result : Check_Result;
2023 Loc : constant Source_Ptr := Sloc (Ck_Node);
2024 Checks_On : constant Boolean :=
2025 (not Index_Checks_Suppressed (Target_Typ))
2027 (not Range_Checks_Suppressed (Target_Typ));
2030 if not Expander_Active or else not Checks_On then
2035 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
2037 for J in 1 .. 2 loop
2039 R_Cno := R_Result (J);
2040 exit when No (R_Cno);
2042 -- If the item is a conditional raise of constraint error,
2043 -- then have a look at what check is being performed and
2046 if Nkind (R_Cno) = N_Raise_Constraint_Error
2047 and then Present (Condition (R_Cno))
2049 Cond := Condition (R_Cno);
2051 if not Has_Dynamic_Range_Check (Ck_Node) then
2052 Insert_Action (Ck_Node, R_Cno);
2054 if not Do_Static then
2055 Set_Has_Dynamic_Range_Check (Ck_Node);
2059 -- Output a warning if the condition is known to be True
2061 if Is_Entity_Name (Cond)
2062 and then Entity (Cond) = Standard_True
2064 -- Since an N_Range is technically not an expression, we
2065 -- have to set one of the bounds to C_E and then just flag
2066 -- the N_Range. The warning message will point to the
2067 -- lower bound and complain about a range, which seems OK.
2069 if Nkind (Ck_Node) = N_Range then
2070 Apply_Compile_Time_Constraint_Error
2071 (Low_Bound (Ck_Node), "static range out of bounds of}?",
2072 CE_Range_Check_Failed,
2076 Set_Raises_Constraint_Error (Ck_Node);
2079 Apply_Compile_Time_Constraint_Error
2080 (Ck_Node, "static value out of range of}?",
2081 CE_Range_Check_Failed,
2086 -- If we were only doing a static check, or if checks are not
2087 -- on, then we want to delete the check, since it is not needed.
2088 -- We do this by replacing the if statement by a null statement
2090 elsif Do_Static or else not Checks_On then
2091 Rewrite (R_Cno, Make_Null_Statement (Loc));
2095 Install_Static_Check (R_Cno, Loc);
2098 end Apply_Selected_Range_Checks;
2100 -------------------------------
2101 -- Apply_Static_Length_Check --
2102 -------------------------------
2104 procedure Apply_Static_Length_Check
2106 Target_Typ : Entity_Id;
2107 Source_Typ : Entity_Id := Empty)
2110 Apply_Selected_Length_Checks
2111 (Expr, Target_Typ, Source_Typ, Do_Static => True);
2112 end Apply_Static_Length_Check;
2114 -------------------------------------
2115 -- Apply_Subscript_Validity_Checks --
2116 -------------------------------------
2118 procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
2122 pragma Assert (Nkind (Expr) = N_Indexed_Component);
2124 -- Loop through subscripts
2126 Sub := First (Expressions (Expr));
2127 while Present (Sub) loop
2129 -- Check one subscript. Note that we do not worry about
2130 -- enumeration type with holes, since we will convert the
2131 -- value to a Pos value for the subscript, and that convert
2132 -- will do the necessary validity check.
2134 Ensure_Valid (Sub, Holes_OK => True);
2136 -- Move to next subscript
2140 end Apply_Subscript_Validity_Checks;
2142 ----------------------------------
2143 -- Apply_Type_Conversion_Checks --
2144 ----------------------------------
2146 procedure Apply_Type_Conversion_Checks (N : Node_Id) is
2147 Target_Type : constant Entity_Id := Etype (N);
2148 Target_Base : constant Entity_Id := Base_Type (Target_Type);
2149 Expr : constant Node_Id := Expression (N);
2150 Expr_Type : constant Entity_Id := Etype (Expr);
2153 if Inside_A_Generic then
2156 -- Skip these checks if serious errors detected, there are some nasty
2157 -- situations of incomplete trees that blow things up.
2159 elsif Serious_Errors_Detected > 0 then
2162 -- Scalar type conversions of the form Target_Type (Expr) require
2163 -- a range check if we cannot be sure that Expr is in the base type
2164 -- of Target_Typ and also that Expr is in the range of Target_Typ.
2165 -- These are not quite the same condition from an implementation
2166 -- point of view, but clearly the second includes the first.
2168 elsif Is_Scalar_Type (Target_Type) then
2170 Conv_OK : constant Boolean := Conversion_OK (N);
2171 -- If the Conversion_OK flag on the type conversion is set
2172 -- and no floating point type is involved in the type conversion
2173 -- then fixed point values must be read as integral values.
2175 Float_To_Int : constant Boolean :=
2176 Is_Floating_Point_Type (Expr_Type)
2177 and then Is_Integer_Type (Target_Type);
2180 if not Overflow_Checks_Suppressed (Target_Base)
2181 and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
2182 and then not Float_To_Int
2184 Set_Do_Overflow_Check (N);
2187 if not Range_Checks_Suppressed (Target_Type)
2188 and then not Range_Checks_Suppressed (Expr_Type)
2190 if Float_To_Int then
2191 Apply_Float_Conversion_Check (Expr, Target_Type);
2193 Apply_Scalar_Range_Check
2194 (Expr, Target_Type, Fixed_Int => Conv_OK);
2199 elsif Comes_From_Source (N)
2200 and then Is_Record_Type (Target_Type)
2201 and then Is_Derived_Type (Target_Type)
2202 and then not Is_Tagged_Type (Target_Type)
2203 and then not Is_Constrained (Target_Type)
2204 and then Present (Stored_Constraint (Target_Type))
2206 -- An unconstrained derived type may have inherited discriminant
2207 -- Build an actual discriminant constraint list using the stored
2208 -- constraint, to verify that the expression of the parent type
2209 -- satisfies the constraints imposed by the (unconstrained!)
2210 -- derived type. This applies to value conversions, not to view
2211 -- conversions of tagged types.
2214 Loc : constant Source_Ptr := Sloc (N);
2216 Constraint : Elmt_Id;
2217 Discr_Value : Node_Id;
2220 New_Constraints : constant Elist_Id := New_Elmt_List;
2221 Old_Constraints : constant Elist_Id :=
2222 Discriminant_Constraint (Expr_Type);
2225 Constraint := First_Elmt (Stored_Constraint (Target_Type));
2227 while Present (Constraint) loop
2228 Discr_Value := Node (Constraint);
2230 if Is_Entity_Name (Discr_Value)
2231 and then Ekind (Entity (Discr_Value)) = E_Discriminant
2233 Discr := Corresponding_Discriminant (Entity (Discr_Value));
2236 and then Scope (Discr) = Base_Type (Expr_Type)
2238 -- Parent is constrained by new discriminant. Obtain
2239 -- Value of original discriminant in expression. If
2240 -- the new discriminant has been used to constrain more
2241 -- than one of the stored discriminants, this will
2242 -- provide the required consistency check.
2245 Make_Selected_Component (Loc,
2247 Duplicate_Subexpr_No_Checks
2248 (Expr, Name_Req => True),
2250 Make_Identifier (Loc, Chars (Discr))),
2254 -- Discriminant of more remote ancestor ???
2259 -- Derived type definition has an explicit value for
2260 -- this stored discriminant.
2264 (Duplicate_Subexpr_No_Checks (Discr_Value),
2268 Next_Elmt (Constraint);
2271 -- Use the unconstrained expression type to retrieve the
2272 -- discriminants of the parent, and apply momentarily the
2273 -- discriminant constraint synthesized above.
2275 Set_Discriminant_Constraint (Expr_Type, New_Constraints);
2276 Cond := Build_Discriminant_Checks (Expr, Expr_Type);
2277 Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
2280 Make_Raise_Constraint_Error (Loc,
2282 Reason => CE_Discriminant_Check_Failed));
2285 -- For arrays, conversions are applied during expansion, to take
2286 -- into accounts changes of representation. The checks become range
2287 -- checks on the base type or length checks on the subtype, depending
2288 -- on whether the target type is unconstrained or constrained.
2293 end Apply_Type_Conversion_Checks;
2295 ----------------------------------------------
2296 -- Apply_Universal_Integer_Attribute_Checks --
2297 ----------------------------------------------
2299 procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is
2300 Loc : constant Source_Ptr := Sloc (N);
2301 Typ : constant Entity_Id := Etype (N);
2304 if Inside_A_Generic then
2307 -- Nothing to do if checks are suppressed
2309 elsif Range_Checks_Suppressed (Typ)
2310 and then Overflow_Checks_Suppressed (Typ)
2314 -- Nothing to do if the attribute does not come from source. The
2315 -- internal attributes we generate of this type do not need checks,
2316 -- and furthermore the attempt to check them causes some circular
2317 -- elaboration orders when dealing with packed types.
2319 elsif not Comes_From_Source (N) then
2322 -- If the prefix is a selected component that depends on a discriminant
2323 -- the check may improperly expose a discriminant instead of using
2324 -- the bounds of the object itself. Set the type of the attribute to
2325 -- the base type of the context, so that a check will be imposed when
2326 -- needed (e.g. if the node appears as an index).
2328 elsif Nkind (Prefix (N)) = N_Selected_Component
2329 and then Ekind (Typ) = E_Signed_Integer_Subtype
2330 and then Depends_On_Discriminant (Scalar_Range (Typ))
2332 Set_Etype (N, Base_Type (Typ));
2334 -- Otherwise, replace the attribute node with a type conversion
2335 -- node whose expression is the attribute, retyped to universal
2336 -- integer, and whose subtype mark is the target type. The call
2337 -- to analyze this conversion will set range and overflow checks
2338 -- as required for proper detection of an out of range value.
2341 Set_Etype (N, Universal_Integer);
2342 Set_Analyzed (N, True);
2345 Make_Type_Conversion (Loc,
2346 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
2347 Expression => Relocate_Node (N)));
2349 Analyze_And_Resolve (N, Typ);
2353 end Apply_Universal_Integer_Attribute_Checks;
2355 -------------------------------
2356 -- Build_Discriminant_Checks --
2357 -------------------------------
2359 function Build_Discriminant_Checks
2361 T_Typ : Entity_Id) return Node_Id
2363 Loc : constant Source_Ptr := Sloc (N);
2366 Disc_Ent : Entity_Id;
2372 Disc := First_Elmt (Discriminant_Constraint (T_Typ));
2374 -- For a fully private type, use the discriminants of the parent type
2376 if Is_Private_Type (T_Typ)
2377 and then No (Full_View (T_Typ))
2379 Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ)));
2381 Disc_Ent := First_Discriminant (T_Typ);
2384 while Present (Disc) loop
2385 Dval := Node (Disc);
2387 if Nkind (Dval) = N_Identifier
2388 and then Ekind (Entity (Dval)) = E_Discriminant
2390 Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
2392 Dval := Duplicate_Subexpr_No_Checks (Dval);
2395 -- If we have an Unchecked_Union node, we can infer the discriminants
2398 if Is_Unchecked_Union (Base_Type (T_Typ)) then
2400 Get_Discriminant_Value (
2401 First_Discriminant (T_Typ),
2403 Stored_Constraint (T_Typ)));
2407 Make_Selected_Component (Loc,
2409 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
2411 Make_Identifier (Loc, Chars (Disc_Ent)));
2413 Set_Is_In_Discriminant_Check (Dref);
2416 Evolve_Or_Else (Cond,
2419 Right_Opnd => Dval));
2422 Next_Discriminant (Disc_Ent);
2426 end Build_Discriminant_Checks;
2428 -----------------------------------
2429 -- Check_Valid_Lvalue_Subscripts --
2430 -----------------------------------
2432 procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is
2434 -- Skip this if range checks are suppressed
2436 if Range_Checks_Suppressed (Etype (Expr)) then
2439 -- Only do this check for expressions that come from source. We
2440 -- assume that expander generated assignments explicitly include
2441 -- any necessary checks. Note that this is not just an optimization,
2442 -- it avoids infinite recursions!
2444 elsif not Comes_From_Source (Expr) then
2447 -- For a selected component, check the prefix
2449 elsif Nkind (Expr) = N_Selected_Component then
2450 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
2453 -- Case of indexed component
2455 elsif Nkind (Expr) = N_Indexed_Component then
2456 Apply_Subscript_Validity_Checks (Expr);
2458 -- Prefix may itself be or contain an indexed component, and
2459 -- these subscripts need checking as well
2461 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
2463 end Check_Valid_Lvalue_Subscripts;
2465 ----------------------------------
2466 -- Null_Exclusion_Static_Checks --
2467 ----------------------------------
2469 procedure Null_Exclusion_Static_Checks (N : Node_Id) is
2470 K : constant Node_Kind := Nkind (N);
2472 Related_Nod : Node_Id;
2473 Has_Null_Exclusion : Boolean := False;
2475 type Msg_Kind is (Components, Formals, Objects);
2476 Msg_K : Msg_Kind := Objects;
2477 -- Used by local subprograms to generate precise error messages
2479 procedure Check_Must_Be_Access
2481 Has_Null_Exclusion : Boolean);
2482 -- ??? local subprograms must have comment on spec
2484 procedure Check_Already_Null_Excluding_Type
2486 Has_Null_Exclusion : Boolean;
2487 Related_Nod : Node_Id);
2488 -- ??? local subprograms must have comment on spec
2490 procedure Check_Must_Be_Initialized
2492 Related_Nod : Node_Id);
2493 -- ??? local subprograms must have comment on spec
2495 procedure Check_Null_Not_Allowed (N : Node_Id);
2496 -- ??? local subprograms must have comment on spec
2498 -- ??? following bodies lack comments
2500 --------------------------
2501 -- Check_Must_Be_Access --
2502 --------------------------
2504 procedure Check_Must_Be_Access
2506 Has_Null_Exclusion : Boolean)
2509 if Has_Null_Exclusion
2510 and then not Is_Access_Type (Typ)
2512 Error_Msg_N ("(Ada 2005) must be an access type", Related_Nod);
2514 end Check_Must_Be_Access;
2516 ---------------------------------------
2517 -- Check_Already_Null_Excluding_Type --
2518 ---------------------------------------
2520 procedure Check_Already_Null_Excluding_Type
2522 Has_Null_Exclusion : Boolean;
2523 Related_Nod : Node_Id)
2526 if Has_Null_Exclusion
2527 and then Can_Never_Be_Null (Typ)
2530 ("(Ada 2005) already a null-excluding type", Related_Nod);
2532 end Check_Already_Null_Excluding_Type;
2534 -------------------------------
2535 -- Check_Must_Be_Initialized --
2536 -------------------------------
2538 procedure Check_Must_Be_Initialized
2540 Related_Nod : Node_Id)
2542 Expr : constant Node_Id := Expression (N);
2545 pragma Assert (Nkind (N) = N_Component_Declaration
2546 or else Nkind (N) = N_Object_Declaration);
2548 if not Present (Expr) then
2552 ("(Ada 2005) null-excluding components must be " &
2553 "initialized", Related_Nod);
2557 ("(Ada 2005) null-excluding formals must be initialized",
2562 ("(Ada 2005) null-excluding objects must be initialized",
2566 end Check_Must_Be_Initialized;
2568 ----------------------------
2569 -- Check_Null_Not_Allowed --
2570 ----------------------------
2572 procedure Check_Null_Not_Allowed (N : Node_Id) is
2573 Expr : constant Node_Id := Expression (N);
2577 and then Nkind (Expr) = N_Null
2582 ("(Ada 2005) NULL not allowed in null-excluding " &
2583 "components", Expr);
2587 ("(Ada 2005) NULL not allowed in null-excluding formals",
2592 ("(Ada 2005) NULL not allowed in null-excluding objects",
2596 end Check_Null_Not_Allowed;
2598 -- Start of processing for Null_Exclusion_Static_Checks
2601 pragma Assert (K = N_Component_Declaration
2602 or else K = N_Parameter_Specification
2603 or else K = N_Object_Declaration
2604 or else K = N_Discriminant_Specification
2605 or else K = N_Allocator);
2608 when N_Component_Declaration =>
2609 Msg_K := Components;
2611 if not Present (Access_Definition (Component_Definition (N))) then
2612 Has_Null_Exclusion := Null_Exclusion_Present
2613 (Component_Definition (N));
2614 Typ := Etype (Subtype_Indication (Component_Definition (N)));
2615 Related_Nod := Subtype_Indication (Component_Definition (N));
2616 Check_Must_Be_Access (Typ, Has_Null_Exclusion);
2617 Check_Already_Null_Excluding_Type
2618 (Typ, Has_Null_Exclusion, Related_Nod);
2619 Check_Must_Be_Initialized (N, Related_Nod);
2622 Check_Null_Not_Allowed (N);
2624 when N_Parameter_Specification =>
2626 Has_Null_Exclusion := Null_Exclusion_Present (N);
2627 Typ := Entity (Parameter_Type (N));
2628 Related_Nod := Parameter_Type (N);
2629 Check_Must_Be_Access (Typ, Has_Null_Exclusion);
2630 Check_Already_Null_Excluding_Type
2631 (Typ, Has_Null_Exclusion, Related_Nod);
2632 Check_Null_Not_Allowed (N);
2634 when N_Object_Declaration =>
2636 Has_Null_Exclusion := Null_Exclusion_Present (N);
2637 Typ := Entity (Object_Definition (N));
2638 Related_Nod := Object_Definition (N);
2639 Check_Must_Be_Access (Typ, Has_Null_Exclusion);
2640 Check_Already_Null_Excluding_Type
2641 (Typ, Has_Null_Exclusion, Related_Nod);
2642 Check_Must_Be_Initialized (N, Related_Nod);
2643 Check_Null_Not_Allowed (N);
2645 when N_Discriminant_Specification =>
2646 Msg_K := Components;
2648 if Nkind (Discriminant_Type (N)) /= N_Access_Definition then
2649 Has_Null_Exclusion := Null_Exclusion_Present (N);
2650 Typ := Etype (Defining_Identifier (N));
2651 Related_Nod := Discriminant_Type (N);
2652 Check_Must_Be_Access (Typ, Has_Null_Exclusion);
2653 Check_Already_Null_Excluding_Type
2654 (Typ, Has_Null_Exclusion, Related_Nod);
2657 Check_Null_Not_Allowed (N);
2661 Has_Null_Exclusion := Null_Exclusion_Present (N);
2662 Typ := Etype (Expression (N));
2664 if Nkind (Expression (N)) = N_Qualified_Expression then
2665 Related_Nod := Subtype_Mark (Expression (N));
2667 Related_Nod := Expression (N);
2670 Check_Must_Be_Access (Typ, Has_Null_Exclusion);
2671 Check_Already_Null_Excluding_Type
2672 (Typ, Has_Null_Exclusion, Related_Nod);
2673 Check_Null_Not_Allowed (N);
2676 raise Program_Error;
2678 end Null_Exclusion_Static_Checks;
2680 ----------------------------------
2681 -- Conditional_Statements_Begin --
2682 ----------------------------------
2684 procedure Conditional_Statements_Begin is
2686 Saved_Checks_TOS := Saved_Checks_TOS + 1;
2688 -- If stack overflows, kill all checks, that way we know to
2689 -- simply reset the number of saved checks to zero on return.
2690 -- This should never occur in practice.
2692 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
2695 -- In the normal case, we just make a new stack entry saving
2696 -- the current number of saved checks for a later restore.
2699 Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks;
2701 if Debug_Flag_CC then
2702 w ("Conditional_Statements_Begin: Num_Saved_Checks = ",
2706 end Conditional_Statements_Begin;
2708 --------------------------------
2709 -- Conditional_Statements_End --
2710 --------------------------------
2712 procedure Conditional_Statements_End is
2714 pragma Assert (Saved_Checks_TOS > 0);
2716 -- If the saved checks stack overflowed, then we killed all
2717 -- checks, so setting the number of saved checks back to
2718 -- zero is correct. This should never occur in practice.
2720 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
2721 Num_Saved_Checks := 0;
2723 -- In the normal case, restore the number of saved checks
2724 -- from the top stack entry.
2727 Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
2728 if Debug_Flag_CC then
2729 w ("Conditional_Statements_End: Num_Saved_Checks = ",
2734 Saved_Checks_TOS := Saved_Checks_TOS - 1;
2735 end Conditional_Statements_End;
2737 ---------------------
2738 -- Determine_Range --
2739 ---------------------
2741 Cache_Size : constant := 2 ** 10;
2742 type Cache_Index is range 0 .. Cache_Size - 1;
2743 -- Determine size of below cache (power of 2 is more efficient!)
2745 Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
2746 Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
2747 Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
2748 -- The above arrays are used to implement a small direct cache
2749 -- for Determine_Range calls. Because of the way Determine_Range
2750 -- recursively traces subexpressions, and because overflow checking
2751 -- calls the routine on the way up the tree, a quadratic behavior
2752 -- can otherwise be encountered in large expressions. The cache
2753 -- entry for node N is stored in the (N mod Cache_Size) entry, and
2754 -- can be validated by checking the actual node value stored there.
2756 procedure Determine_Range
2762 Typ : constant Entity_Id := Etype (N);
2766 -- Lo and Hi bounds of left operand
2770 -- Lo and Hi bounds of right (or only) operand
2773 -- Temp variable used to hold a bound node
2776 -- High bound of base type of expression
2780 -- Refined values for low and high bounds, after tightening
2783 -- Used in lower level calls to indicate if call succeeded
2785 Cindex : Cache_Index;
2786 -- Used to search cache
2788 function OK_Operands return Boolean;
2789 -- Used for binary operators. Determines the ranges of the left and
2790 -- right operands, and if they are both OK, returns True, and puts
2791 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left
2797 function OK_Operands return Boolean is
2799 Determine_Range (Left_Opnd (N), OK1, Lo_Left, Hi_Left);
2805 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
2809 -- Start of processing for Determine_Range
2812 -- Prevent junk warnings by initializing range variables
2819 -- If the type is not discrete, or is undefined, then we can't
2820 -- do anything about determining the range.
2822 if No (Typ) or else not Is_Discrete_Type (Typ)
2823 or else Error_Posted (N)
2829 -- For all other cases, we can determine the range
2833 -- If value is compile time known, then the possible range is the
2834 -- one value that we know this expression definitely has!
2836 if Compile_Time_Known_Value (N) then
2837 Lo := Expr_Value (N);
2842 -- Return if already in the cache
2844 Cindex := Cache_Index (N mod Cache_Size);
2846 if Determine_Range_Cache_N (Cindex) = N then
2847 Lo := Determine_Range_Cache_Lo (Cindex);
2848 Hi := Determine_Range_Cache_Hi (Cindex);
2852 -- Otherwise, start by finding the bounds of the type of the
2853 -- expression, the value cannot be outside this range (if it
2854 -- is, then we have an overflow situation, which is a separate
2855 -- check, we are talking here only about the expression value).
2857 -- We use the actual bound unless it is dynamic, in which case
2858 -- use the corresponding base type bound if possible. If we can't
2859 -- get a bound then we figure we can't determine the range (a
2860 -- peculiar case, that perhaps cannot happen, but there is no
2861 -- point in bombing in this optimization circuit.
2863 -- First the low bound
2865 Bound := Type_Low_Bound (Typ);
2867 if Compile_Time_Known_Value (Bound) then
2868 Lo := Expr_Value (Bound);
2870 elsif Compile_Time_Known_Value (Type_Low_Bound (Base_Type (Typ))) then
2871 Lo := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
2878 -- Now the high bound
2880 Bound := Type_High_Bound (Typ);
2882 -- We need the high bound of the base type later on, and this should
2883 -- always be compile time known. Again, it is not clear that this
2884 -- can ever be false, but no point in bombing.
2886 if Compile_Time_Known_Value (Type_High_Bound (Base_Type (Typ))) then
2887 Hbound := Expr_Value (Type_High_Bound (Base_Type (Typ)));
2895 -- If we have a static subtype, then that may have a tighter bound
2896 -- so use the upper bound of the subtype instead in this case.
2898 if Compile_Time_Known_Value (Bound) then
2899 Hi := Expr_Value (Bound);
2902 -- We may be able to refine this value in certain situations. If
2903 -- refinement is possible, then Lor and Hir are set to possibly
2904 -- tighter bounds, and OK1 is set to True.
2908 -- For unary plus, result is limited by range of operand
2911 Determine_Range (Right_Opnd (N), OK1, Lor, Hir);
2913 -- For unary minus, determine range of operand, and negate it
2916 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
2923 -- For binary addition, get range of each operand and do the
2924 -- addition to get the result range.
2928 Lor := Lo_Left + Lo_Right;
2929 Hir := Hi_Left + Hi_Right;
2932 -- Division is tricky. The only case we consider is where the
2933 -- right operand is a positive constant, and in this case we
2934 -- simply divide the bounds of the left operand
2938 if Lo_Right = Hi_Right
2939 and then Lo_Right > 0
2941 Lor := Lo_Left / Lo_Right;
2942 Hir := Hi_Left / Lo_Right;
2949 -- For binary subtraction, get range of each operand and do
2950 -- the worst case subtraction to get the result range.
2952 when N_Op_Subtract =>
2954 Lor := Lo_Left - Hi_Right;
2955 Hir := Hi_Left - Lo_Right;
2958 -- For MOD, if right operand is a positive constant, then
2959 -- result must be in the allowable range of mod results.
2963 if Lo_Right = Hi_Right
2964 and then Lo_Right /= 0
2966 if Lo_Right > 0 then
2968 Hir := Lo_Right - 1;
2970 else -- Lo_Right < 0
2971 Lor := Lo_Right + 1;
2980 -- For REM, if right operand is a positive constant, then
2981 -- result must be in the allowable range of mod results.
2985 if Lo_Right = Hi_Right
2986 and then Lo_Right /= 0
2989 Dval : constant Uint := (abs Lo_Right) - 1;
2992 -- The sign of the result depends on the sign of the
2993 -- dividend (but not on the sign of the divisor, hence
2994 -- the abs operation above).
3014 -- Attribute reference cases
3016 when N_Attribute_Reference =>
3017 case Attribute_Name (N) is
3019 -- For Pos/Val attributes, we can refine the range using the
3020 -- possible range of values of the attribute expression
3022 when Name_Pos | Name_Val =>
3023 Determine_Range (First (Expressions (N)), OK1, Lor, Hir);
3025 -- For Length attribute, use the bounds of the corresponding
3026 -- index type to refine the range.
3030 Atyp : Entity_Id := Etype (Prefix (N));
3038 if Is_Access_Type (Atyp) then
3039 Atyp := Designated_Type (Atyp);
3042 -- For string literal, we know exact value
3044 if Ekind (Atyp) = E_String_Literal_Subtype then
3046 Lo := String_Literal_Length (Atyp);
3047 Hi := String_Literal_Length (Atyp);
3051 -- Otherwise check for expression given
3053 if No (Expressions (N)) then
3057 UI_To_Int (Expr_Value (First (Expressions (N))));
3060 Indx := First_Index (Atyp);
3061 for J in 2 .. Inum loop
3062 Indx := Next_Index (Indx);
3066 (Type_Low_Bound (Etype (Indx)), OK1, LL, LU);
3070 (Type_High_Bound (Etype (Indx)), OK1, UL, UU);
3074 -- The maximum value for Length is the biggest
3075 -- possible gap between the values of the bounds.
3076 -- But of course, this value cannot be negative.
3078 Hir := UI_Max (Uint_0, UU - LL);
3080 -- For constrained arrays, the minimum value for
3081 -- Length is taken from the actual value of the
3082 -- bounds, since the index will be exactly of
3085 if Is_Constrained (Atyp) then
3086 Lor := UI_Max (Uint_0, UL - LU);
3088 -- For an unconstrained array, the minimum value
3089 -- for length is always zero.
3098 -- No special handling for other attributes
3099 -- Probably more opportunities exist here ???
3106 -- For type conversion from one discrete type to another, we
3107 -- can refine the range using the converted value.
3109 when N_Type_Conversion =>
3110 Determine_Range (Expression (N), OK1, Lor, Hir);
3112 -- Nothing special to do for all other expression kinds
3120 -- At this stage, if OK1 is true, then we know that the actual
3121 -- result of the computed expression is in the range Lor .. Hir.
3122 -- We can use this to restrict the possible range of results.
3126 -- If the refined value of the low bound is greater than the
3127 -- type high bound, then reset it to the more restrictive
3128 -- value. However, we do NOT do this for the case of a modular
3129 -- type where the possible upper bound on the value is above the
3130 -- base type high bound, because that means the result could wrap.
3133 and then not (Is_Modular_Integer_Type (Typ)
3134 and then Hir > Hbound)
3139 -- Similarly, if the refined value of the high bound is less
3140 -- than the value so far, then reset it to the more restrictive
3141 -- value. Again, we do not do this if the refined low bound is
3142 -- negative for a modular type, since this would wrap.
3145 and then not (Is_Modular_Integer_Type (Typ)
3146 and then Lor < Uint_0)
3152 -- Set cache entry for future call and we are all done
3154 Determine_Range_Cache_N (Cindex) := N;
3155 Determine_Range_Cache_Lo (Cindex) := Lo;
3156 Determine_Range_Cache_Hi (Cindex) := Hi;
3159 -- If any exception occurs, it means that we have some bug in the compiler
3160 -- possibly triggered by a previous error, or by some unforseen peculiar
3161 -- occurrence. However, this is only an optimization attempt, so there is
3162 -- really no point in crashing the compiler. Instead we just decide, too
3163 -- bad, we can't figure out a range in this case after all.
3168 -- Debug flag K disables this behavior (useful for debugging)
3170 if Debug_Flag_K then
3178 end Determine_Range;
3180 ------------------------------------
3181 -- Discriminant_Checks_Suppressed --
3182 ------------------------------------
3184 function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
3187 if Is_Unchecked_Union (E) then
3189 elsif Checks_May_Be_Suppressed (E) then
3190 return Is_Check_Suppressed (E, Discriminant_Check);
3194 return Scope_Suppress (Discriminant_Check);
3195 end Discriminant_Checks_Suppressed;
3197 --------------------------------
3198 -- Division_Checks_Suppressed --
3199 --------------------------------
3201 function Division_Checks_Suppressed (E : Entity_Id) return Boolean is
3203 if Present (E) and then Checks_May_Be_Suppressed (E) then
3204 return Is_Check_Suppressed (E, Division_Check);
3206 return Scope_Suppress (Division_Check);
3208 end Division_Checks_Suppressed;
3210 -----------------------------------
3211 -- Elaboration_Checks_Suppressed --
3212 -----------------------------------
3214 function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
3217 if Kill_Elaboration_Checks (E) then
3219 elsif Checks_May_Be_Suppressed (E) then
3220 return Is_Check_Suppressed (E, Elaboration_Check);
3224 return Scope_Suppress (Elaboration_Check);
3225 end Elaboration_Checks_Suppressed;
3227 ---------------------------
3228 -- Enable_Overflow_Check --
3229 ---------------------------
3231 procedure Enable_Overflow_Check (N : Node_Id) is
3232 Typ : constant Entity_Id := Base_Type (Etype (N));
3241 if Debug_Flag_CC then
3242 w ("Enable_Overflow_Check for node ", Int (N));
3243 Write_Str (" Source location = ");
3248 -- Nothing to do if the range of the result is known OK. We skip
3249 -- this for conversions, since the caller already did the check,
3250 -- and in any case the condition for deleting the check for a
3251 -- type conversion is different in any case.
3253 if Nkind (N) /= N_Type_Conversion then
3254 Determine_Range (N, OK, Lo, Hi);
3256 -- Note in the test below that we assume that if a bound of the
3257 -- range is equal to that of the type. That's not quite accurate
3258 -- but we do this for the following reasons:
3260 -- a) The way that Determine_Range works, it will typically report
3261 -- the bounds of the value as being equal to the bounds of the
3262 -- type, because it either can't tell anything more precise, or
3263 -- does not think it is worth the effort to be more precise.
3265 -- b) It is very unusual to have a situation in which this would
3266 -- generate an unnecessary overflow check (an example would be
3267 -- a subtype with a range 0 .. Integer'Last - 1 to which the
3268 -- literal value one is added.
3270 -- c) The alternative is a lot of special casing in this routine
3271 -- which would partially duplicate Determine_Range processing.
3274 and then Lo > Expr_Value (Type_Low_Bound (Typ))
3275 and then Hi < Expr_Value (Type_High_Bound (Typ))
3277 if Debug_Flag_CC then
3278 w ("No overflow check required");
3285 -- If not in optimizing mode, set flag and we are done. We are also
3286 -- done (and just set the flag) if the type is not a discrete type,
3287 -- since it is not worth the effort to eliminate checks for other
3288 -- than discrete types. In addition, we take this same path if we
3289 -- have stored the maximum number of checks possible already (a
3290 -- very unlikely situation, but we do not want to blow up!)
3292 if Optimization_Level = 0
3293 or else not Is_Discrete_Type (Etype (N))
3294 or else Num_Saved_Checks = Saved_Checks'Last
3296 Set_Do_Overflow_Check (N, True);
3298 if Debug_Flag_CC then
3299 w ("Optimization off");
3305 -- Otherwise evaluate and check the expression
3310 Target_Type => Empty,
3316 if Debug_Flag_CC then
3317 w ("Called Find_Check");
3321 w (" Check_Num = ", Chk);
3322 w (" Ent = ", Int (Ent));
3323 Write_Str (" Ofs = ");
3328 -- If check is not of form to optimize, then set flag and we are done
3331 Set_Do_Overflow_Check (N, True);
3335 -- If check is already performed, then return without setting flag
3338 if Debug_Flag_CC then
3339 w ("Check suppressed!");
3345 -- Here we will make a new entry for the new check
3347 Set_Do_Overflow_Check (N, True);
3348 Num_Saved_Checks := Num_Saved_Checks + 1;
3349 Saved_Checks (Num_Saved_Checks) :=
3354 Target_Type => Empty);
3356 if Debug_Flag_CC then
3357 w ("Make new entry, check number = ", Num_Saved_Checks);
3358 w (" Entity = ", Int (Ent));
3359 Write_Str (" Offset = ");
3361 w (" Check_Type = O");
3362 w (" Target_Type = Empty");
3365 -- If we get an exception, then something went wrong, probably because
3366 -- of an error in the structure of the tree due to an incorrect program.
3367 -- Or it may be a bug in the optimization circuit. In either case the
3368 -- safest thing is simply to set the check flag unconditionally.
3372 Set_Do_Overflow_Check (N, True);
3374 if Debug_Flag_CC then
3375 w (" exception occurred, overflow flag set");
3379 end Enable_Overflow_Check;
3381 ------------------------
3382 -- Enable_Range_Check --
3383 ------------------------
3385 procedure Enable_Range_Check (N : Node_Id) is
3394 -- Return if unchecked type conversion with range check killed.
3395 -- In this case we never set the flag (that's what Kill_Range_Check
3398 if Nkind (N) = N_Unchecked_Type_Conversion
3399 and then Kill_Range_Check (N)
3404 -- Debug trace output
3406 if Debug_Flag_CC then
3407 w ("Enable_Range_Check for node ", Int (N));
3408 Write_Str (" Source location = ");
3413 -- If not in optimizing mode, set flag and we are done. We are also
3414 -- done (and just set the flag) if the type is not a discrete type,
3415 -- since it is not worth the effort to eliminate checks for other
3416 -- than discrete types. In addition, we take this same path if we
3417 -- have stored the maximum number of checks possible already (a
3418 -- very unlikely situation, but we do not want to blow up!)
3420 if Optimization_Level = 0
3421 or else No (Etype (N))
3422 or else not Is_Discrete_Type (Etype (N))
3423 or else Num_Saved_Checks = Saved_Checks'Last
3425 Set_Do_Range_Check (N, True);
3427 if Debug_Flag_CC then
3428 w ("Optimization off");
3434 -- Otherwise find out the target type
3438 -- For assignment, use left side subtype
3440 if Nkind (P) = N_Assignment_Statement
3441 and then Expression (P) = N
3443 Ttyp := Etype (Name (P));
3445 -- For indexed component, use subscript subtype
3447 elsif Nkind (P) = N_Indexed_Component then
3454 Atyp := Etype (Prefix (P));
3456 if Is_Access_Type (Atyp) then
3457 Atyp := Designated_Type (Atyp);
3459 -- If the prefix is an access to an unconstrained array,
3460 -- perform check unconditionally: it depends on the bounds
3461 -- of an object and we cannot currently recognize whether
3462 -- the test may be redundant.
3464 if not Is_Constrained (Atyp) then
3465 Set_Do_Range_Check (N, True);
3470 Indx := First_Index (Atyp);
3471 Subs := First (Expressions (P));
3474 Ttyp := Etype (Indx);
3483 -- For now, ignore all other cases, they are not so interesting
3486 if Debug_Flag_CC then
3487 w (" target type not found, flag set");
3490 Set_Do_Range_Check (N, True);
3494 -- Evaluate and check the expression
3499 Target_Type => Ttyp,
3505 if Debug_Flag_CC then
3506 w ("Called Find_Check");
3507 w ("Target_Typ = ", Int (Ttyp));
3511 w (" Check_Num = ", Chk);
3512 w (" Ent = ", Int (Ent));
3513 Write_Str (" Ofs = ");
3518 -- If check is not of form to optimize, then set flag and we are done
3521 if Debug_Flag_CC then
3522 w (" expression not of optimizable type, flag set");
3525 Set_Do_Range_Check (N, True);
3529 -- If check is already performed, then return without setting flag
3532 if Debug_Flag_CC then
3533 w ("Check suppressed!");
3539 -- Here we will make a new entry for the new check
3541 Set_Do_Range_Check (N, True);
3542 Num_Saved_Checks := Num_Saved_Checks + 1;
3543 Saved_Checks (Num_Saved_Checks) :=
3548 Target_Type => Ttyp);
3550 if Debug_Flag_CC then
3551 w ("Make new entry, check number = ", Num_Saved_Checks);
3552 w (" Entity = ", Int (Ent));
3553 Write_Str (" Offset = ");
3555 w (" Check_Type = R");
3556 w (" Target_Type = ", Int (Ttyp));
3560 -- If we get an exception, then something went wrong, probably because
3561 -- of an error in the structure of the tree due to an incorrect program.
3562 -- Or it may be a bug in the optimization circuit. In either case the
3563 -- safest thing is simply to set the check flag unconditionally.
3567 Set_Do_Range_Check (N, True);
3569 if Debug_Flag_CC then
3570 w (" exception occurred, range flag set");
3574 end Enable_Range_Check;
3580 procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False) is
3581 Typ : constant Entity_Id := Etype (Expr);
3584 -- Ignore call if we are not doing any validity checking
3586 if not Validity_Checks_On then
3589 -- Ignore call if range checks suppressed on entity in question
3591 elsif Is_Entity_Name (Expr)
3592 and then Range_Checks_Suppressed (Entity (Expr))
3596 -- No check required if expression is from the expander, we assume
3597 -- the expander will generate whatever checks are needed. Note that
3598 -- this is not just an optimization, it avoids infinite recursions!
3600 -- Unchecked conversions must be checked, unless they are initialized
3601 -- scalar values, as in a component assignment in an init proc.
3603 -- In addition, we force a check if Force_Validity_Checks is set
3605 elsif not Comes_From_Source (Expr)
3606 and then not Force_Validity_Checks
3607 and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
3608 or else Kill_Range_Check (Expr))
3612 -- No check required if expression is known to have valid value
3614 elsif Expr_Known_Valid (Expr) then
3617 -- No check required if checks off
3619 elsif Range_Checks_Suppressed (Typ) then
3622 -- Ignore case of enumeration with holes where the flag is set not
3623 -- to worry about holes, since no special validity check is needed
3625 elsif Is_Enumeration_Type (Typ)
3626 and then Has_Non_Standard_Rep (Typ)
3631 -- No check required on the left-hand side of an assignment.
3633 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
3634 and then Expr = Name (Parent (Expr))
3638 -- An annoying special case. If this is an out parameter of a scalar
3639 -- type, then the value is not going to be accessed, therefore it is
3640 -- inappropriate to do any validity check at the call site.
3643 -- Only need to worry about scalar types
3645 if Is_Scalar_Type (Typ) then
3655 -- Find actual argument (which may be a parameter association)
3656 -- and the parent of the actual argument (the call statement)
3661 if Nkind (P) = N_Parameter_Association then
3666 -- Only need to worry if we are argument of a procedure
3667 -- call since functions don't have out parameters. If this
3668 -- is an indirect or dispatching call, get signature from
3669 -- the subprogram type.
3671 if Nkind (P) = N_Procedure_Call_Statement then
3672 L := Parameter_Associations (P);
3674 if Is_Entity_Name (Name (P)) then
3675 E := Entity (Name (P));
3677 pragma Assert (Nkind (Name (P)) = N_Explicit_Dereference);
3678 E := Etype (Name (P));
3681 -- Only need to worry if there are indeed actuals, and
3682 -- if this could be a procedure call, otherwise we cannot
3683 -- get a match (either we are not an argument, or the
3684 -- mode of the formal is not OUT). This test also filters
3685 -- out the generic case.
3687 if Is_Non_Empty_List (L)
3688 and then Is_Subprogram (E)
3690 -- This is the loop through parameters, looking to
3691 -- see if there is an OUT parameter for which we are
3694 F := First_Formal (E);
3697 while Present (F) loop
3698 if Ekind (F) = E_Out_Parameter and then A = N then
3711 -- If we fall through, a validity check is required. Note that it would
3712 -- not be good to set Do_Range_Check, even in contexts where this is
3713 -- permissible, since this flag causes checking against the target type,
3714 -- not the source type in contexts such as assignments
3716 Insert_Valid_Check (Expr);
3719 ----------------------
3720 -- Expr_Known_Valid --
3721 ----------------------
3723 function Expr_Known_Valid (Expr : Node_Id) return Boolean is
3724 Typ : constant Entity_Id := Etype (Expr);
3727 -- Non-scalar types are always considered valid, since they never
3728 -- give rise to the issues of erroneous or bounded error behavior
3729 -- that are the concern. In formal reference manual terms the
3730 -- notion of validity only applies to scalar types. Note that
3731 -- even when packed arrays are represented using modular types,
3732 -- they are still arrays semantically, so they are also always
3733 -- valid (in particular, the unused bits can be random rubbish
3734 -- without affecting the validity of the array value).
3736 if not Is_Scalar_Type (Typ) or else Is_Packed_Array_Type (Typ) then
3739 -- If no validity checking, then everything is considered valid
3741 elsif not Validity_Checks_On then
3744 -- Floating-point types are considered valid unless floating-point
3745 -- validity checks have been specifically turned on.
3747 elsif Is_Floating_Point_Type (Typ)
3748 and then not Validity_Check_Floating_Point
3752 -- If the expression is the value of an object that is known to
3753 -- be valid, then clearly the expression value itself is valid.
3755 elsif Is_Entity_Name (Expr)
3756 and then Is_Known_Valid (Entity (Expr))
3760 -- If the type is one for which all values are known valid, then
3761 -- we are sure that the value is valid except in the slightly odd
3762 -- case where the expression is a reference to a variable whose size
3763 -- has been explicitly set to a value greater than the object size.
3765 elsif Is_Known_Valid (Typ) then
3766 if Is_Entity_Name (Expr)
3767 and then Ekind (Entity (Expr)) = E_Variable
3768 and then Esize (Entity (Expr)) > Esize (Typ)
3775 -- Integer and character literals always have valid values, where
3776 -- appropriate these will be range checked in any case.
3778 elsif Nkind (Expr) = N_Integer_Literal
3780 Nkind (Expr) = N_Character_Literal
3784 -- If we have a type conversion or a qualification of a known valid
3785 -- value, then the result will always be valid.
3787 elsif Nkind (Expr) = N_Type_Conversion
3789 Nkind (Expr) = N_Qualified_Expression
3791 return Expr_Known_Valid (Expression (Expr));
3793 -- The result of any function call or operator is always considered
3794 -- valid, since we assume the necessary checks are done by the call.
3795 -- For operators on floating-point operations, we must also check
3796 -- when the operation is the right-hand side of an assignment, or
3797 -- is an actual in a call.
3800 Nkind (Expr) in N_Binary_Op or else Nkind (Expr) in N_Unary_Op
3802 if Is_Floating_Point_Type (Typ)
3803 and then Validity_Check_Floating_Point
3805 (Nkind (Parent (Expr)) = N_Assignment_Statement
3806 or else Nkind (Parent (Expr)) = N_Function_Call
3807 or else Nkind (Parent (Expr)) = N_Parameter_Association)
3814 elsif Nkind (Expr) = N_Function_Call then
3817 -- For all other cases, we do not know the expression is valid
3822 end Expr_Known_Valid;
3828 procedure Find_Check
3830 Check_Type : Character;
3831 Target_Type : Entity_Id;
3832 Entry_OK : out Boolean;
3833 Check_Num : out Nat;
3834 Ent : out Entity_Id;
3837 function Within_Range_Of
3838 (Target_Type : Entity_Id;
3839 Check_Type : Entity_Id) return Boolean;
3840 -- Given a requirement for checking a range against Target_Type, and
3841 -- and a range Check_Type against which a check has already been made,
3842 -- determines if the check against check type is sufficient to ensure
3843 -- that no check against Target_Type is required.
3845 ---------------------
3846 -- Within_Range_Of --
3847 ---------------------
3849 function Within_Range_Of
3850 (Target_Type : Entity_Id;
3851 Check_Type : Entity_Id) return Boolean
3854 if Target_Type = Check_Type then
3859 Tlo : constant Node_Id := Type_Low_Bound (Target_Type);
3860 Thi : constant Node_Id := Type_High_Bound (Target_Type);
3861 Clo : constant Node_Id := Type_Low_Bound (Check_Type);
3862 Chi : constant Node_Id := Type_High_Bound (Check_Type);
3866 or else (Compile_Time_Known_Value (Tlo)
3868 Compile_Time_Known_Value (Clo)
3870 Expr_Value (Clo) >= Expr_Value (Tlo)))
3873 or else (Compile_Time_Known_Value (Thi)
3875 Compile_Time_Known_Value (Chi)
3877 Expr_Value (Chi) <= Expr_Value (Clo)))
3885 end Within_Range_Of;
3887 -- Start of processing for Find_Check
3890 -- Establish default, to avoid warnings from GCC.
3894 -- Case of expression is simple entity reference
3896 if Is_Entity_Name (Expr) then
3897 Ent := Entity (Expr);
3900 -- Case of expression is entity + known constant
3902 elsif Nkind (Expr) = N_Op_Add
3903 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3904 and then Is_Entity_Name (Left_Opnd (Expr))
3906 Ent := Entity (Left_Opnd (Expr));
3907 Ofs := Expr_Value (Right_Opnd (Expr));
3909 -- Case of expression is entity - known constant
3911 elsif Nkind (Expr) = N_Op_Subtract
3912 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3913 and then Is_Entity_Name (Left_Opnd (Expr))
3915 Ent := Entity (Left_Opnd (Expr));
3916 Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr)));
3918 -- Any other expression is not of the right form
3927 -- Come here with expression of appropriate form, check if
3928 -- entity is an appropriate one for our purposes.
3930 if (Ekind (Ent) = E_Variable
3932 Ekind (Ent) = E_Constant
3934 Ekind (Ent) = E_Loop_Parameter
3936 Ekind (Ent) = E_In_Parameter)
3937 and then not Is_Library_Level_Entity (Ent)
3945 -- See if there is matching check already
3947 for J in reverse 1 .. Num_Saved_Checks loop
3949 SC : Saved_Check renames Saved_Checks (J);
3952 if SC.Killed = False
3953 and then SC.Entity = Ent
3954 and then SC.Offset = Ofs
3955 and then SC.Check_Type = Check_Type
3956 and then Within_Range_Of (Target_Type, SC.Target_Type)
3964 -- If we fall through entry was not found
3970 ---------------------------------
3971 -- Generate_Discriminant_Check --
3972 ---------------------------------
3974 -- Note: the code for this procedure is derived from the
3975 -- emit_discriminant_check routine a-trans.c v1.659.
3977 procedure Generate_Discriminant_Check (N : Node_Id) is
3978 Loc : constant Source_Ptr := Sloc (N);
3979 Pref : constant Node_Id := Prefix (N);
3980 Sel : constant Node_Id := Selector_Name (N);
3982 Orig_Comp : constant Entity_Id :=
3983 Original_Record_Component (Entity (Sel));
3984 -- The original component to be checked
3986 Discr_Fct : constant Entity_Id :=
3987 Discriminant_Checking_Func (Orig_Comp);
3988 -- The discriminant checking function
3991 -- One discriminant to be checked in the type
3993 Real_Discr : Entity_Id;
3994 -- Actual discriminant in the call
3996 Pref_Type : Entity_Id;
3997 -- Type of relevant prefix (ignoring private/access stuff)
4000 -- List of arguments for function call
4003 -- Keep track of the formal corresponding to the actual we build
4004 -- for each discriminant, in order to be able to perform the
4005 -- necessary type conversions.
4008 -- Selected component reference for checking function argument
4011 Pref_Type := Etype (Pref);
4013 -- Force evaluation of the prefix, so that it does not get evaluated
4014 -- twice (once for the check, once for the actual reference). Such a
4015 -- double evaluation is always a potential source of inefficiency,
4016 -- and is functionally incorrect in the volatile case, or when the
4017 -- prefix may have side-effects. An entity or a component of an
4018 -- entity requires no evaluation.
4020 if Is_Entity_Name (Pref) then
4021 if Treat_As_Volatile (Entity (Pref)) then
4022 Force_Evaluation (Pref, Name_Req => True);
4025 elsif Treat_As_Volatile (Etype (Pref)) then
4026 Force_Evaluation (Pref, Name_Req => True);
4028 elsif Nkind (Pref) = N_Selected_Component
4029 and then Is_Entity_Name (Prefix (Pref))
4034 Force_Evaluation (Pref, Name_Req => True);
4037 -- For a tagged type, use the scope of the original component to
4038 -- obtain the type, because ???
4040 if Is_Tagged_Type (Scope (Orig_Comp)) then
4041 Pref_Type := Scope (Orig_Comp);
4043 -- For an untagged derived type, use the discriminants of the
4044 -- parent which have been renamed in the derivation, possibly
4045 -- by a one-to-many discriminant constraint.
4046 -- For non-tagged type, initially get the Etype of the prefix
4049 if Is_Derived_Type (Pref_Type)
4050 and then Number_Discriminants (Pref_Type) /=
4051 Number_Discriminants (Etype (Base_Type (Pref_Type)))
4053 Pref_Type := Etype (Base_Type (Pref_Type));
4057 -- We definitely should have a checking function, This routine should
4058 -- not be called if no discriminant checking function is present.
4060 pragma Assert (Present (Discr_Fct));
4062 -- Create the list of the actual parameters for the call. This list
4063 -- is the list of the discriminant fields of the record expression to
4064 -- be discriminant checked.
4067 Formal := First_Formal (Discr_Fct);
4068 Discr := First_Discriminant (Pref_Type);
4069 while Present (Discr) loop
4071 -- If we have a corresponding discriminant field, and a parent
4072 -- subtype is present, then we want to use the corresponding
4073 -- discriminant since this is the one with the useful value.
4075 if Present (Corresponding_Discriminant (Discr))
4076 and then Ekind (Pref_Type) = E_Record_Type
4077 and then Present (Parent_Subtype (Pref_Type))
4079 Real_Discr := Corresponding_Discriminant (Discr);
4081 Real_Discr := Discr;
4084 -- Construct the reference to the discriminant
4087 Make_Selected_Component (Loc,
4089 Unchecked_Convert_To (Pref_Type,
4090 Duplicate_Subexpr (Pref)),
4091 Selector_Name => New_Occurrence_Of (Real_Discr, Loc));
4093 -- Manually analyze and resolve this selected component. We really
4094 -- want it just as it appears above, and do not want the expander
4095 -- playing discriminal games etc with this reference. Then we
4096 -- append the argument to the list we are gathering.
4098 Set_Etype (Scomp, Etype (Real_Discr));
4099 Set_Analyzed (Scomp, True);
4100 Append_To (Args, Convert_To (Etype (Formal), Scomp));
4102 Next_Formal_With_Extras (Formal);
4103 Next_Discriminant (Discr);
4106 -- Now build and insert the call
4109 Make_Raise_Constraint_Error (Loc,
4111 Make_Function_Call (Loc,
4112 Name => New_Occurrence_Of (Discr_Fct, Loc),
4113 Parameter_Associations => Args),
4114 Reason => CE_Discriminant_Check_Failed));
4115 end Generate_Discriminant_Check;
4117 ---------------------------
4118 -- Generate_Index_Checks --
4119 ---------------------------
4121 procedure Generate_Index_Checks (N : Node_Id) is
4122 Loc : constant Source_Ptr := Sloc (N);
4123 A : constant Node_Id := Prefix (N);
4129 Sub := First (Expressions (N));
4131 while Present (Sub) loop
4132 if Do_Range_Check (Sub) then
4133 Set_Do_Range_Check (Sub, False);
4135 -- Force evaluation except for the case of a simple name of
4136 -- a non-volatile entity.
4138 if not Is_Entity_Name (Sub)
4139 or else Treat_As_Volatile (Entity (Sub))
4141 Force_Evaluation (Sub);
4144 -- Generate a raise of constraint error with the appropriate
4145 -- reason and a condition of the form:
4147 -- Base_Type(Sub) not in array'range (subscript)
4149 -- Note that the reason we generate the conversion to the
4150 -- base type here is that we definitely want the range check
4151 -- to take place, even if it looks like the subtype is OK.
4152 -- Optimization considerations that allow us to omit the
4153 -- check have already been taken into account in the setting
4154 -- of the Do_Range_Check flag earlier on.
4159 Num := New_List (Make_Integer_Literal (Loc, Ind));
4163 Make_Raise_Constraint_Error (Loc,
4167 Convert_To (Base_Type (Etype (Sub)),
4168 Duplicate_Subexpr_Move_Checks (Sub)),
4170 Make_Attribute_Reference (Loc,
4171 Prefix => Duplicate_Subexpr_Move_Checks (A),
4172 Attribute_Name => Name_Range,
4173 Expressions => Num)),
4174 Reason => CE_Index_Check_Failed));
4180 end Generate_Index_Checks;
4182 --------------------------
4183 -- Generate_Range_Check --
4184 --------------------------
4186 procedure Generate_Range_Check
4188 Target_Type : Entity_Id;
4189 Reason : RT_Exception_Code)
4191 Loc : constant Source_Ptr := Sloc (N);
4192 Source_Type : constant Entity_Id := Etype (N);
4193 Source_Base_Type : constant Entity_Id := Base_Type (Source_Type);
4194 Target_Base_Type : constant Entity_Id := Base_Type (Target_Type);
4197 -- First special case, if the source type is already within the
4198 -- range of the target type, then no check is needed (probably we
4199 -- should have stopped Do_Range_Check from being set in the first
4200 -- place, but better late than later in preventing junk code!
4202 -- We do NOT apply this if the source node is a literal, since in
4203 -- this case the literal has already been labeled as having the
4204 -- subtype of the target.
4206 if In_Subrange_Of (Source_Type, Target_Type)
4208 (Nkind (N) = N_Integer_Literal
4210 Nkind (N) = N_Real_Literal
4212 Nkind (N) = N_Character_Literal
4215 and then Ekind (Entity (N)) = E_Enumeration_Literal))
4220 -- We need a check, so force evaluation of the node, so that it does
4221 -- not get evaluated twice (once for the check, once for the actual
4222 -- reference). Such a double evaluation is always a potential source
4223 -- of inefficiency, and is functionally incorrect in the volatile case.
4225 if not Is_Entity_Name (N)
4226 or else Treat_As_Volatile (Entity (N))
4228 Force_Evaluation (N);
4231 -- The easiest case is when Source_Base_Type and Target_Base_Type
4232 -- are the same since in this case we can simply do a direct
4233 -- check of the value of N against the bounds of Target_Type.
4235 -- [constraint_error when N not in Target_Type]
4237 -- Note: this is by far the most common case, for example all cases of
4238 -- checks on the RHS of assignments are in this category, but not all
4239 -- cases are like this. Notably conversions can involve two types.
4241 if Source_Base_Type = Target_Base_Type then
4243 Make_Raise_Constraint_Error (Loc,
4246 Left_Opnd => Duplicate_Subexpr (N),
4247 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
4250 -- Next test for the case where the target type is within the bounds
4251 -- of the base type of the source type, since in this case we can
4252 -- simply convert these bounds to the base type of T to do the test.
4254 -- [constraint_error when N not in
4255 -- Source_Base_Type (Target_Type'First)
4257 -- Source_Base_Type(Target_Type'Last))]
4259 -- The conversions will always work and need no check.
4261 elsif In_Subrange_Of (Target_Type, Source_Base_Type) then
4263 Make_Raise_Constraint_Error (Loc,
4266 Left_Opnd => Duplicate_Subexpr (N),
4271 Convert_To (Source_Base_Type,
4272 Make_Attribute_Reference (Loc,
4274 New_Occurrence_Of (Target_Type, Loc),
4275 Attribute_Name => Name_First)),
4278 Convert_To (Source_Base_Type,
4279 Make_Attribute_Reference (Loc,
4281 New_Occurrence_Of (Target_Type, Loc),
4282 Attribute_Name => Name_Last)))),
4285 -- Note that at this stage we now that the Target_Base_Type is
4286 -- not in the range of the Source_Base_Type (since even the
4287 -- Target_Type itself is not in this range). It could still be
4288 -- the case that the Source_Type is in range of the target base
4289 -- type, since we have not checked that case.
4291 -- If that is the case, we can freely convert the source to the
4292 -- target, and then test the target result against the bounds.
4294 elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
4296 -- We make a temporary to hold the value of the converted
4297 -- value (converted to the base type), and then we will
4298 -- do the test against this temporary.
4300 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
4301 -- [constraint_error when Tnn not in Target_Type]
4303 -- Then the conversion itself is replaced by an occurrence of Tnn
4306 Tnn : constant Entity_Id :=
4307 Make_Defining_Identifier (Loc,
4308 Chars => New_Internal_Name ('T'));
4311 Insert_Actions (N, New_List (
4312 Make_Object_Declaration (Loc,
4313 Defining_Identifier => Tnn,
4314 Object_Definition =>
4315 New_Occurrence_Of (Target_Base_Type, Loc),
4316 Constant_Present => True,
4318 Make_Type_Conversion (Loc,
4319 Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
4320 Expression => Duplicate_Subexpr (N))),
4322 Make_Raise_Constraint_Error (Loc,
4325 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
4326 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
4328 Reason => Reason)));
4330 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
4333 -- At this stage, we know that we have two scalar types, which are
4334 -- directly convertible, and where neither scalar type has a base
4335 -- range that is in the range of the other scalar type.
4337 -- The only way this can happen is with a signed and unsigned type.
4338 -- So test for these two cases:
4341 -- Case of the source is unsigned and the target is signed
4343 if Is_Unsigned_Type (Source_Base_Type)
4344 and then not Is_Unsigned_Type (Target_Base_Type)
4346 -- If the source is unsigned and the target is signed, then we
4347 -- know that the source is not shorter than the target (otherwise
4348 -- the source base type would be in the target base type range).
4350 -- In other words, the unsigned type is either the same size
4351 -- as the target, or it is larger. It cannot be smaller.
4354 (Esize (Source_Base_Type) >= Esize (Target_Base_Type));
4356 -- We only need to check the low bound if the low bound of the
4357 -- target type is non-negative. If the low bound of the target
4358 -- type is negative, then we know that we will fit fine.
4360 -- If the high bound of the target type is negative, then we
4361 -- know we have a constraint error, since we can't possibly
4362 -- have a negative source.
4364 -- With these two checks out of the way, we can do the check
4365 -- using the source type safely
4367 -- This is definitely the most annoying case!
4369 -- [constraint_error
4370 -- when (Target_Type'First >= 0
4372 -- N < Source_Base_Type (Target_Type'First))
4373 -- or else Target_Type'Last < 0
4374 -- or else N > Source_Base_Type (Target_Type'Last)];
4376 -- We turn off all checks since we know that the conversions
4377 -- will work fine, given the guards for negative values.
4380 Make_Raise_Constraint_Error (Loc,
4386 Left_Opnd => Make_Op_Ge (Loc,
4388 Make_Attribute_Reference (Loc,
4390 New_Occurrence_Of (Target_Type, Loc),
4391 Attribute_Name => Name_First),
4392 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
4396 Left_Opnd => Duplicate_Subexpr (N),
4398 Convert_To (Source_Base_Type,
4399 Make_Attribute_Reference (Loc,
4401 New_Occurrence_Of (Target_Type, Loc),
4402 Attribute_Name => Name_First)))),
4407 Make_Attribute_Reference (Loc,
4408 Prefix => New_Occurrence_Of (Target_Type, Loc),
4409 Attribute_Name => Name_Last),
4410 Right_Opnd => Make_Integer_Literal (Loc, Uint_0))),
4414 Left_Opnd => Duplicate_Subexpr (N),
4416 Convert_To (Source_Base_Type,
4417 Make_Attribute_Reference (Loc,
4418 Prefix => New_Occurrence_Of (Target_Type, Loc),
4419 Attribute_Name => Name_Last)))),
4422 Suppress => All_Checks);
4424 -- Only remaining possibility is that the source is signed and
4425 -- the target is unsigned
4428 pragma Assert (not Is_Unsigned_Type (Source_Base_Type)
4429 and then Is_Unsigned_Type (Target_Base_Type));
4431 -- If the source is signed and the target is unsigned, then
4432 -- we know that the target is not shorter than the source
4433 -- (otherwise the target base type would be in the source
4434 -- base type range).
4436 -- In other words, the unsigned type is either the same size
4437 -- as the target, or it is larger. It cannot be smaller.
4439 -- Clearly we have an error if the source value is negative
4440 -- since no unsigned type can have negative values. If the
4441 -- source type is non-negative, then the check can be done
4442 -- using the target type.
4444 -- Tnn : constant Target_Base_Type (N) := Target_Type;
4446 -- [constraint_error
4447 -- when N < 0 or else Tnn not in Target_Type];
4449 -- We turn off all checks for the conversion of N to the
4450 -- target base type, since we generate the explicit check
4451 -- to ensure that the value is non-negative
4454 Tnn : constant Entity_Id :=
4455 Make_Defining_Identifier (Loc,
4456 Chars => New_Internal_Name ('T'));
4459 Insert_Actions (N, New_List (
4460 Make_Object_Declaration (Loc,
4461 Defining_Identifier => Tnn,
4462 Object_Definition =>
4463 New_Occurrence_Of (Target_Base_Type, Loc),
4464 Constant_Present => True,
4466 Make_Type_Conversion (Loc,
4468 New_Occurrence_Of (Target_Base_Type, Loc),
4469 Expression => Duplicate_Subexpr (N))),
4471 Make_Raise_Constraint_Error (Loc,
4476 Left_Opnd => Duplicate_Subexpr (N),
4477 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
4481 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
4483 New_Occurrence_Of (Target_Type, Loc))),
4486 Suppress => All_Checks);
4488 -- Set the Etype explicitly, because Insert_Actions may
4489 -- have placed the declaration in the freeze list for an
4490 -- enclosing construct, and thus it is not analyzed yet.
4492 Set_Etype (Tnn, Target_Base_Type);
4493 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
4497 end Generate_Range_Check;
4499 ---------------------
4500 -- Get_Discriminal --
4501 ---------------------
4503 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is
4504 Loc : constant Source_Ptr := Sloc (E);
4509 -- The entity E is the type of a private component of the protected
4510 -- type, or the type of a renaming of that component within a protected
4511 -- operation of that type.
4515 if Ekind (Sc) /= E_Protected_Type then
4518 if Ekind (Sc) /= E_Protected_Type then
4523 D := First_Discriminant (Sc);
4526 and then Chars (D) /= Chars (Bound)
4528 Next_Discriminant (D);
4531 return New_Occurrence_Of (Discriminal (D), Loc);
4532 end Get_Discriminal;
4538 function Guard_Access
4541 Ck_Node : Node_Id) return Node_Id
4544 if Nkind (Cond) = N_Or_Else then
4545 Set_Paren_Count (Cond, 1);
4548 if Nkind (Ck_Node) = N_Allocator then
4555 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
4556 Right_Opnd => Make_Null (Loc)),
4557 Right_Opnd => Cond);
4561 -----------------------------
4562 -- Index_Checks_Suppressed --
4563 -----------------------------
4565 function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
4567 if Present (E) and then Checks_May_Be_Suppressed (E) then
4568 return Is_Check_Suppressed (E, Index_Check);
4570 return Scope_Suppress (Index_Check);
4572 end Index_Checks_Suppressed;
4578 procedure Initialize is
4580 for J in Determine_Range_Cache_N'Range loop
4581 Determine_Range_Cache_N (J) := Empty;
4585 -------------------------
4586 -- Insert_Range_Checks --
4587 -------------------------
4589 procedure Insert_Range_Checks
4590 (Checks : Check_Result;
4592 Suppress_Typ : Entity_Id;
4593 Static_Sloc : Source_Ptr := No_Location;
4594 Flag_Node : Node_Id := Empty;
4595 Do_Before : Boolean := False)
4597 Internal_Flag_Node : Node_Id := Flag_Node;
4598 Internal_Static_Sloc : Source_Ptr := Static_Sloc;
4600 Check_Node : Node_Id;
4601 Checks_On : constant Boolean :=
4602 (not Index_Checks_Suppressed (Suppress_Typ))
4604 (not Range_Checks_Suppressed (Suppress_Typ));
4607 -- For now we just return if Checks_On is false, however this should
4608 -- be enhanced to check for an always True value in the condition
4609 -- and to generate a compilation warning???
4611 if not Expander_Active or else not Checks_On then
4615 if Static_Sloc = No_Location then
4616 Internal_Static_Sloc := Sloc (Node);
4619 if No (Flag_Node) then
4620 Internal_Flag_Node := Node;
4623 for J in 1 .. 2 loop
4624 exit when No (Checks (J));
4626 if Nkind (Checks (J)) = N_Raise_Constraint_Error
4627 and then Present (Condition (Checks (J)))
4629 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
4630 Check_Node := Checks (J);
4631 Mark_Rewrite_Insertion (Check_Node);
4634 Insert_Before_And_Analyze (Node, Check_Node);
4636 Insert_After_And_Analyze (Node, Check_Node);
4639 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
4644 Make_Raise_Constraint_Error (Internal_Static_Sloc,
4645 Reason => CE_Range_Check_Failed);
4646 Mark_Rewrite_Insertion (Check_Node);
4649 Insert_Before_And_Analyze (Node, Check_Node);
4651 Insert_After_And_Analyze (Node, Check_Node);
4655 end Insert_Range_Checks;
4657 ------------------------
4658 -- Insert_Valid_Check --
4659 ------------------------
4661 procedure Insert_Valid_Check (Expr : Node_Id) is
4662 Loc : constant Source_Ptr := Sloc (Expr);
4666 -- Do not insert if checks off, or if not checking validity
4668 if Range_Checks_Suppressed (Etype (Expr))
4669 or else (not Validity_Checks_On)
4674 -- If we have a checked conversion, then validity check applies to
4675 -- the expression inside the conversion, not the result, since if
4676 -- the expression inside is valid, then so is the conversion result.
4679 while Nkind (Exp) = N_Type_Conversion loop
4680 Exp := Expression (Exp);
4683 -- Insert the validity check. Note that we do this with validity
4684 -- checks turned off, to avoid recursion, we do not want validity
4685 -- checks on the validity checking code itself!
4687 Validity_Checks_On := False;
4690 Make_Raise_Constraint_Error (Loc,
4694 Make_Attribute_Reference (Loc,
4696 Duplicate_Subexpr_No_Checks (Exp, Name_Req => True),
4697 Attribute_Name => Name_Valid)),
4698 Reason => CE_Invalid_Data),
4699 Suppress => All_Checks);
4700 Validity_Checks_On := True;
4701 end Insert_Valid_Check;
4703 ----------------------------------
4704 -- Install_Null_Excluding_Check --
4705 ----------------------------------
4707 procedure Install_Null_Excluding_Check (N : Node_Id) is
4708 Loc : constant Source_Ptr := Sloc (N);
4709 Etyp : constant Entity_Id := Etype (N);
4712 pragma Assert (Is_Access_Type (Etyp));
4714 -- Don't need access check if: 1) we are analyzing a generic, 2) it is
4715 -- known to be non-null, or 3) the check was suppressed on the type
4718 or else Access_Checks_Suppressed (Etyp)
4722 -- Otherwise install access check
4726 Make_Raise_Constraint_Error (Loc,
4729 Left_Opnd => Duplicate_Subexpr_Move_Checks (N),
4730 Right_Opnd => Make_Null (Loc)),
4731 Reason => CE_Access_Check_Failed));
4733 end Install_Null_Excluding_Check;
4735 --------------------------
4736 -- Install_Static_Check --
4737 --------------------------
4739 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
4740 Stat : constant Boolean := Is_Static_Expression (R_Cno);
4741 Typ : constant Entity_Id := Etype (R_Cno);
4745 Make_Raise_Constraint_Error (Loc,
4746 Reason => CE_Range_Check_Failed));
4747 Set_Analyzed (R_Cno);
4748 Set_Etype (R_Cno, Typ);
4749 Set_Raises_Constraint_Error (R_Cno);
4750 Set_Is_Static_Expression (R_Cno, Stat);
4751 end Install_Static_Check;
4753 ---------------------
4754 -- Kill_All_Checks --
4755 ---------------------
4757 procedure Kill_All_Checks is
4759 if Debug_Flag_CC then
4760 w ("Kill_All_Checks");
4763 -- We reset the number of saved checks to zero, and also modify
4764 -- all stack entries for statement ranges to indicate that the
4765 -- number of checks at each level is now zero.
4767 Num_Saved_Checks := 0;
4769 for J in 1 .. Saved_Checks_TOS loop
4770 Saved_Checks_Stack (J) := 0;
4772 end Kill_All_Checks;
4778 procedure Kill_Checks (V : Entity_Id) is
4780 if Debug_Flag_CC then
4781 w ("Kill_Checks for entity", Int (V));
4784 for J in 1 .. Num_Saved_Checks loop
4785 if Saved_Checks (J).Entity = V then
4786 if Debug_Flag_CC then
4787 w (" Checks killed for saved check ", J);
4790 Saved_Checks (J).Killed := True;
4795 ------------------------------
4796 -- Length_Checks_Suppressed --
4797 ------------------------------
4799 function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
4801 if Present (E) and then Checks_May_Be_Suppressed (E) then
4802 return Is_Check_Suppressed (E, Length_Check);
4804 return Scope_Suppress (Length_Check);
4806 end Length_Checks_Suppressed;
4808 --------------------------------
4809 -- Overflow_Checks_Suppressed --
4810 --------------------------------
4812 function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
4814 if Present (E) and then Checks_May_Be_Suppressed (E) then
4815 return Is_Check_Suppressed (E, Overflow_Check);
4817 return Scope_Suppress (Overflow_Check);
4819 end Overflow_Checks_Suppressed;
4825 function Range_Check
4827 Target_Typ : Entity_Id;
4828 Source_Typ : Entity_Id := Empty;
4829 Warn_Node : Node_Id := Empty) return Check_Result
4832 return Selected_Range_Checks
4833 (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
4836 -----------------------------
4837 -- Range_Checks_Suppressed --
4838 -----------------------------
4840 function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
4844 -- Note: for now we always suppress range checks on Vax float types,
4845 -- since Gigi does not know how to generate these checks.
4847 if Vax_Float (E) then
4849 elsif Kill_Range_Checks (E) then
4851 elsif Checks_May_Be_Suppressed (E) then
4852 return Is_Check_Suppressed (E, Range_Check);
4856 return Scope_Suppress (Range_Check);
4857 end Range_Checks_Suppressed;
4863 procedure Remove_Checks (Expr : Node_Id) is
4864 Discard : Traverse_Result;
4865 pragma Warnings (Off, Discard);
4867 function Process (N : Node_Id) return Traverse_Result;
4868 -- Process a single node during the traversal
4870 function Traverse is new Traverse_Func (Process);
4871 -- The traversal function itself
4877 function Process (N : Node_Id) return Traverse_Result is
4879 if Nkind (N) not in N_Subexpr then
4883 Set_Do_Range_Check (N, False);
4887 Discard := Traverse (Left_Opnd (N));
4890 when N_Attribute_Reference =>
4891 Set_Do_Overflow_Check (N, False);
4893 when N_Function_Call =>
4894 Set_Do_Tag_Check (N, False);
4897 Set_Do_Overflow_Check (N, False);
4901 Set_Do_Division_Check (N, False);
4904 Set_Do_Length_Check (N, False);
4907 Set_Do_Division_Check (N, False);
4910 Set_Do_Length_Check (N, False);
4913 Set_Do_Division_Check (N, False);
4916 Set_Do_Length_Check (N, False);
4923 Discard := Traverse (Left_Opnd (N));
4926 when N_Selected_Component =>
4927 Set_Do_Discriminant_Check (N, False);
4929 when N_Type_Conversion =>
4930 Set_Do_Length_Check (N, False);
4931 Set_Do_Tag_Check (N, False);
4932 Set_Do_Overflow_Check (N, False);
4941 -- Start of processing for Remove_Checks
4944 Discard := Traverse (Expr);
4947 ----------------------------
4948 -- Selected_Length_Checks --
4949 ----------------------------
4951 function Selected_Length_Checks
4953 Target_Typ : Entity_Id;
4954 Source_Typ : Entity_Id;
4955 Warn_Node : Node_Id) return Check_Result
4957 Loc : constant Source_Ptr := Sloc (Ck_Node);
4960 Expr_Actual : Node_Id;
4962 Cond : Node_Id := Empty;
4963 Do_Access : Boolean := False;
4964 Wnode : Node_Id := Warn_Node;
4965 Ret_Result : Check_Result := (Empty, Empty);
4966 Num_Checks : Natural := 0;
4968 procedure Add_Check (N : Node_Id);
4969 -- Adds the action given to Ret_Result if N is non-Empty
4971 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
4972 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
4973 -- Comments required ???
4975 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
4976 -- True for equal literals and for nodes that denote the same constant
4977 -- entity, even if its value is not a static constant. This includes the
4978 -- case of a discriminal reference within an init proc. Removes some
4979 -- obviously superfluous checks.
4981 function Length_E_Cond
4982 (Exptyp : Entity_Id;
4984 Indx : Nat) return Node_Id;
4985 -- Returns expression to compute:
4986 -- Typ'Length /= Exptyp'Length
4988 function Length_N_Cond
4991 Indx : Nat) return Node_Id;
4992 -- Returns expression to compute:
4993 -- Typ'Length /= Expr'Length
4999 procedure Add_Check (N : Node_Id) is
5003 -- For now, ignore attempt to place more than 2 checks ???
5005 if Num_Checks = 2 then
5009 pragma Assert (Num_Checks <= 1);
5010 Num_Checks := Num_Checks + 1;
5011 Ret_Result (Num_Checks) := N;
5019 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
5020 Pt : constant Entity_Id := Scope (Scope (E));
5022 E1 : Entity_Id := E;
5025 if Ekind (Scope (E)) = E_Record_Type
5026 and then Has_Discriminants (Scope (E))
5028 N := Build_Discriminal_Subtype_Of_Component (E);
5031 Insert_Action (Ck_Node, N);
5032 E1 := Defining_Identifier (N);
5036 if Ekind (E1) = E_String_Literal_Subtype then
5038 Make_Integer_Literal (Loc,
5039 Intval => String_Literal_Length (E1));
5041 elsif Ekind (Pt) = E_Protected_Type
5042 and then Has_Discriminants (Pt)
5043 and then Has_Completion (Pt)
5044 and then not Inside_Init_Proc
5047 -- If the type whose length is needed is a private component
5048 -- constrained by a discriminant, we must expand the 'Length
5049 -- attribute into an explicit computation, using the discriminal
5050 -- of the current protected operation. This is because the actual
5051 -- type of the prival is constructed after the protected opera-
5052 -- tion has been fully expanded.
5055 Indx_Type : Node_Id;
5058 Do_Expand : Boolean := False;
5061 Indx_Type := First_Index (E);
5063 for J in 1 .. Indx - 1 loop
5064 Next_Index (Indx_Type);
5067 Get_Index_Bounds (Indx_Type, Lo, Hi);
5069 if Nkind (Lo) = N_Identifier
5070 and then Ekind (Entity (Lo)) = E_In_Parameter
5072 Lo := Get_Discriminal (E, Lo);
5076 if Nkind (Hi) = N_Identifier
5077 and then Ekind (Entity (Hi)) = E_In_Parameter
5079 Hi := Get_Discriminal (E, Hi);
5084 if not Is_Entity_Name (Lo) then
5085 Lo := Duplicate_Subexpr_No_Checks (Lo);
5088 if not Is_Entity_Name (Hi) then
5089 Lo := Duplicate_Subexpr_No_Checks (Hi);
5095 Make_Op_Subtract (Loc,
5099 Right_Opnd => Make_Integer_Literal (Loc, 1));
5104 Make_Attribute_Reference (Loc,
5105 Attribute_Name => Name_Length,
5107 New_Occurrence_Of (E1, Loc));
5110 Set_Expressions (N, New_List (
5111 Make_Integer_Literal (Loc, Indx)));
5120 Make_Attribute_Reference (Loc,
5121 Attribute_Name => Name_Length,
5123 New_Occurrence_Of (E1, Loc));
5126 Set_Expressions (N, New_List (
5127 Make_Integer_Literal (Loc, Indx)));
5139 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is
5142 Make_Attribute_Reference (Loc,
5143 Attribute_Name => Name_Length,
5145 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
5146 Expressions => New_List (
5147 Make_Integer_Literal (Loc, Indx)));
5155 function Length_E_Cond
5156 (Exptyp : Entity_Id;
5158 Indx : Nat) return Node_Id
5163 Left_Opnd => Get_E_Length (Typ, Indx),
5164 Right_Opnd => Get_E_Length (Exptyp, Indx));
5172 function Length_N_Cond
5175 Indx : Nat) return Node_Id
5180 Left_Opnd => Get_E_Length (Typ, Indx),
5181 Right_Opnd => Get_N_Length (Expr, Indx));
5185 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is
5188 (Nkind (L) = N_Integer_Literal
5189 and then Nkind (R) = N_Integer_Literal
5190 and then Intval (L) = Intval (R))
5194 and then Ekind (Entity (L)) = E_Constant
5195 and then ((Is_Entity_Name (R)
5196 and then Entity (L) = Entity (R))
5198 (Nkind (R) = N_Type_Conversion
5199 and then Is_Entity_Name (Expression (R))
5200 and then Entity (L) = Entity (Expression (R)))))
5204 and then Ekind (Entity (R)) = E_Constant
5205 and then Nkind (L) = N_Type_Conversion
5206 and then Is_Entity_Name (Expression (L))
5207 and then Entity (R) = Entity (Expression (L)))
5211 and then Is_Entity_Name (R)
5212 and then Entity (L) = Entity (R)
5213 and then Ekind (Entity (L)) = E_In_Parameter
5214 and then Inside_Init_Proc);
5217 -- Start of processing for Selected_Length_Checks
5220 if not Expander_Active then
5224 if Target_Typ = Any_Type
5225 or else Target_Typ = Any_Composite
5226 or else Raises_Constraint_Error (Ck_Node)
5235 T_Typ := Target_Typ;
5237 if No (Source_Typ) then
5238 S_Typ := Etype (Ck_Node);
5240 S_Typ := Source_Typ;
5243 if S_Typ = Any_Type or else S_Typ = Any_Composite then
5247 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
5248 S_Typ := Designated_Type (S_Typ);
5249 T_Typ := Designated_Type (T_Typ);
5252 -- A simple optimization
5254 if Nkind (Ck_Node) = N_Null then
5259 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
5260 if Is_Constrained (T_Typ) then
5262 -- The checking code to be generated will freeze the
5263 -- corresponding array type. However, we must freeze the
5264 -- type now, so that the freeze node does not appear within
5265 -- the generated condional expression, but ahead of it.
5267 Freeze_Before (Ck_Node, T_Typ);
5269 Expr_Actual := Get_Referenced_Object (Ck_Node);
5270 Exptyp := Get_Actual_Subtype (Expr_Actual);
5272 if Is_Access_Type (Exptyp) then
5273 Exptyp := Designated_Type (Exptyp);
5276 -- String_Literal case. This needs to be handled specially be-
5277 -- cause no index types are available for string literals. The
5278 -- condition is simply:
5280 -- T_Typ'Length = string-literal-length
5282 if Nkind (Expr_Actual) = N_String_Literal
5283 and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype
5287 Left_Opnd => Get_E_Length (T_Typ, 1),
5289 Make_Integer_Literal (Loc,
5291 String_Literal_Length (Etype (Expr_Actual))));
5293 -- General array case. Here we have a usable actual subtype for
5294 -- the expression, and the condition is built from the two types
5297 -- T_Typ'Length /= Exptyp'Length or else
5298 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
5299 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
5302 elsif Is_Constrained (Exptyp) then
5304 Ndims : constant Nat := Number_Dimensions (T_Typ);
5318 -- At the library level, we need to ensure that the
5319 -- type of the object is elaborated before the check
5320 -- itself is emitted. This is only done if the object
5321 -- is in the current compilation unit, otherwise the
5322 -- type is frozen and elaborated in its unit.
5324 if Is_Itype (Exptyp)
5326 Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package
5328 not In_Package_Body (Cunit_Entity (Current_Sem_Unit))
5329 and then In_Open_Scopes (Scope (Exptyp))
5331 Ref_Node := Make_Itype_Reference (Sloc (Ck_Node));
5332 Set_Itype (Ref_Node, Exptyp);
5333 Insert_Action (Ck_Node, Ref_Node);
5336 L_Index := First_Index (T_Typ);
5337 R_Index := First_Index (Exptyp);
5339 for Indx in 1 .. Ndims loop
5340 if not (Nkind (L_Index) = N_Raise_Constraint_Error
5342 Nkind (R_Index) = N_Raise_Constraint_Error)
5344 Get_Index_Bounds (L_Index, L_Low, L_High);
5345 Get_Index_Bounds (R_Index, R_Low, R_High);
5347 -- Deal with compile time length check. Note that we
5348 -- skip this in the access case, because the access
5349 -- value may be null, so we cannot know statically.
5352 and then Compile_Time_Known_Value (L_Low)
5353 and then Compile_Time_Known_Value (L_High)
5354 and then Compile_Time_Known_Value (R_Low)
5355 and then Compile_Time_Known_Value (R_High)
5357 if Expr_Value (L_High) >= Expr_Value (L_Low) then
5358 L_Length := Expr_Value (L_High) -
5359 Expr_Value (L_Low) + 1;
5361 L_Length := UI_From_Int (0);
5364 if Expr_Value (R_High) >= Expr_Value (R_Low) then
5365 R_Length := Expr_Value (R_High) -
5366 Expr_Value (R_Low) + 1;
5368 R_Length := UI_From_Int (0);
5371 if L_Length > R_Length then
5373 (Compile_Time_Constraint_Error
5374 (Wnode, "too few elements for}?", T_Typ));
5376 elsif L_Length < R_Length then
5378 (Compile_Time_Constraint_Error
5379 (Wnode, "too many elements for}?", T_Typ));
5382 -- The comparison for an individual index subtype
5383 -- is omitted if the corresponding index subtypes
5384 -- statically match, since the result is known to
5385 -- be true. Note that this test is worth while even
5386 -- though we do static evaluation, because non-static
5387 -- subtypes can statically match.
5390 Subtypes_Statically_Match
5391 (Etype (L_Index), Etype (R_Index))
5394 (Same_Bounds (L_Low, R_Low)
5395 and then Same_Bounds (L_High, R_High))
5398 (Cond, Length_E_Cond (Exptyp, T_Typ, Indx));
5407 -- Handle cases where we do not get a usable actual subtype that
5408 -- is constrained. This happens for example in the function call
5409 -- and explicit dereference cases. In these cases, we have to get
5410 -- the length or range from the expression itself, making sure we
5411 -- do not evaluate it more than once.
5413 -- Here Ck_Node is the original expression, or more properly the
5414 -- result of applying Duplicate_Expr to the original tree,
5415 -- forcing the result to be a name.
5419 Ndims : constant Nat := Number_Dimensions (T_Typ);
5422 -- Build the condition for the explicit dereference case
5424 for Indx in 1 .. Ndims loop
5426 (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx));
5433 -- Construct the test and insert into the tree
5435 if Present (Cond) then
5437 Cond := Guard_Access (Cond, Loc, Ck_Node);
5441 (Make_Raise_Constraint_Error (Loc,
5443 Reason => CE_Length_Check_Failed));
5447 end Selected_Length_Checks;
5449 ---------------------------
5450 -- Selected_Range_Checks --
5451 ---------------------------
5453 function Selected_Range_Checks
5455 Target_Typ : Entity_Id;
5456 Source_Typ : Entity_Id;
5457 Warn_Node : Node_Id) return Check_Result
5459 Loc : constant Source_Ptr := Sloc (Ck_Node);
5462 Expr_Actual : Node_Id;
5464 Cond : Node_Id := Empty;
5465 Do_Access : Boolean := False;
5466 Wnode : Node_Id := Warn_Node;
5467 Ret_Result : Check_Result := (Empty, Empty);
5468 Num_Checks : Integer := 0;
5470 procedure Add_Check (N : Node_Id);
5471 -- Adds the action given to Ret_Result if N is non-Empty
5473 function Discrete_Range_Cond
5475 Typ : Entity_Id) return Node_Id;
5476 -- Returns expression to compute:
5477 -- Low_Bound (Expr) < Typ'First
5479 -- High_Bound (Expr) > Typ'Last
5481 function Discrete_Expr_Cond
5483 Typ : Entity_Id) return Node_Id;
5484 -- Returns expression to compute:
5489 function Get_E_First_Or_Last
5492 Nam : Name_Id) return Node_Id;
5493 -- Returns expression to compute:
5494 -- E'First or E'Last
5496 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
5497 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id;
5498 -- Returns expression to compute:
5499 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
5501 function Range_E_Cond
5502 (Exptyp : Entity_Id;
5506 -- Returns expression to compute:
5507 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
5509 function Range_Equal_E_Cond
5510 (Exptyp : Entity_Id;
5512 Indx : Nat) return Node_Id;
5513 -- Returns expression to compute:
5514 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
5516 function Range_N_Cond
5519 Indx : Nat) return Node_Id;
5520 -- Return expression to compute:
5521 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
5527 procedure Add_Check (N : Node_Id) is
5531 -- For now, ignore attempt to place more than 2 checks ???
5533 if Num_Checks = 2 then
5537 pragma Assert (Num_Checks <= 1);
5538 Num_Checks := Num_Checks + 1;
5539 Ret_Result (Num_Checks) := N;
5543 -------------------------
5544 -- Discrete_Expr_Cond --
5545 -------------------------
5547 function Discrete_Expr_Cond
5549 Typ : Entity_Id) return Node_Id
5557 Convert_To (Base_Type (Typ),
5558 Duplicate_Subexpr_No_Checks (Expr)),
5560 Convert_To (Base_Type (Typ),
5561 Get_E_First_Or_Last (Typ, 0, Name_First))),
5566 Convert_To (Base_Type (Typ),
5567 Duplicate_Subexpr_No_Checks (Expr)),
5571 Get_E_First_Or_Last (Typ, 0, Name_Last))));
5572 end Discrete_Expr_Cond;
5574 -------------------------
5575 -- Discrete_Range_Cond --
5576 -------------------------
5578 function Discrete_Range_Cond
5580 Typ : Entity_Id) return Node_Id
5582 LB : Node_Id := Low_Bound (Expr);
5583 HB : Node_Id := High_Bound (Expr);
5585 Left_Opnd : Node_Id;
5586 Right_Opnd : Node_Id;
5589 if Nkind (LB) = N_Identifier
5590 and then Ekind (Entity (LB)) = E_Discriminant then
5591 LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
5594 if Nkind (HB) = N_Identifier
5595 and then Ekind (Entity (HB)) = E_Discriminant then
5596 HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
5603 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)),
5607 (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First)));
5609 if Base_Type (Typ) = Typ then
5612 elsif Compile_Time_Known_Value (High_Bound (Scalar_Range (Typ)))
5614 Compile_Time_Known_Value (High_Bound (Scalar_Range
5617 if Is_Floating_Point_Type (Typ) then
5618 if Expr_Value_R (High_Bound (Scalar_Range (Typ))) =
5619 Expr_Value_R (High_Bound (Scalar_Range (Base_Type (Typ))))
5625 if Expr_Value (High_Bound (Scalar_Range (Typ))) =
5626 Expr_Value (High_Bound (Scalar_Range (Base_Type (Typ))))
5637 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)),
5642 Get_E_First_Or_Last (Typ, 0, Name_Last)));
5644 return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
5645 end Discrete_Range_Cond;
5647 -------------------------
5648 -- Get_E_First_Or_Last --
5649 -------------------------
5651 function Get_E_First_Or_Last
5654 Nam : Name_Id) return Node_Id
5662 if Is_Array_Type (E) then
5663 N := First_Index (E);
5665 for J in 2 .. Indx loop
5670 N := Scalar_Range (E);
5673 if Nkind (N) = N_Subtype_Indication then
5674 LB := Low_Bound (Range_Expression (Constraint (N)));
5675 HB := High_Bound (Range_Expression (Constraint (N)));
5677 elsif Is_Entity_Name (N) then
5678 LB := Type_Low_Bound (Etype (N));
5679 HB := Type_High_Bound (Etype (N));
5682 LB := Low_Bound (N);
5683 HB := High_Bound (N);
5686 if Nam = Name_First then
5692 if Nkind (Bound) = N_Identifier
5693 and then Ekind (Entity (Bound)) = E_Discriminant
5695 -- If this is a task discriminant, and we are the body, we must
5696 -- retrieve the corresponding body discriminal. This is another
5697 -- consequence of the early creation of discriminals, and the
5698 -- need to generate constraint checks before their declarations
5699 -- are made visible.
5701 if Is_Concurrent_Record_Type (Scope (Entity (Bound))) then
5703 Tsk : constant Entity_Id :=
5704 Corresponding_Concurrent_Type
5705 (Scope (Entity (Bound)));
5709 if In_Open_Scopes (Tsk)
5710 and then Has_Completion (Tsk)
5712 -- Find discriminant of original task, and use its
5713 -- current discriminal, which is the renaming within
5716 Disc := First_Discriminant (Tsk);
5717 while Present (Disc) loop
5718 if Chars (Disc) = Chars (Entity (Bound)) then
5719 Set_Scope (Discriminal (Disc), Tsk);
5720 return New_Occurrence_Of (Discriminal (Disc), Loc);
5723 Next_Discriminant (Disc);
5726 -- That loop should always succeed in finding a matching
5727 -- entry and returning. Fatal error if not.
5729 raise Program_Error;
5733 New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
5737 return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
5740 elsif Nkind (Bound) = N_Identifier
5741 and then Ekind (Entity (Bound)) = E_In_Parameter
5742 and then not Inside_Init_Proc
5744 return Get_Discriminal (E, Bound);
5746 elsif Nkind (Bound) = N_Integer_Literal then
5747 return Make_Integer_Literal (Loc, Intval (Bound));
5750 return Duplicate_Subexpr_No_Checks (Bound);
5752 end Get_E_First_Or_Last;
5758 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is
5761 Make_Attribute_Reference (Loc,
5762 Attribute_Name => Name_First,
5764 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
5765 Expressions => New_List (
5766 Make_Integer_Literal (Loc, Indx)));
5773 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is
5776 Make_Attribute_Reference (Loc,
5777 Attribute_Name => Name_Last,
5779 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
5780 Expressions => New_List (
5781 Make_Integer_Literal (Loc, Indx)));
5788 function Range_E_Cond
5789 (Exptyp : Entity_Id;
5791 Indx : Nat) return Node_Id
5798 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
5799 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
5803 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
5804 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
5808 ------------------------
5809 -- Range_Equal_E_Cond --
5810 ------------------------
5812 function Range_Equal_E_Cond
5813 (Exptyp : Entity_Id;
5815 Indx : Nat) return Node_Id
5822 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
5823 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
5826 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
5827 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
5828 end Range_Equal_E_Cond;
5834 function Range_N_Cond
5837 Indx : Nat) return Node_Id
5844 Left_Opnd => Get_N_First (Expr, Indx),
5845 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
5849 Left_Opnd => Get_N_Last (Expr, Indx),
5850 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
5853 -- Start of processing for Selected_Range_Checks
5856 if not Expander_Active then
5860 if Target_Typ = Any_Type
5861 or else Target_Typ = Any_Composite
5862 or else Raises_Constraint_Error (Ck_Node)
5871 T_Typ := Target_Typ;
5873 if No (Source_Typ) then
5874 S_Typ := Etype (Ck_Node);
5876 S_Typ := Source_Typ;
5879 if S_Typ = Any_Type or else S_Typ = Any_Composite then
5883 -- The order of evaluating T_Typ before S_Typ seems to be critical
5884 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
5885 -- in, and since Node can be an N_Range node, it might be invalid.
5886 -- Should there be an assert check somewhere for taking the Etype of
5887 -- an N_Range node ???
5889 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
5890 S_Typ := Designated_Type (S_Typ);
5891 T_Typ := Designated_Type (T_Typ);
5894 -- A simple optimization
5896 if Nkind (Ck_Node) = N_Null then
5901 -- For an N_Range Node, check for a null range and then if not
5902 -- null generate a range check action.
5904 if Nkind (Ck_Node) = N_Range then
5906 -- There's no point in checking a range against itself
5908 if Ck_Node = Scalar_Range (T_Typ) then
5913 T_LB : constant Node_Id := Type_Low_Bound (T_Typ);
5914 T_HB : constant Node_Id := Type_High_Bound (T_Typ);
5915 LB : constant Node_Id := Low_Bound (Ck_Node);
5916 HB : constant Node_Id := High_Bound (Ck_Node);
5917 Null_Range : Boolean;
5919 Out_Of_Range_L : Boolean;
5920 Out_Of_Range_H : Boolean;
5923 -- Check for case where everything is static and we can
5924 -- do the check at compile time. This is skipped if we
5925 -- have an access type, since the access value may be null.
5927 -- ??? This code can be improved since you only need to know
5928 -- that the two respective bounds (LB & T_LB or HB & T_HB)
5929 -- are known at compile time to emit pertinent messages.
5931 if Compile_Time_Known_Value (LB)
5932 and then Compile_Time_Known_Value (HB)
5933 and then Compile_Time_Known_Value (T_LB)
5934 and then Compile_Time_Known_Value (T_HB)
5935 and then not Do_Access
5937 -- Floating-point case
5939 if Is_Floating_Point_Type (S_Typ) then
5940 Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
5942 (Expr_Value_R (LB) < Expr_Value_R (T_LB))
5944 (Expr_Value_R (LB) > Expr_Value_R (T_HB));
5947 (Expr_Value_R (HB) > Expr_Value_R (T_HB))
5949 (Expr_Value_R (HB) < Expr_Value_R (T_LB));
5951 -- Fixed or discrete type case
5954 Null_Range := Expr_Value (HB) < Expr_Value (LB);
5956 (Expr_Value (LB) < Expr_Value (T_LB))
5958 (Expr_Value (LB) > Expr_Value (T_HB));
5961 (Expr_Value (HB) > Expr_Value (T_HB))
5963 (Expr_Value (HB) < Expr_Value (T_LB));
5966 if not Null_Range then
5967 if Out_Of_Range_L then
5968 if No (Warn_Node) then
5970 (Compile_Time_Constraint_Error
5971 (Low_Bound (Ck_Node),
5972 "static value out of range of}?", T_Typ));
5976 (Compile_Time_Constraint_Error
5978 "static range out of bounds of}?", T_Typ));
5982 if Out_Of_Range_H then
5983 if No (Warn_Node) then
5985 (Compile_Time_Constraint_Error
5986 (High_Bound (Ck_Node),
5987 "static value out of range of}?", T_Typ));
5991 (Compile_Time_Constraint_Error
5993 "static range out of bounds of}?", T_Typ));
6001 LB : Node_Id := Low_Bound (Ck_Node);
6002 HB : Node_Id := High_Bound (Ck_Node);
6006 -- If either bound is a discriminant and we are within
6007 -- the record declaration, it is a use of the discriminant
6008 -- in a constraint of a component, and nothing can be
6009 -- checked here. The check will be emitted within the
6010 -- init proc. Before then, the discriminal has no real
6013 if Nkind (LB) = N_Identifier
6014 and then Ekind (Entity (LB)) = E_Discriminant
6016 if Current_Scope = Scope (Entity (LB)) then
6020 New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
6024 if Nkind (HB) = N_Identifier
6025 and then Ekind (Entity (HB)) = E_Discriminant
6027 if Current_Scope = Scope (Entity (HB)) then
6031 New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
6035 Cond := Discrete_Range_Cond (Ck_Node, T_Typ);
6036 Set_Paren_Count (Cond, 1);
6042 Left_Opnd => Duplicate_Subexpr_No_Checks (HB),
6043 Right_Opnd => Duplicate_Subexpr_No_Checks (LB)),
6044 Right_Opnd => Cond);
6050 elsif Is_Scalar_Type (S_Typ) then
6052 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
6053 -- except the above simply sets a flag in the node and lets
6054 -- gigi generate the check base on the Etype of the expression.
6055 -- Sometimes, however we want to do a dynamic check against an
6056 -- arbitrary target type, so we do that here.
6058 if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then
6059 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
6061 -- For literals, we can tell if the constraint error will be
6062 -- raised at compile time, so we never need a dynamic check, but
6063 -- if the exception will be raised, then post the usual warning,
6064 -- and replace the literal with a raise constraint error
6065 -- expression. As usual, skip this for access types
6067 elsif Compile_Time_Known_Value (Ck_Node)
6068 and then not Do_Access
6071 LB : constant Node_Id := Type_Low_Bound (T_Typ);
6072 UB : constant Node_Id := Type_High_Bound (T_Typ);
6074 Out_Of_Range : Boolean;
6075 Static_Bounds : constant Boolean :=
6076 Compile_Time_Known_Value (LB)
6077 and Compile_Time_Known_Value (UB);
6080 -- Following range tests should use Sem_Eval routine ???
6082 if Static_Bounds then
6083 if Is_Floating_Point_Type (S_Typ) then
6085 (Expr_Value_R (Ck_Node) < Expr_Value_R (LB))
6087 (Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
6089 else -- fixed or discrete type
6091 Expr_Value (Ck_Node) < Expr_Value (LB)
6093 Expr_Value (Ck_Node) > Expr_Value (UB);
6096 -- Bounds of the type are static and the literal is
6097 -- out of range so make a warning message.
6099 if Out_Of_Range then
6100 if No (Warn_Node) then
6102 (Compile_Time_Constraint_Error
6104 "static value out of range of}?", T_Typ));
6108 (Compile_Time_Constraint_Error
6110 "static value out of range of}?", T_Typ));
6115 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
6119 -- Here for the case of a non-static expression, we need a runtime
6120 -- check unless the source type range is guaranteed to be in the
6121 -- range of the target type.
6124 if not In_Subrange_Of (S_Typ, T_Typ) then
6125 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
6130 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
6131 if Is_Constrained (T_Typ) then
6133 Expr_Actual := Get_Referenced_Object (Ck_Node);
6134 Exptyp := Get_Actual_Subtype (Expr_Actual);
6136 if Is_Access_Type (Exptyp) then
6137 Exptyp := Designated_Type (Exptyp);
6140 -- String_Literal case. This needs to be handled specially be-
6141 -- cause no index types are available for string literals. The
6142 -- condition is simply:
6144 -- T_Typ'Length = string-literal-length
6146 if Nkind (Expr_Actual) = N_String_Literal then
6149 -- General array case. Here we have a usable actual subtype for
6150 -- the expression, and the condition is built from the two types
6152 -- T_Typ'First < Exptyp'First or else
6153 -- T_Typ'Last > Exptyp'Last or else
6154 -- T_Typ'First(1) < Exptyp'First(1) or else
6155 -- T_Typ'Last(1) > Exptyp'Last(1) or else
6158 elsif Is_Constrained (Exptyp) then
6160 Ndims : constant Nat := Number_Dimensions (T_Typ);
6170 L_Index := First_Index (T_Typ);
6171 R_Index := First_Index (Exptyp);
6173 for Indx in 1 .. Ndims loop
6174 if not (Nkind (L_Index) = N_Raise_Constraint_Error
6176 Nkind (R_Index) = N_Raise_Constraint_Error)
6178 Get_Index_Bounds (L_Index, L_Low, L_High);
6179 Get_Index_Bounds (R_Index, R_Low, R_High);
6181 -- Deal with compile time length check. Note that we
6182 -- skip this in the access case, because the access
6183 -- value may be null, so we cannot know statically.
6186 Subtypes_Statically_Match
6187 (Etype (L_Index), Etype (R_Index))
6189 -- If the target type is constrained then we
6190 -- have to check for exact equality of bounds
6191 -- (required for qualified expressions).
6193 if Is_Constrained (T_Typ) then
6196 Range_Equal_E_Cond (Exptyp, T_Typ, Indx));
6200 (Cond, Range_E_Cond (Exptyp, T_Typ, Indx));
6211 -- Handle cases where we do not get a usable actual subtype that
6212 -- is constrained. This happens for example in the function call
6213 -- and explicit dereference cases. In these cases, we have to get
6214 -- the length or range from the expression itself, making sure we
6215 -- do not evaluate it more than once.
6217 -- Here Ck_Node is the original expression, or more properly the
6218 -- result of applying Duplicate_Expr to the original tree,
6219 -- forcing the result to be a name.
6223 Ndims : constant Nat := Number_Dimensions (T_Typ);
6226 -- Build the condition for the explicit dereference case
6228 for Indx in 1 .. Ndims loop
6230 (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
6237 -- Generate an Action to check that the bounds of the
6238 -- source value are within the constraints imposed by the
6239 -- target type for a conversion to an unconstrained type.
6242 if Nkind (Parent (Ck_Node)) = N_Type_Conversion then
6244 Opnd_Index : Node_Id;
6245 Targ_Index : Node_Id;
6249 := First_Index (Get_Actual_Subtype (Ck_Node));
6250 Targ_Index := First_Index (T_Typ);
6252 while Opnd_Index /= Empty loop
6253 if Nkind (Opnd_Index) = N_Range then
6255 (Low_Bound (Opnd_Index), Etype (Targ_Index))
6258 (High_Bound (Opnd_Index), Etype (Targ_Index))
6262 -- If null range, no check needed.
6264 Compile_Time_Known_Value (High_Bound (Opnd_Index))
6266 Compile_Time_Known_Value (Low_Bound (Opnd_Index))
6268 Expr_Value (High_Bound (Opnd_Index)) <
6269 Expr_Value (Low_Bound (Opnd_Index))
6273 elsif Is_Out_Of_Range
6274 (Low_Bound (Opnd_Index), Etype (Targ_Index))
6277 (High_Bound (Opnd_Index), Etype (Targ_Index))
6280 (Compile_Time_Constraint_Error
6281 (Wnode, "value out of range of}?", T_Typ));
6287 (Opnd_Index, Etype (Targ_Index)));
6291 Next_Index (Opnd_Index);
6292 Next_Index (Targ_Index);
6299 -- Construct the test and insert into the tree
6301 if Present (Cond) then
6303 Cond := Guard_Access (Cond, Loc, Ck_Node);
6307 (Make_Raise_Constraint_Error (Loc,
6309 Reason => CE_Range_Check_Failed));
6313 end Selected_Range_Checks;
6315 -------------------------------
6316 -- Storage_Checks_Suppressed --
6317 -------------------------------
6319 function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is
6321 if Present (E) and then Checks_May_Be_Suppressed (E) then
6322 return Is_Check_Suppressed (E, Storage_Check);
6324 return Scope_Suppress (Storage_Check);
6326 end Storage_Checks_Suppressed;
6328 ---------------------------
6329 -- Tag_Checks_Suppressed --
6330 ---------------------------
6332 function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
6335 if Kill_Tag_Checks (E) then
6337 elsif Checks_May_Be_Suppressed (E) then
6338 return Is_Check_Suppressed (E, Tag_Check);
6342 return Scope_Suppress (Tag_Check);
6343 end Tag_Checks_Suppressed;