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_Ch8; use Sem_Ch8;
47 with Sem_Res; use Sem_Res;
48 with Sem_Util; use Sem_Util;
49 with Sem_Warn; use Sem_Warn;
50 with Sinfo; use Sinfo;
51 with Sinput; use Sinput;
52 with Snames; use Snames;
53 with Sprint; use Sprint;
54 with Stand; use Stand;
55 with Targparm; use Targparm;
56 with Tbuild; use Tbuild;
57 with Ttypes; use Ttypes;
58 with Urealp; use Urealp;
59 with Validsw; use Validsw;
61 package body Checks is
63 -- General note: many of these routines are concerned with generating
64 -- checking code to make sure that constraint error is raised at runtime.
65 -- Clearly this code is only needed if the expander is active, since
66 -- otherwise we will not be generating code or going into the runtime
69 -- We therefore disconnect most of these checks if the expander is
70 -- inactive. This has the additional benefit that we do not need to
71 -- worry about the tree being messed up by previous errors (since errors
72 -- turn off expansion anyway).
74 -- There are a few exceptions to the above rule. For instance routines
75 -- such as Apply_Scalar_Range_Check that do not insert any code can be
76 -- safely called even when the Expander is inactive (but Errors_Detected
77 -- is 0). The benefit of executing this code when expansion is off, is
78 -- the ability to emit constraint error warning for static expressions
79 -- even when we are not generating code.
81 -------------------------------------
82 -- Suppression of Redundant Checks --
83 -------------------------------------
85 -- This unit implements a limited circuit for removal of redundant
86 -- checks. The processing is based on a tracing of simple sequential
87 -- flow. For any sequence of statements, we save expressions that are
88 -- marked to be checked, and then if the same expression appears later
89 -- with the same check, then under certain circumstances, the second
90 -- check can be suppressed.
92 -- Basically, we can suppress the check if we know for certain that
93 -- the previous expression has been elaborated (together with its
94 -- check), and we know that the exception frame is the same, and that
95 -- nothing has happened to change the result of the exception.
97 -- Let us examine each of these three conditions in turn to describe
98 -- how we ensure that this condition is met.
100 -- First, we need to know for certain that the previous expression has
101 -- been executed. This is done principly by the mechanism of calling
102 -- Conditional_Statements_Begin at the start of any statement sequence
103 -- and Conditional_Statements_End at the end. The End call causes all
104 -- checks remembered since the Begin call to be discarded. This does
105 -- miss a few cases, notably the case of a nested BEGIN-END block with
106 -- no exception handlers. But the important thing is to be conservative.
107 -- The other protection is that all checks are discarded if a label
108 -- is encountered, since then the assumption of sequential execution
109 -- is violated, and we don't know enough about the flow.
111 -- Second, we need to know that the exception frame is the same. We
112 -- do this by killing all remembered checks when we enter a new frame.
113 -- Again, that's over-conservative, but generally the cases we can help
114 -- with are pretty local anyway (like the body of a loop for example).
116 -- Third, we must be sure to forget any checks which are no longer valid.
117 -- This is done by two mechanisms, first the Kill_Checks_Variable call is
118 -- used to note any changes to local variables. We only attempt to deal
119 -- with checks involving local variables, so we do not need to worry
120 -- about global variables. Second, a call to any non-global procedure
121 -- causes us to abandon all stored checks, since such a all may affect
122 -- the values of any local variables.
124 -- The following define the data structures used to deal with remembering
125 -- checks so that redundant checks can be eliminated as described above.
127 -- Right now, the only expressions that we deal with are of the form of
128 -- simple local objects (either declared locally, or IN parameters) or
129 -- such objects plus/minus a compile time known constant. We can do
130 -- more later on if it seems worthwhile, but this catches many simple
131 -- cases in practice.
133 -- The following record type reflects a single saved check. An entry
134 -- is made in the stack of saved checks if and only if the expression
135 -- has been elaborated with the indicated checks.
137 type Saved_Check is record
139 -- Set True if entry is killed by Kill_Checks
142 -- The entity involved in the expression that is checked
145 -- A compile time value indicating the result of adding or
146 -- subtracting a compile time value. This value is to be
147 -- added to the value of the Entity. A value of zero is
148 -- used for the case of a simple entity reference.
150 Check_Type : Character;
151 -- This is set to 'R' for a range check (in which case Target_Type
152 -- is set to the target type for the range check) or to 'O' for an
153 -- overflow check (in which case Target_Type is set to Empty).
155 Target_Type : Entity_Id;
156 -- Used only if Do_Range_Check is set. Records the target type for
157 -- the check. We need this, because a check is a duplicate only if
158 -- it has a the same target type (or more accurately one with a
159 -- range that is smaller or equal to the stored target type of a
163 -- The following table keeps track of saved checks. Rather than use an
164 -- extensible table. We just use a table of fixed size, and we discard
165 -- any saved checks that do not fit. That's very unlikely to happen and
166 -- this is only an optimization in any case.
168 Saved_Checks : array (Int range 1 .. 200) of Saved_Check;
169 -- Array of saved checks
171 Num_Saved_Checks : Nat := 0;
172 -- Number of saved checks
174 -- The following stack keeps track of statement ranges. It is treated
175 -- as a stack. When Conditional_Statements_Begin is called, an entry
176 -- is pushed onto this stack containing the value of Num_Saved_Checks
177 -- at the time of the call. Then when Conditional_Statements_End is
178 -- called, this value is popped off and used to reset Num_Saved_Checks.
180 -- Note: again, this is a fixed length stack with a size that should
181 -- always be fine. If the value of the stack pointer goes above the
182 -- limit, then we just forget all saved checks.
184 Saved_Checks_Stack : array (Int range 1 .. 100) of Nat;
185 Saved_Checks_TOS : Nat := 0;
187 -----------------------
188 -- Local Subprograms --
189 -----------------------
191 procedure Apply_Float_Conversion_Check
193 Target_Typ : Entity_Id);
194 -- The checks on a conversion from a floating-point type to an integer
195 -- type are delicate. They have to be performed before conversion, they
196 -- have to raise an exception when the operand is a NaN, and rounding must
197 -- be taken into account to determine the safe bounds of the operand.
199 procedure Apply_Selected_Length_Checks
201 Target_Typ : Entity_Id;
202 Source_Typ : Entity_Id;
203 Do_Static : Boolean);
204 -- This is the subprogram that does all the work for Apply_Length_Check
205 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
206 -- described for the above routines. The Do_Static flag indicates that
207 -- only a static check is to be done.
209 procedure Apply_Selected_Range_Checks
211 Target_Typ : Entity_Id;
212 Source_Typ : Entity_Id;
213 Do_Static : Boolean);
214 -- This is the subprogram that does all the work for Apply_Range_Check.
215 -- Expr, Target_Typ and Source_Typ are as described for the above
216 -- routine. The Do_Static flag indicates that only a static check is
221 Check_Type : Character;
222 Target_Type : Entity_Id;
223 Entry_OK : out Boolean;
227 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
228 -- to see if a check is of the form for optimization, and if so, to see
229 -- if it has already been performed. Expr is the expression to check,
230 -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
231 -- Target_Type is the target type for a range check, and Empty for an
232 -- overflow check. If the entry is not of the form for optimization,
233 -- then Entry_OK is set to False, and the remaining out parameters
234 -- are undefined. If the entry is OK, then Ent/Ofs are set to the
235 -- entity and offset from the expression. Check_Num is the number of
236 -- a matching saved entry in Saved_Checks, or zero if no such entry
239 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id;
240 -- If a discriminal is used in constraining a prival, Return reference
241 -- to the discriminal of the protected body (which renames the parameter
242 -- of the enclosing protected operation). This clumsy transformation is
243 -- needed because privals are created too late and their actual subtypes
244 -- are not available when analysing the bodies of the protected operations.
245 -- To be cleaned up???
247 function Guard_Access
250 Ck_Node : Node_Id) return Node_Id;
251 -- In the access type case, guard the test with a test to ensure
252 -- that the access value is non-null, since the checks do not
253 -- not apply to null access values.
255 procedure Install_Null_Excluding_Check (N : Node_Id);
256 -- Determines whether an access node requires a runtime access check and
257 -- if so inserts the appropriate run-time check
259 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);
260 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
261 -- Constraint_Error node.
263 function Selected_Length_Checks
265 Target_Typ : Entity_Id;
266 Source_Typ : Entity_Id;
267 Warn_Node : Node_Id) return Check_Result;
268 -- Like Apply_Selected_Length_Checks, except it doesn't modify
269 -- anything, just returns a list of nodes as described in the spec of
270 -- this package for the Range_Check function.
272 function Selected_Range_Checks
274 Target_Typ : Entity_Id;
275 Source_Typ : Entity_Id;
276 Warn_Node : Node_Id) return Check_Result;
277 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
278 -- just returns a list of nodes as described in the spec of this package
279 -- for the Range_Check function.
281 ------------------------------
282 -- Access_Checks_Suppressed --
283 ------------------------------
285 function Access_Checks_Suppressed (E : Entity_Id) return Boolean is
287 if Present (E) and then Checks_May_Be_Suppressed (E) then
288 return Is_Check_Suppressed (E, Access_Check);
290 return Scope_Suppress (Access_Check);
292 end Access_Checks_Suppressed;
294 -------------------------------------
295 -- Accessibility_Checks_Suppressed --
296 -------------------------------------
298 function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
300 if Present (E) and then Checks_May_Be_Suppressed (E) then
301 return Is_Check_Suppressed (E, Accessibility_Check);
303 return Scope_Suppress (Accessibility_Check);
305 end Accessibility_Checks_Suppressed;
307 -------------------------
308 -- Append_Range_Checks --
309 -------------------------
311 procedure Append_Range_Checks
312 (Checks : Check_Result;
314 Suppress_Typ : Entity_Id;
315 Static_Sloc : Source_Ptr;
318 Internal_Flag_Node : constant Node_Id := Flag_Node;
319 Internal_Static_Sloc : constant Source_Ptr := Static_Sloc;
321 Checks_On : constant Boolean :=
322 (not Index_Checks_Suppressed (Suppress_Typ))
324 (not Range_Checks_Suppressed (Suppress_Typ));
327 -- For now we just return if Checks_On is false, however this should
328 -- be enhanced to check for an always True value in the condition
329 -- and to generate a compilation warning???
331 if not Checks_On then
336 exit when No (Checks (J));
338 if Nkind (Checks (J)) = N_Raise_Constraint_Error
339 and then Present (Condition (Checks (J)))
341 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
342 Append_To (Stmts, Checks (J));
343 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
349 Make_Raise_Constraint_Error (Internal_Static_Sloc,
350 Reason => CE_Range_Check_Failed));
353 end Append_Range_Checks;
355 ------------------------
356 -- Apply_Access_Check --
357 ------------------------
359 procedure Apply_Access_Check (N : Node_Id) is
360 P : constant Node_Id := Prefix (N);
363 if Inside_A_Generic then
367 if Is_Entity_Name (P) then
368 Check_Unset_Reference (P);
371 -- Don't need access check if prefix is known to be non-null
373 if Known_Non_Null (P) then
376 -- Don't need access checks if they are suppressed on the type
378 elsif Access_Checks_Suppressed (Etype (P)) then
382 -- Case where P is an entity name
384 if Is_Entity_Name (P) then
386 Ent : constant Entity_Id := Entity (P);
389 if Access_Checks_Suppressed (Ent) then
393 -- Otherwise we are going to generate an access check, and
394 -- are we have done it, the entity will now be known non null
395 -- But we have to check for safe sequential semantics here!
397 if Safe_To_Capture_Value (N, Ent) then
398 Set_Is_Known_Non_Null (Ent);
403 -- Access check is required
405 Install_Null_Excluding_Check (P);
406 end Apply_Access_Check;
408 -------------------------------
409 -- Apply_Accessibility_Check --
410 -------------------------------
412 procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id) is
413 Loc : constant Source_Ptr := Sloc (N);
414 Param_Ent : constant Entity_Id := Param_Entity (N);
415 Param_Level : Node_Id;
416 Type_Level : Node_Id;
419 if Inside_A_Generic then
422 -- Only apply the run-time check if the access parameter
423 -- has an associated extra access level parameter and
424 -- when the level of the type is less deep than the level
425 -- of the access parameter.
427 elsif Present (Param_Ent)
428 and then Present (Extra_Accessibility (Param_Ent))
429 and then UI_Gt (Object_Access_Level (N),
430 Type_Access_Level (Typ))
431 and then not Accessibility_Checks_Suppressed (Param_Ent)
432 and then not Accessibility_Checks_Suppressed (Typ)
435 New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
438 Make_Integer_Literal (Loc, Type_Access_Level (Typ));
440 -- Raise Program_Error if the accessibility level of the
441 -- the access parameter is deeper than the level of the
442 -- target access type.
445 Make_Raise_Program_Error (Loc,
448 Left_Opnd => Param_Level,
449 Right_Opnd => Type_Level),
450 Reason => PE_Accessibility_Check_Failed));
452 Analyze_And_Resolve (N);
454 end Apply_Accessibility_Check;
456 ---------------------------
457 -- Apply_Alignment_Check --
458 ---------------------------
460 procedure Apply_Alignment_Check (E : Entity_Id; N : Node_Id) is
461 AC : constant Node_Id := Address_Clause (E);
465 Alignment_Required : constant Boolean := Maximum_Alignment > 1;
466 -- Constant to show whether target requires alignment checks
469 -- See if check needed. Note that we never need a check if the
470 -- maximum alignment is one, since the check will always succeed
473 or else not Check_Address_Alignment (AC)
474 or else not Alignment_Required
480 Expr := Expression (AC);
482 if Nkind (Expr) = N_Unchecked_Type_Conversion then
483 Expr := Expression (Expr);
485 elsif Nkind (Expr) = N_Function_Call
486 and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
488 Expr := First (Parameter_Associations (Expr));
490 if Nkind (Expr) = N_Parameter_Association then
491 Expr := Explicit_Actual_Parameter (Expr);
495 -- Here Expr is the address value. See if we know that the
496 -- value is unacceptable at compile time.
498 if Compile_Time_Known_Value (Expr)
499 and then Known_Alignment (E)
501 if Expr_Value (Expr) mod Alignment (E) /= 0 then
503 Make_Raise_Program_Error (Loc,
504 Reason => PE_Misaligned_Address_Value));
506 ("?specified address for& not " &
507 "consistent with alignment ('R'M 13.3(27))", Expr, E);
510 -- Here we do not know if the value is acceptable, generate
511 -- code to raise PE if alignment is inappropriate.
514 -- Skip generation of this code if we don't want elab code
516 if not Restriction_Active (No_Elaboration_Code) then
517 Insert_After_And_Analyze (N,
518 Make_Raise_Program_Error (Loc,
525 (RTE (RE_Integer_Address),
526 Duplicate_Subexpr_No_Checks (Expr)),
528 Make_Attribute_Reference (Loc,
529 Prefix => New_Occurrence_Of (E, Loc),
530 Attribute_Name => Name_Alignment)),
531 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
532 Reason => PE_Misaligned_Address_Value),
533 Suppress => All_Checks);
540 when RE_Not_Available =>
542 end Apply_Alignment_Check;
544 -------------------------------------
545 -- Apply_Arithmetic_Overflow_Check --
546 -------------------------------------
548 -- This routine is called only if the type is an integer type, and
549 -- a software arithmetic overflow check must be performed for op
550 -- (add, subtract, multiply). The check is performed only if
551 -- Software_Overflow_Checking is enabled and Do_Overflow_Check
552 -- is set. In this case we expand the operation into a more complex
553 -- sequence of tests that ensures that overflow is properly caught.
555 procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
556 Loc : constant Source_Ptr := Sloc (N);
557 Typ : constant Entity_Id := Etype (N);
558 Rtyp : constant Entity_Id := Root_Type (Typ);
559 Siz : constant Int := UI_To_Int (Esize (Rtyp));
560 Dsiz : constant Int := Siz * 2;
567 -- Skip this if overflow checks are done in back end, or the overflow
568 -- flag is not set anyway, or we are not doing code expansion.
570 if Backend_Overflow_Checks_On_Target
571 or not Do_Overflow_Check (N)
572 or not Expander_Active
577 -- Otherwise, we generate the full general code for front end overflow
578 -- detection, which works by doing arithmetic in a larger type:
584 -- Typ (Checktyp (x) op Checktyp (y));
586 -- where Typ is the type of the original expression, and Checktyp is
587 -- an integer type of sufficient length to hold the largest possible
590 -- In the case where check type exceeds the size of Long_Long_Integer,
591 -- we use a different approach, expanding to:
593 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
595 -- where xxx is Add, Multiply or Subtract as appropriate
597 -- Find check type if one exists
599 if Dsiz <= Standard_Integer_Size then
600 Ctyp := Standard_Integer;
602 elsif Dsiz <= Standard_Long_Long_Integer_Size then
603 Ctyp := Standard_Long_Long_Integer;
605 -- No check type exists, use runtime call
608 if Nkind (N) = N_Op_Add then
609 Cent := RE_Add_With_Ovflo_Check;
611 elsif Nkind (N) = N_Op_Multiply then
612 Cent := RE_Multiply_With_Ovflo_Check;
615 pragma Assert (Nkind (N) = N_Op_Subtract);
616 Cent := RE_Subtract_With_Ovflo_Check;
621 Make_Function_Call (Loc,
622 Name => New_Reference_To (RTE (Cent), Loc),
623 Parameter_Associations => New_List (
624 OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)),
625 OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
627 Analyze_And_Resolve (N, Typ);
631 -- If we fall through, we have the case where we do the arithmetic in
632 -- the next higher type and get the check by conversion. In these cases
633 -- Ctyp is set to the type to be used as the check type.
635 Opnod := Relocate_Node (N);
637 Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
640 Set_Etype (Opnd, Ctyp);
641 Set_Analyzed (Opnd, True);
642 Set_Left_Opnd (Opnod, Opnd);
644 Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
647 Set_Etype (Opnd, Ctyp);
648 Set_Analyzed (Opnd, True);
649 Set_Right_Opnd (Opnod, Opnd);
651 -- The type of the operation changes to the base type of the check
652 -- type, and we reset the overflow check indication, since clearly
653 -- no overflow is possible now that we are using a double length
654 -- type. We also set the Analyzed flag to avoid a recursive attempt
655 -- to expand the node.
657 Set_Etype (Opnod, Base_Type (Ctyp));
658 Set_Do_Overflow_Check (Opnod, False);
659 Set_Analyzed (Opnod, True);
661 -- Now build the outer conversion
663 Opnd := OK_Convert_To (Typ, Opnod);
665 Set_Etype (Opnd, Typ);
667 -- In the discrete type case, we directly generate the range check
668 -- for the outer operand. This range check will implement the required
671 if Is_Discrete_Type (Typ) then
673 Generate_Range_Check (Expression (N), Typ, CE_Overflow_Check_Failed);
675 -- For other types, we enable overflow checking on the conversion,
676 -- after setting the node as analyzed to prevent recursive attempts
677 -- to expand the conversion node.
680 Set_Analyzed (Opnd, True);
681 Enable_Overflow_Check (Opnd);
686 when RE_Not_Available =>
688 end Apply_Arithmetic_Overflow_Check;
690 ----------------------------
691 -- Apply_Array_Size_Check --
692 ----------------------------
694 -- Note: Really of course this entre check should be in the backend,
695 -- and perhaps this is not quite the right value, but it is good
696 -- enough to catch the normal cases (and the relevant ACVC tests!)
698 -- The situation is as follows. In GNAT 3 (GCC 2.x), the size in bits
699 -- is computed in 32 bits without an overflow check. That's a real
700 -- problem for Ada. So what we do in GNAT 3 is to approximate the
701 -- size of an array by manually multiplying the element size by the
702 -- number of elements, and comparing that against the allowed limits.
704 -- In GNAT 5, the size in byte is still computed in 32 bits without
705 -- an overflow check in the dynamic case, but the size in bits is
706 -- computed in 64 bits. We assume that's good enough, so we use the
707 -- size in bits for the test.
709 procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is
710 Loc : constant Source_Ptr := Sloc (N);
711 Ctyp : constant Entity_Id := Component_Type (Typ);
712 Ent : constant Entity_Id := Defining_Identifier (N);
724 Static : Boolean := True;
725 -- Set false if any index subtye bound is non-static
727 Umark : constant Uintp.Save_Mark := Uintp.Mark;
728 -- We can throw away all the Uint computations here, since they are
729 -- done only to generate boolean test results.
732 -- Size to check against
734 function Is_Address_Or_Import (Decl : Node_Id) return Boolean;
735 -- Determines if Decl is an address clause or Import/Interface pragma
736 -- that references the defining identifier of the current declaration.
738 --------------------------
739 -- Is_Address_Or_Import --
740 --------------------------
742 function Is_Address_Or_Import (Decl : Node_Id) return Boolean is
744 if Nkind (Decl) = N_At_Clause then
745 return Chars (Identifier (Decl)) = Chars (Ent);
747 elsif Nkind (Decl) = N_Attribute_Definition_Clause then
749 Chars (Decl) = Name_Address
751 Nkind (Name (Decl)) = N_Identifier
753 Chars (Name (Decl)) = Chars (Ent);
755 elsif Nkind (Decl) = N_Pragma then
756 if (Chars (Decl) = Name_Import
758 Chars (Decl) = Name_Interface)
759 and then Present (Pragma_Argument_Associations (Decl))
762 F : constant Node_Id :=
763 First (Pragma_Argument_Associations (Decl));
771 Nkind (Expression (Next (F))) = N_Identifier
773 Chars (Expression (Next (F))) = Chars (Ent);
783 end Is_Address_Or_Import;
785 -- Start of processing for Apply_Array_Size_Check
788 -- No need for a check if not expanding
790 if not Expander_Active then
794 -- No need for a check if checks are suppressed
796 if Storage_Checks_Suppressed (Typ) then
800 -- It is pointless to insert this check inside an init proc, because
801 -- that's too late, we have already built the object to be the right
802 -- size, and if it's too large, too bad!
804 if Inside_Init_Proc then
808 -- Look head for pragma interface/import or address clause applying
809 -- to this entity. If found, we suppress the check entirely. For now
810 -- we only look ahead 20 declarations to stop this becoming too slow
811 -- Note that eventually this whole routine gets moved to gigi.
814 for Ctr in 1 .. 20 loop
818 if Is_Address_Or_Import (Decl) then
825 if Opt.GCC_Version = 3 then
827 -- No problem if size is known at compile time (even if the front
828 -- end does not know it) because the back end does do overflow
829 -- checking on the size in bytes if it is compile time known.
831 if Size_Known_At_Compile_Time (Typ) then
836 -- Following code is temporarily deleted, since GCC 3 is returning
837 -- zero for size in bits of large dynamic arrays. ???
839 -- -- Otherwise we check for the size in bits exceeding 2**31-1 * 8.
840 -- -- This is the case in which we could end up with problems from
841 -- -- an unnoticed overflow in computing the size in bytes
843 -- Check_Siz := (Uint_2 ** 31 - Uint_1) * Uint_8;
846 -- Make_Attribute_Reference (Loc,
847 -- Prefix => New_Occurrence_Of (Typ, Loc),
848 -- Attribute_Name => Name_Size);
850 -- GCC 2 case (for now this is for GCC 3 dynamic case as well)
853 -- First step is to calculate the maximum number of elements. For
854 -- this calculation, we use the actual size of the subtype if it is
855 -- static, and if a bound of a subtype is non-static, we go to the
856 -- bound of the base type.
859 Indx := First_Index (Typ);
860 while Present (Indx) loop
861 Xtyp := Etype (Indx);
862 Lo := Type_Low_Bound (Xtyp);
863 Hi := Type_High_Bound (Xtyp);
865 -- If any bound raises constraint error, we will never get this
866 -- far, so there is no need to generate any kind of check.
868 if Raises_Constraint_Error (Lo)
870 Raises_Constraint_Error (Hi)
872 Uintp.Release (Umark);
876 -- Otherwise get bounds values
878 if Is_Static_Expression (Lo) then
879 Lob := Expr_Value (Lo);
881 Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp)));
885 if Is_Static_Expression (Hi) then
886 Hib := Expr_Value (Hi);
888 Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
892 Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0);
896 -- Compute the limit against which we want to check. For subprograms,
897 -- where the array will go on the stack, we use 8*2**24, which (in
898 -- bits) is the size of a 16 megabyte array.
900 if Is_Subprogram (Scope (Ent)) then
901 Check_Siz := Uint_2 ** 27;
903 Check_Siz := Uint_2 ** 31;
906 -- If we have all static bounds and Siz is too large, then we know
907 -- we know we have a storage error right now, so generate message
909 if Static and then Siz >= Check_Siz then
911 Make_Raise_Storage_Error (Loc,
912 Reason => SE_Object_Too_Large));
913 Error_Msg_N ("?Storage_Error will be raised at run-time", N);
914 Uintp.Release (Umark);
918 -- Case of component size known at compile time. If the array
919 -- size is definitely in range, then we do not need a check.
921 if Known_Esize (Ctyp)
922 and then Siz * Esize (Ctyp) < Check_Siz
924 Uintp.Release (Umark);
928 -- Here if a dynamic check is required
930 -- What we do is to build an expression for the size of the array,
931 -- which is computed as the 'Size of the array component, times
932 -- the size of each dimension.
934 Uintp.Release (Umark);
937 Make_Attribute_Reference (Loc,
938 Prefix => New_Occurrence_Of (Ctyp, Loc),
939 Attribute_Name => Name_Size);
941 Indx := First_Index (Typ);
942 for J in 1 .. Number_Dimensions (Typ) loop
943 if Sloc (Etype (Indx)) = Sloc (N) then
944 Ensure_Defined (Etype (Indx), N);
948 Make_Op_Multiply (Loc,
951 Make_Attribute_Reference (Loc,
952 Prefix => New_Occurrence_Of (Typ, Loc),
953 Attribute_Name => Name_Length,
954 Expressions => New_List (
955 Make_Integer_Literal (Loc, J))));
960 -- Common code to actually emit the check
963 Make_Raise_Storage_Error (Loc,
968 Make_Integer_Literal (Loc,
969 Intval => Check_Siz)),
970 Reason => SE_Object_Too_Large);
972 Set_Size_Check_Code (Defining_Identifier (N), Code);
973 Insert_Action (N, Code, Suppress => All_Checks);
974 end Apply_Array_Size_Check;
976 ----------------------------
977 -- Apply_Constraint_Check --
978 ----------------------------
980 procedure Apply_Constraint_Check
983 No_Sliding : Boolean := False)
985 Desig_Typ : Entity_Id;
988 if Inside_A_Generic then
991 elsif Is_Scalar_Type (Typ) then
992 Apply_Scalar_Range_Check (N, Typ);
994 elsif Is_Array_Type (Typ) then
996 -- A useful optimization: an aggregate with only an Others clause
997 -- always has the right bounds.
999 if Nkind (N) = N_Aggregate
1000 and then No (Expressions (N))
1002 (First (Choices (First (Component_Associations (N)))))
1008 if Is_Constrained (Typ) then
1009 Apply_Length_Check (N, Typ);
1012 Apply_Range_Check (N, Typ);
1015 Apply_Range_Check (N, Typ);
1018 elsif (Is_Record_Type (Typ)
1019 or else Is_Private_Type (Typ))
1020 and then Has_Discriminants (Base_Type (Typ))
1021 and then Is_Constrained (Typ)
1023 Apply_Discriminant_Check (N, Typ);
1025 elsif Is_Access_Type (Typ) then
1027 Desig_Typ := Designated_Type (Typ);
1029 -- No checks necessary if expression statically null
1031 if Nkind (N) = N_Null then
1034 -- No sliding possible on access to arrays
1036 elsif Is_Array_Type (Desig_Typ) then
1037 if Is_Constrained (Desig_Typ) then
1038 Apply_Length_Check (N, Typ);
1041 Apply_Range_Check (N, Typ);
1043 elsif Has_Discriminants (Base_Type (Desig_Typ))
1044 and then Is_Constrained (Desig_Typ)
1046 Apply_Discriminant_Check (N, Typ);
1049 if Can_Never_Be_Null (Typ)
1050 and then not Can_Never_Be_Null (Etype (N))
1052 Install_Null_Excluding_Check (N);
1055 end Apply_Constraint_Check;
1057 ------------------------------
1058 -- Apply_Discriminant_Check --
1059 ------------------------------
1061 procedure Apply_Discriminant_Check
1064 Lhs : Node_Id := Empty)
1066 Loc : constant Source_Ptr := Sloc (N);
1067 Do_Access : constant Boolean := Is_Access_Type (Typ);
1068 S_Typ : Entity_Id := Etype (N);
1072 function Is_Aliased_Unconstrained_Component return Boolean;
1073 -- It is possible for an aliased component to have a nominal
1074 -- unconstrained subtype (through instantiation). If this is a
1075 -- discriminated component assigned in the expansion of an aggregate
1076 -- in an initialization, the check must be suppressed. This unusual
1077 -- situation requires a predicate of its own (see 7503-008).
1079 ----------------------------------------
1080 -- Is_Aliased_Unconstrained_Component --
1081 ----------------------------------------
1083 function Is_Aliased_Unconstrained_Component return Boolean is
1088 if Nkind (Lhs) /= N_Selected_Component then
1091 Comp := Entity (Selector_Name (Lhs));
1092 Pref := Prefix (Lhs);
1095 if Ekind (Comp) /= E_Component
1096 or else not Is_Aliased (Comp)
1101 return not Comes_From_Source (Pref)
1102 and then In_Instance
1103 and then not Is_Constrained (Etype (Comp));
1104 end Is_Aliased_Unconstrained_Component;
1106 -- Start of processing for Apply_Discriminant_Check
1110 T_Typ := Designated_Type (Typ);
1115 -- Nothing to do if discriminant checks are suppressed or else no code
1116 -- is to be generated
1118 if not Expander_Active
1119 or else Discriminant_Checks_Suppressed (T_Typ)
1124 -- No discriminant checks necessary for access when expression
1125 -- is statically Null. This is not only an optimization, this is
1126 -- fundamental because otherwise discriminant checks may be generated
1127 -- in init procs for types containing an access to a non-frozen yet
1128 -- record, causing a deadly forward reference.
1130 -- Also, if the expression is of an access type whose designated
1131 -- type is incomplete, then the access value must be null and
1132 -- we suppress the check.
1134 if Nkind (N) = N_Null then
1137 elsif Is_Access_Type (S_Typ) then
1138 S_Typ := Designated_Type (S_Typ);
1140 if Ekind (S_Typ) = E_Incomplete_Type then
1145 -- If an assignment target is present, then we need to generate
1146 -- the actual subtype if the target is a parameter or aliased
1147 -- object with an unconstrained nominal subtype.
1150 and then (Present (Param_Entity (Lhs))
1151 or else (not Is_Constrained (T_Typ)
1152 and then Is_Aliased_View (Lhs)
1153 and then not Is_Aliased_Unconstrained_Component))
1155 T_Typ := Get_Actual_Subtype (Lhs);
1158 -- Nothing to do if the type is unconstrained (this is the case
1159 -- where the actual subtype in the RM sense of N is unconstrained
1160 -- and no check is required).
1162 if not Is_Constrained (T_Typ) then
1166 -- Suppress checks if the subtypes are the same.
1167 -- the check must be preserved in an assignment to a formal, because
1168 -- the constraint is given by the actual.
1170 if Nkind (Original_Node (N)) /= N_Allocator
1172 or else not Is_Entity_Name (Lhs)
1173 or else No (Param_Entity (Lhs)))
1176 or else (Do_Access and then Designated_Type (Typ) = S_Typ))
1177 and then not Is_Aliased_View (Lhs)
1182 -- We can also eliminate checks on allocators with a subtype mark
1183 -- that coincides with the context type. The context type may be a
1184 -- subtype without a constraint (common case, a generic actual).
1186 elsif Nkind (Original_Node (N)) = N_Allocator
1187 and then Is_Entity_Name (Expression (Original_Node (N)))
1190 Alloc_Typ : constant Entity_Id :=
1191 Entity (Expression (Original_Node (N)));
1194 if Alloc_Typ = T_Typ
1195 or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration
1196 and then Is_Entity_Name (
1197 Subtype_Indication (Parent (T_Typ)))
1198 and then Alloc_Typ = Base_Type (T_Typ))
1206 -- See if we have a case where the types are both constrained, and
1207 -- all the constraints are constants. In this case, we can do the
1208 -- check successfully at compile time.
1210 -- We skip this check for the case where the node is a rewritten`
1211 -- allocator, because it already carries the context subtype, and
1212 -- extracting the discriminants from the aggregate is messy.
1214 if Is_Constrained (S_Typ)
1215 and then Nkind (Original_Node (N)) /= N_Allocator
1225 -- S_Typ may not have discriminants in the case where it is a
1226 -- private type completed by a default discriminated type. In
1227 -- that case, we need to get the constraints from the
1228 -- underlying_type. If the underlying type is unconstrained (i.e.
1229 -- has no default discriminants) no check is needed.
1231 if Has_Discriminants (S_Typ) then
1232 Discr := First_Discriminant (S_Typ);
1233 DconS := First_Elmt (Discriminant_Constraint (S_Typ));
1236 Discr := First_Discriminant (Underlying_Type (S_Typ));
1239 (Discriminant_Constraint (Underlying_Type (S_Typ)));
1245 -- A further optimization: if T_Typ is derived from S_Typ
1246 -- without imposing a constraint, no check is needed.
1248 if Nkind (Original_Node (Parent (T_Typ))) =
1249 N_Full_Type_Declaration
1252 Type_Def : constant Node_Id :=
1254 (Original_Node (Parent (T_Typ)));
1256 if Nkind (Type_Def) = N_Derived_Type_Definition
1257 and then Is_Entity_Name (Subtype_Indication (Type_Def))
1258 and then Entity (Subtype_Indication (Type_Def)) = S_Typ
1266 DconT := First_Elmt (Discriminant_Constraint (T_Typ));
1268 while Present (Discr) loop
1269 ItemS := Node (DconS);
1270 ItemT := Node (DconT);
1273 not Is_OK_Static_Expression (ItemS)
1275 not Is_OK_Static_Expression (ItemT);
1277 if Expr_Value (ItemS) /= Expr_Value (ItemT) then
1278 if Do_Access then -- needs run-time check.
1281 Apply_Compile_Time_Constraint_Error
1282 (N, "incorrect value for discriminant&?",
1283 CE_Discriminant_Check_Failed, Ent => Discr);
1290 Next_Discriminant (Discr);
1299 -- Here we need a discriminant check. First build the expression
1300 -- for the comparisons of the discriminants:
1302 -- (n.disc1 /= typ.disc1) or else
1303 -- (n.disc2 /= typ.disc2) or else
1305 -- (n.discn /= typ.discn)
1307 Cond := Build_Discriminant_Checks (N, T_Typ);
1309 -- If Lhs is set and is a parameter, then the condition is
1310 -- guarded by: lhs'constrained and then (condition built above)
1312 if Present (Param_Entity (Lhs)) then
1316 Make_Attribute_Reference (Loc,
1317 Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc),
1318 Attribute_Name => Name_Constrained),
1319 Right_Opnd => Cond);
1323 Cond := Guard_Access (Cond, Loc, N);
1327 Make_Raise_Constraint_Error (Loc,
1329 Reason => CE_Discriminant_Check_Failed));
1330 end Apply_Discriminant_Check;
1332 ------------------------
1333 -- Apply_Divide_Check --
1334 ------------------------
1336 procedure Apply_Divide_Check (N : Node_Id) is
1337 Loc : constant Source_Ptr := Sloc (N);
1338 Typ : constant Entity_Id := Etype (N);
1339 Left : constant Node_Id := Left_Opnd (N);
1340 Right : constant Node_Id := Right_Opnd (N);
1352 and not Backend_Divide_Checks_On_Target
1354 Determine_Range (Right, ROK, Rlo, Rhi);
1356 -- See if division by zero possible, and if so generate test. This
1357 -- part of the test is not controlled by the -gnato switch.
1359 if Do_Division_Check (N) then
1361 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
1363 Make_Raise_Constraint_Error (Loc,
1366 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
1367 Right_Opnd => Make_Integer_Literal (Loc, 0)),
1368 Reason => CE_Divide_By_Zero));
1372 -- Test for extremely annoying case of xxx'First divided by -1
1374 if Do_Overflow_Check (N) then
1376 if Nkind (N) = N_Op_Divide
1377 and then Is_Signed_Integer_Type (Typ)
1379 Determine_Range (Left, LOK, Llo, Lhi);
1380 LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
1382 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
1384 ((not LOK) or else (Llo = LLB))
1387 Make_Raise_Constraint_Error (Loc,
1393 Duplicate_Subexpr_Move_Checks (Left),
1394 Right_Opnd => Make_Integer_Literal (Loc, LLB)),
1398 Duplicate_Subexpr (Right),
1400 Make_Integer_Literal (Loc, -1))),
1401 Reason => CE_Overflow_Check_Failed));
1406 end Apply_Divide_Check;
1408 ----------------------------------
1409 -- Apply_Float_Conversion_Check --
1410 ----------------------------------
1412 -- Let F and I be the source and target types of the conversion.
1413 -- The Ada standard specifies that a floating-point value X is rounded
1414 -- to the nearest integer, with halfway cases being rounded away from
1415 -- zero. The rounded value of X is checked against I'Range.
1417 -- The catch in the above paragraph is that there is no good way
1418 -- to know whether the round-to-integer operation resulted in
1419 -- overflow. A remedy is to perform a range check in the floating-point
1420 -- domain instead, however:
1421 -- (1) The bounds may not be known at compile time
1422 -- (2) The check must take into account possible rounding.
1423 -- (3) The range of type I may not be exactly representable in F.
1424 -- (4) The end-points I'First - 0.5 and I'Last + 0.5 may or may
1425 -- not be in range, depending on the sign of I'First and I'Last.
1426 -- (5) X may be a NaN, which will fail any comparison
1428 -- The following steps take care of these issues converting X:
1429 -- (1) If either I'First or I'Last is not known at compile time, use
1430 -- I'Base instead of I in the next three steps and perform a
1431 -- regular range check against I'Range after conversion.
1432 -- (2) If I'First - 0.5 is representable in F then let Lo be that
1433 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
1434 -- F'Machine (T) and let Lo_OK be (Lo >= I'First). In other words,
1435 -- take one of the closest floating-point numbers to T, and see if
1436 -- it is in range or not.
1437 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value
1438 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
1439 -- F'Rounding (T) and let Hi_OK be (Hi <= I'Last).
1440 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
1441 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
1443 procedure Apply_Float_Conversion_Check
1445 Target_Typ : Entity_Id)
1447 LB : constant Node_Id := Type_Low_Bound (Target_Typ);
1448 HB : constant Node_Id := Type_High_Bound (Target_Typ);
1449 Loc : constant Source_Ptr := Sloc (Ck_Node);
1450 Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node));
1451 Target_Base : constant Entity_Id := Implementation_Base_Type
1453 Max_Bound : constant Uint := UI_Expon
1454 (Machine_Radix (Expr_Type),
1455 Machine_Mantissa (Expr_Type) - 1) - 1;
1456 -- Largest bound, so bound plus or minus half is a machine number of F
1459 Ilast : Uint; -- Bounds of integer type
1460 Lo, Hi : Ureal; -- Bounds to check in floating-point domain
1462 Hi_OK : Boolean; -- True iff Lo resp. Hi belongs to I'Range
1465 Hi_Chk : Node_Id; -- Expressions that are False iff check fails
1467 Reason : RT_Exception_Code;
1470 if not Compile_Time_Known_Value (LB)
1471 or not Compile_Time_Known_Value (HB)
1474 -- First check that the value falls in the range of the base
1475 -- type, to prevent overflow during conversion and then
1476 -- perform a regular range check against the (dynamic) bounds.
1478 Par : constant Node_Id := Parent (Ck_Node);
1480 pragma Assert (Target_Base /= Target_Typ);
1481 pragma Assert (Nkind (Par) = N_Type_Conversion);
1483 Temp : constant Entity_Id :=
1484 Make_Defining_Identifier (Loc,
1485 Chars => New_Internal_Name ('T'));
1488 Apply_Float_Conversion_Check (Ck_Node, Target_Base);
1489 Set_Etype (Temp, Target_Base);
1491 Insert_Action (Parent (Par),
1492 Make_Object_Declaration (Loc,
1493 Defining_Identifier => Temp,
1494 Object_Definition => New_Occurrence_Of (Target_Typ, Loc),
1495 Expression => New_Copy_Tree (Par)),
1496 Suppress => All_Checks);
1499 Make_Raise_Constraint_Error (Loc,
1502 Left_Opnd => New_Occurrence_Of (Temp, Loc),
1503 Right_Opnd => New_Occurrence_Of (Target_Typ, Loc)),
1504 Reason => CE_Range_Check_Failed));
1505 Rewrite (Par, New_Occurrence_Of (Temp, Loc));
1511 -- Get the bounds of the target type
1513 Ifirst := Expr_Value (LB);
1514 Ilast := Expr_Value (HB);
1516 -- Check against lower bound
1518 if abs (Ifirst) < Max_Bound then
1519 Lo := UR_From_Uint (Ifirst) - Ureal_Half;
1520 Lo_OK := (Ifirst > 0);
1522 Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
1523 Lo_OK := (Lo >= UR_From_Uint (Ifirst));
1528 -- Lo_Chk := (X >= Lo)
1530 Lo_Chk := Make_Op_Ge (Loc,
1531 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
1532 Right_Opnd => Make_Real_Literal (Loc, Lo));
1535 -- Lo_Chk := (X > Lo)
1537 Lo_Chk := Make_Op_Gt (Loc,
1538 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
1539 Right_Opnd => Make_Real_Literal (Loc, Lo));
1542 -- Check against higher bound
1544 if abs (Ilast) < Max_Bound then
1545 Hi := UR_From_Uint (Ilast) + Ureal_Half;
1546 Hi_OK := (Ilast < 0);
1548 Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Ck_Node);
1549 Hi_OK := (Hi <= UR_From_Uint (Ilast));
1554 -- Hi_Chk := (X <= Hi)
1556 Hi_Chk := Make_Op_Le (Loc,
1557 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
1558 Right_Opnd => Make_Real_Literal (Loc, Hi));
1561 -- Hi_Chk := (X < Hi)
1563 Hi_Chk := Make_Op_Lt (Loc,
1564 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
1565 Right_Opnd => Make_Real_Literal (Loc, Hi));
1568 -- If the bounds of the target type are the same as those of the
1569 -- base type, the check is an overflow check as a range check is
1570 -- not performed in these cases.
1572 if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst
1573 and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast
1575 Reason := CE_Overflow_Check_Failed;
1577 Reason := CE_Range_Check_Failed;
1580 -- Raise CE if either conditions does not hold
1582 Insert_Action (Ck_Node,
1583 Make_Raise_Constraint_Error (Loc,
1584 Condition => Make_Op_Not (Loc, Make_Op_And (Loc, Lo_Chk, Hi_Chk)),
1586 end Apply_Float_Conversion_Check;
1588 ------------------------
1589 -- Apply_Length_Check --
1590 ------------------------
1592 procedure Apply_Length_Check
1594 Target_Typ : Entity_Id;
1595 Source_Typ : Entity_Id := Empty)
1598 Apply_Selected_Length_Checks
1599 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1600 end Apply_Length_Check;
1602 -----------------------
1603 -- Apply_Range_Check --
1604 -----------------------
1606 procedure Apply_Range_Check
1608 Target_Typ : Entity_Id;
1609 Source_Typ : Entity_Id := Empty)
1612 Apply_Selected_Range_Checks
1613 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1614 end Apply_Range_Check;
1616 ------------------------------
1617 -- Apply_Scalar_Range_Check --
1618 ------------------------------
1620 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check
1621 -- flag off if it is already set on.
1623 procedure Apply_Scalar_Range_Check
1625 Target_Typ : Entity_Id;
1626 Source_Typ : Entity_Id := Empty;
1627 Fixed_Int : Boolean := False)
1629 Parnt : constant Node_Id := Parent (Expr);
1631 Arr : Node_Id := Empty; -- initialize to prevent warning
1632 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning
1635 Is_Subscr_Ref : Boolean;
1636 -- Set true if Expr is a subscript
1638 Is_Unconstrained_Subscr_Ref : Boolean;
1639 -- Set true if Expr is a subscript of an unconstrained array. In this
1640 -- case we do not attempt to do an analysis of the value against the
1641 -- range of the subscript, since we don't know the actual subtype.
1644 -- Set to True if Expr should be regarded as a real value
1645 -- even though the type of Expr might be discrete.
1647 procedure Bad_Value;
1648 -- Procedure called if value is determined to be out of range
1654 procedure Bad_Value is
1656 Apply_Compile_Time_Constraint_Error
1657 (Expr, "value not in range of}?", CE_Range_Check_Failed,
1662 -- Start of processing for Apply_Scalar_Range_Check
1665 if Inside_A_Generic then
1668 -- Return if check obviously not needed. Note that we do not check
1669 -- for the expander being inactive, since this routine does not
1670 -- insert any code, but it does generate useful warnings sometimes,
1671 -- which we would like even if we are in semantics only mode.
1673 elsif Target_Typ = Any_Type
1674 or else not Is_Scalar_Type (Target_Typ)
1675 or else Raises_Constraint_Error (Expr)
1680 -- Now, see if checks are suppressed
1683 Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component;
1685 if Is_Subscr_Ref then
1686 Arr := Prefix (Parnt);
1687 Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
1690 if not Do_Range_Check (Expr) then
1692 -- Subscript reference. Check for Index_Checks suppressed
1694 if Is_Subscr_Ref then
1696 -- Check array type and its base type
1698 if Index_Checks_Suppressed (Arr_Typ)
1699 or else Index_Checks_Suppressed (Base_Type (Arr_Typ))
1703 -- Check array itself if it is an entity name
1705 elsif Is_Entity_Name (Arr)
1706 and then Index_Checks_Suppressed (Entity (Arr))
1710 -- Check expression itself if it is an entity name
1712 elsif Is_Entity_Name (Expr)
1713 and then Index_Checks_Suppressed (Entity (Expr))
1718 -- All other cases, check for Range_Checks suppressed
1721 -- Check target type and its base type
1723 if Range_Checks_Suppressed (Target_Typ)
1724 or else Range_Checks_Suppressed (Base_Type (Target_Typ))
1728 -- Check expression itself if it is an entity name
1730 elsif Is_Entity_Name (Expr)
1731 and then Range_Checks_Suppressed (Entity (Expr))
1735 -- If Expr is part of an assignment statement, then check
1736 -- left side of assignment if it is an entity name.
1738 elsif Nkind (Parnt) = N_Assignment_Statement
1739 and then Is_Entity_Name (Name (Parnt))
1740 and then Range_Checks_Suppressed (Entity (Name (Parnt)))
1747 -- Do not set range checks if they are killed
1749 if Nkind (Expr) = N_Unchecked_Type_Conversion
1750 and then Kill_Range_Check (Expr)
1755 -- Do not set range checks for any values from System.Scalar_Values
1756 -- since the whole idea of such values is to avoid checking them!
1758 if Is_Entity_Name (Expr)
1759 and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values)
1764 -- Now see if we need a check
1766 if No (Source_Typ) then
1767 S_Typ := Etype (Expr);
1769 S_Typ := Source_Typ;
1772 if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then
1776 Is_Unconstrained_Subscr_Ref :=
1777 Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
1779 -- Always do a range check if the source type includes infinities
1780 -- and the target type does not include infinities. We do not do
1781 -- this if range checks are killed.
1783 if Is_Floating_Point_Type (S_Typ)
1784 and then Has_Infinities (S_Typ)
1785 and then not Has_Infinities (Target_Typ)
1787 Enable_Range_Check (Expr);
1790 -- Return if we know expression is definitely in the range of
1791 -- the target type as determined by Determine_Range. Right now
1792 -- we only do this for discrete types, and not fixed-point or
1793 -- floating-point types.
1795 -- The additional less-precise tests below catch these cases.
1797 -- Note: skip this if we are given a source_typ, since the point
1798 -- of supplying a Source_Typ is to stop us looking at the expression.
1799 -- could sharpen this test to be out parameters only ???
1801 if Is_Discrete_Type (Target_Typ)
1802 and then Is_Discrete_Type (Etype (Expr))
1803 and then not Is_Unconstrained_Subscr_Ref
1804 and then No (Source_Typ)
1807 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
1808 Thi : constant Node_Id := Type_High_Bound (Target_Typ);
1813 if Compile_Time_Known_Value (Tlo)
1814 and then Compile_Time_Known_Value (Thi)
1817 Lov : constant Uint := Expr_Value (Tlo);
1818 Hiv : constant Uint := Expr_Value (Thi);
1821 -- If range is null, we for sure have a constraint error
1822 -- (we don't even need to look at the value involved,
1823 -- since all possible values will raise CE).
1830 -- Otherwise determine range of value
1832 Determine_Range (Expr, OK, Lo, Hi);
1836 -- If definitely in range, all OK
1838 if Lo >= Lov and then Hi <= Hiv then
1841 -- If definitely not in range, warn
1843 elsif Lov > Hi or else Hiv < Lo then
1847 -- Otherwise we don't know
1859 Is_Floating_Point_Type (S_Typ)
1860 or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
1862 -- Check if we can determine at compile time whether Expr is in the
1863 -- range of the target type. Note that if S_Typ is within the bounds
1864 -- of Target_Typ then this must be the case. This check is meaningful
1865 -- only if this is not a conversion between integer and real types.
1867 if not Is_Unconstrained_Subscr_Ref
1869 Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
1871 (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
1873 Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real))
1877 elsif Is_Out_Of_Range (Expr, Target_Typ, Fixed_Int, Int_Real) then
1881 -- In the floating-point case, we only do range checks if the
1882 -- type is constrained. We definitely do NOT want range checks
1883 -- for unconstrained types, since we want to have infinities
1885 elsif Is_Floating_Point_Type (S_Typ) then
1886 if Is_Constrained (S_Typ) then
1887 Enable_Range_Check (Expr);
1890 -- For all other cases we enable a range check unconditionally
1893 Enable_Range_Check (Expr);
1896 end Apply_Scalar_Range_Check;
1898 ----------------------------------
1899 -- Apply_Selected_Length_Checks --
1900 ----------------------------------
1902 procedure Apply_Selected_Length_Checks
1904 Target_Typ : Entity_Id;
1905 Source_Typ : Entity_Id;
1906 Do_Static : Boolean)
1909 R_Result : Check_Result;
1912 Loc : constant Source_Ptr := Sloc (Ck_Node);
1913 Checks_On : constant Boolean :=
1914 (not Index_Checks_Suppressed (Target_Typ))
1916 (not Length_Checks_Suppressed (Target_Typ));
1919 if not Expander_Active then
1924 Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
1926 for J in 1 .. 2 loop
1927 R_Cno := R_Result (J);
1928 exit when No (R_Cno);
1930 -- A length check may mention an Itype which is attached to a
1931 -- subsequent node. At the top level in a package this can cause
1932 -- an order-of-elaboration problem, so we make sure that the itype
1933 -- is referenced now.
1935 if Ekind (Current_Scope) = E_Package
1936 and then Is_Compilation_Unit (Current_Scope)
1938 Ensure_Defined (Target_Typ, Ck_Node);
1940 if Present (Source_Typ) then
1941 Ensure_Defined (Source_Typ, Ck_Node);
1943 elsif Is_Itype (Etype (Ck_Node)) then
1944 Ensure_Defined (Etype (Ck_Node), Ck_Node);
1948 -- If the item is a conditional raise of constraint error,
1949 -- then have a look at what check is being performed and
1952 if Nkind (R_Cno) = N_Raise_Constraint_Error
1953 and then Present (Condition (R_Cno))
1955 Cond := Condition (R_Cno);
1957 if not Has_Dynamic_Length_Check (Ck_Node)
1960 Insert_Action (Ck_Node, R_Cno);
1962 if not Do_Static then
1963 Set_Has_Dynamic_Length_Check (Ck_Node);
1967 -- Output a warning if the condition is known to be True
1969 if Is_Entity_Name (Cond)
1970 and then Entity (Cond) = Standard_True
1972 Apply_Compile_Time_Constraint_Error
1973 (Ck_Node, "wrong length for array of}?",
1974 CE_Length_Check_Failed,
1978 -- If we were only doing a static check, or if checks are not
1979 -- on, then we want to delete the check, since it is not needed.
1980 -- We do this by replacing the if statement by a null statement
1982 elsif Do_Static or else not Checks_On then
1983 Rewrite (R_Cno, Make_Null_Statement (Loc));
1987 Install_Static_Check (R_Cno, Loc);
1992 end Apply_Selected_Length_Checks;
1994 ---------------------------------
1995 -- Apply_Selected_Range_Checks --
1996 ---------------------------------
1998 procedure Apply_Selected_Range_Checks
2000 Target_Typ : Entity_Id;
2001 Source_Typ : Entity_Id;
2002 Do_Static : Boolean)
2005 R_Result : Check_Result;
2008 Loc : constant Source_Ptr := Sloc (Ck_Node);
2009 Checks_On : constant Boolean :=
2010 (not Index_Checks_Suppressed (Target_Typ))
2012 (not Range_Checks_Suppressed (Target_Typ));
2015 if not Expander_Active or else not Checks_On then
2020 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
2022 for J in 1 .. 2 loop
2024 R_Cno := R_Result (J);
2025 exit when No (R_Cno);
2027 -- If the item is a conditional raise of constraint error,
2028 -- then have a look at what check is being performed and
2031 if Nkind (R_Cno) = N_Raise_Constraint_Error
2032 and then Present (Condition (R_Cno))
2034 Cond := Condition (R_Cno);
2036 if not Has_Dynamic_Range_Check (Ck_Node) then
2037 Insert_Action (Ck_Node, R_Cno);
2039 if not Do_Static then
2040 Set_Has_Dynamic_Range_Check (Ck_Node);
2044 -- Output a warning if the condition is known to be True
2046 if Is_Entity_Name (Cond)
2047 and then Entity (Cond) = Standard_True
2049 -- Since an N_Range is technically not an expression, we
2050 -- have to set one of the bounds to C_E and then just flag
2051 -- the N_Range. The warning message will point to the
2052 -- lower bound and complain about a range, which seems OK.
2054 if Nkind (Ck_Node) = N_Range then
2055 Apply_Compile_Time_Constraint_Error
2056 (Low_Bound (Ck_Node), "static range out of bounds of}?",
2057 CE_Range_Check_Failed,
2061 Set_Raises_Constraint_Error (Ck_Node);
2064 Apply_Compile_Time_Constraint_Error
2065 (Ck_Node, "static value out of range of}?",
2066 CE_Range_Check_Failed,
2071 -- If we were only doing a static check, or if checks are not
2072 -- on, then we want to delete the check, since it is not needed.
2073 -- We do this by replacing the if statement by a null statement
2075 elsif Do_Static or else not Checks_On then
2076 Rewrite (R_Cno, Make_Null_Statement (Loc));
2080 Install_Static_Check (R_Cno, Loc);
2083 end Apply_Selected_Range_Checks;
2085 -------------------------------
2086 -- Apply_Static_Length_Check --
2087 -------------------------------
2089 procedure Apply_Static_Length_Check
2091 Target_Typ : Entity_Id;
2092 Source_Typ : Entity_Id := Empty)
2095 Apply_Selected_Length_Checks
2096 (Expr, Target_Typ, Source_Typ, Do_Static => True);
2097 end Apply_Static_Length_Check;
2099 -------------------------------------
2100 -- Apply_Subscript_Validity_Checks --
2101 -------------------------------------
2103 procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
2107 pragma Assert (Nkind (Expr) = N_Indexed_Component);
2109 -- Loop through subscripts
2111 Sub := First (Expressions (Expr));
2112 while Present (Sub) loop
2114 -- Check one subscript. Note that we do not worry about
2115 -- enumeration type with holes, since we will convert the
2116 -- value to a Pos value for the subscript, and that convert
2117 -- will do the necessary validity check.
2119 Ensure_Valid (Sub, Holes_OK => True);
2121 -- Move to next subscript
2125 end Apply_Subscript_Validity_Checks;
2127 ----------------------------------
2128 -- Apply_Type_Conversion_Checks --
2129 ----------------------------------
2131 procedure Apply_Type_Conversion_Checks (N : Node_Id) is
2132 Target_Type : constant Entity_Id := Etype (N);
2133 Target_Base : constant Entity_Id := Base_Type (Target_Type);
2134 Expr : constant Node_Id := Expression (N);
2135 Expr_Type : constant Entity_Id := Etype (Expr);
2138 if Inside_A_Generic then
2141 -- Skip these checks if serious errors detected, there are some nasty
2142 -- situations of incomplete trees that blow things up.
2144 elsif Serious_Errors_Detected > 0 then
2147 -- Scalar type conversions of the form Target_Type (Expr) require
2148 -- a range check if we cannot be sure that Expr is in the base type
2149 -- of Target_Typ and also that Expr is in the range of Target_Typ.
2150 -- These are not quite the same condition from an implementation
2151 -- point of view, but clearly the second includes the first.
2153 elsif Is_Scalar_Type (Target_Type) then
2155 Conv_OK : constant Boolean := Conversion_OK (N);
2156 -- If the Conversion_OK flag on the type conversion is set
2157 -- and no floating point type is involved in the type conversion
2158 -- then fixed point values must be read as integral values.
2160 Float_To_Int : constant Boolean :=
2161 Is_Floating_Point_Type (Expr_Type)
2162 and then Is_Integer_Type (Target_Type);
2165 if not Overflow_Checks_Suppressed (Target_Base)
2166 and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
2167 and then not Float_To_Int
2169 Set_Do_Overflow_Check (N);
2172 if not Range_Checks_Suppressed (Target_Type)
2173 and then not Range_Checks_Suppressed (Expr_Type)
2175 if Float_To_Int then
2176 Apply_Float_Conversion_Check (Expr, Target_Type);
2178 Apply_Scalar_Range_Check
2179 (Expr, Target_Type, Fixed_Int => Conv_OK);
2184 elsif Comes_From_Source (N)
2185 and then Is_Record_Type (Target_Type)
2186 and then Is_Derived_Type (Target_Type)
2187 and then not Is_Tagged_Type (Target_Type)
2188 and then not Is_Constrained (Target_Type)
2189 and then Present (Stored_Constraint (Target_Type))
2191 -- An unconstrained derived type may have inherited discriminant
2192 -- Build an actual discriminant constraint list using the stored
2193 -- constraint, to verify that the expression of the parent type
2194 -- satisfies the constraints imposed by the (unconstrained!)
2195 -- derived type. This applies to value conversions, not to view
2196 -- conversions of tagged types.
2199 Loc : constant Source_Ptr := Sloc (N);
2201 Constraint : Elmt_Id;
2202 Discr_Value : Node_Id;
2205 New_Constraints : constant Elist_Id := New_Elmt_List;
2206 Old_Constraints : constant Elist_Id :=
2207 Discriminant_Constraint (Expr_Type);
2210 Constraint := First_Elmt (Stored_Constraint (Target_Type));
2212 while Present (Constraint) loop
2213 Discr_Value := Node (Constraint);
2215 if Is_Entity_Name (Discr_Value)
2216 and then Ekind (Entity (Discr_Value)) = E_Discriminant
2218 Discr := Corresponding_Discriminant (Entity (Discr_Value));
2221 and then Scope (Discr) = Base_Type (Expr_Type)
2223 -- Parent is constrained by new discriminant. Obtain
2224 -- Value of original discriminant in expression. If
2225 -- the new discriminant has been used to constrain more
2226 -- than one of the stored discriminants, this will
2227 -- provide the required consistency check.
2230 Make_Selected_Component (Loc,
2232 Duplicate_Subexpr_No_Checks
2233 (Expr, Name_Req => True),
2235 Make_Identifier (Loc, Chars (Discr))),
2239 -- Discriminant of more remote ancestor ???
2244 -- Derived type definition has an explicit value for
2245 -- this stored discriminant.
2249 (Duplicate_Subexpr_No_Checks (Discr_Value),
2253 Next_Elmt (Constraint);
2256 -- Use the unconstrained expression type to retrieve the
2257 -- discriminants of the parent, and apply momentarily the
2258 -- discriminant constraint synthesized above.
2260 Set_Discriminant_Constraint (Expr_Type, New_Constraints);
2261 Cond := Build_Discriminant_Checks (Expr, Expr_Type);
2262 Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
2265 Make_Raise_Constraint_Error (Loc,
2267 Reason => CE_Discriminant_Check_Failed));
2270 -- For arrays, conversions are applied during expansion, to take
2271 -- into accounts changes of representation. The checks become range
2272 -- checks on the base type or length checks on the subtype, depending
2273 -- on whether the target type is unconstrained or constrained.
2278 end Apply_Type_Conversion_Checks;
2280 ----------------------------------------------
2281 -- Apply_Universal_Integer_Attribute_Checks --
2282 ----------------------------------------------
2284 procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is
2285 Loc : constant Source_Ptr := Sloc (N);
2286 Typ : constant Entity_Id := Etype (N);
2289 if Inside_A_Generic then
2292 -- Nothing to do if checks are suppressed
2294 elsif Range_Checks_Suppressed (Typ)
2295 and then Overflow_Checks_Suppressed (Typ)
2299 -- Nothing to do if the attribute does not come from source. The
2300 -- internal attributes we generate of this type do not need checks,
2301 -- and furthermore the attempt to check them causes some circular
2302 -- elaboration orders when dealing with packed types.
2304 elsif not Comes_From_Source (N) then
2307 -- If the prefix is a selected component that depends on a discriminant
2308 -- the check may improperly expose a discriminant instead of using
2309 -- the bounds of the object itself. Set the type of the attribute to
2310 -- the base type of the context, so that a check will be imposed when
2311 -- needed (e.g. if the node appears as an index).
2313 elsif Nkind (Prefix (N)) = N_Selected_Component
2314 and then Ekind (Typ) = E_Signed_Integer_Subtype
2315 and then Depends_On_Discriminant (Scalar_Range (Typ))
2317 Set_Etype (N, Base_Type (Typ));
2319 -- Otherwise, replace the attribute node with a type conversion
2320 -- node whose expression is the attribute, retyped to universal
2321 -- integer, and whose subtype mark is the target type. The call
2322 -- to analyze this conversion will set range and overflow checks
2323 -- as required for proper detection of an out of range value.
2326 Set_Etype (N, Universal_Integer);
2327 Set_Analyzed (N, True);
2330 Make_Type_Conversion (Loc,
2331 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
2332 Expression => Relocate_Node (N)));
2334 Analyze_And_Resolve (N, Typ);
2338 end Apply_Universal_Integer_Attribute_Checks;
2340 -------------------------------
2341 -- Build_Discriminant_Checks --
2342 -------------------------------
2344 function Build_Discriminant_Checks
2346 T_Typ : Entity_Id) return Node_Id
2348 Loc : constant Source_Ptr := Sloc (N);
2351 Disc_Ent : Entity_Id;
2357 Disc := First_Elmt (Discriminant_Constraint (T_Typ));
2359 -- For a fully private type, use the discriminants of the parent type
2361 if Is_Private_Type (T_Typ)
2362 and then No (Full_View (T_Typ))
2364 Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ)));
2366 Disc_Ent := First_Discriminant (T_Typ);
2369 while Present (Disc) loop
2370 Dval := Node (Disc);
2372 if Nkind (Dval) = N_Identifier
2373 and then Ekind (Entity (Dval)) = E_Discriminant
2375 Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
2377 Dval := Duplicate_Subexpr_No_Checks (Dval);
2381 Make_Selected_Component (Loc,
2383 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
2385 Make_Identifier (Loc, Chars (Disc_Ent)));
2387 Set_Is_In_Discriminant_Check (Dref);
2389 Evolve_Or_Else (Cond,
2392 Right_Opnd => Dval));
2395 Next_Discriminant (Disc_Ent);
2399 end Build_Discriminant_Checks;
2401 -----------------------------------
2402 -- Check_Valid_Lvalue_Subscripts --
2403 -----------------------------------
2405 procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is
2407 -- Skip this if range checks are suppressed
2409 if Range_Checks_Suppressed (Etype (Expr)) then
2412 -- Only do this check for expressions that come from source. We
2413 -- assume that expander generated assignments explicitly include
2414 -- any necessary checks. Note that this is not just an optimization,
2415 -- it avoids infinite recursions!
2417 elsif not Comes_From_Source (Expr) then
2420 -- For a selected component, check the prefix
2422 elsif Nkind (Expr) = N_Selected_Component then
2423 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
2426 -- Case of indexed component
2428 elsif Nkind (Expr) = N_Indexed_Component then
2429 Apply_Subscript_Validity_Checks (Expr);
2431 -- Prefix may itself be or contain an indexed component, and
2432 -- these subscripts need checking as well
2434 Check_Valid_Lvalue_Subscripts (Prefix (Expr));
2436 end Check_Valid_Lvalue_Subscripts;
2438 ----------------------------------
2439 -- Null_Exclusion_Static_Checks --
2440 ----------------------------------
2442 procedure Null_Exclusion_Static_Checks (N : Node_Id) is
2443 K : constant Node_Kind := Nkind (N);
2445 Related_Nod : Node_Id;
2446 Has_Null_Exclusion : Boolean := False;
2448 type Msg_Kind is (Components, Formals, Objects);
2449 Msg_K : Msg_Kind := Objects;
2450 -- Used by local subprograms to generate precise error messages
2452 procedure Check_Must_Be_Access
2454 Has_Null_Exclusion : Boolean);
2455 -- ??? local subprograms must have comment on spec
2457 procedure Check_Already_Null_Excluding_Type
2459 Has_Null_Exclusion : Boolean;
2460 Related_Nod : Node_Id);
2461 -- ??? local subprograms must have comment on spec
2463 procedure Check_Must_Be_Initialized
2465 Related_Nod : Node_Id);
2466 -- ??? local subprograms must have comment on spec
2468 procedure Check_Null_Not_Allowed (N : Node_Id);
2469 -- ??? local subprograms must have comment on spec
2471 -- ??? following bodies lack comments
2473 --------------------------
2474 -- Check_Must_Be_Access --
2475 --------------------------
2477 procedure Check_Must_Be_Access
2479 Has_Null_Exclusion : Boolean)
2482 if Has_Null_Exclusion
2483 and then not Is_Access_Type (Typ)
2485 Error_Msg_N ("(Ada 2005) must be an access type", Related_Nod);
2487 end Check_Must_Be_Access;
2489 ---------------------------------------
2490 -- Check_Already_Null_Excluding_Type --
2491 ---------------------------------------
2493 procedure Check_Already_Null_Excluding_Type
2495 Has_Null_Exclusion : Boolean;
2496 Related_Nod : Node_Id)
2499 if Has_Null_Exclusion
2500 and then Can_Never_Be_Null (Typ)
2503 ("(Ada 2005) already a null-excluding type", Related_Nod);
2505 end Check_Already_Null_Excluding_Type;
2507 -------------------------------
2508 -- Check_Must_Be_Initialized --
2509 -------------------------------
2511 procedure Check_Must_Be_Initialized
2513 Related_Nod : Node_Id)
2515 Expr : constant Node_Id := Expression (N);
2518 pragma Assert (Nkind (N) = N_Component_Declaration
2519 or else Nkind (N) = N_Object_Declaration);
2521 if not Present (Expr) then
2525 ("(Ada 2005) null-excluding components must be " &
2526 "initialized", Related_Nod);
2530 ("(Ada 2005) null-excluding formals must be initialized",
2535 ("(Ada 2005) null-excluding objects must be initialized",
2539 end Check_Must_Be_Initialized;
2541 ----------------------------
2542 -- Check_Null_Not_Allowed --
2543 ----------------------------
2545 procedure Check_Null_Not_Allowed (N : Node_Id) is
2546 Expr : constant Node_Id := Expression (N);
2550 and then Nkind (Expr) = N_Null
2555 ("(Ada 2005) NULL not allowed in null-excluding " &
2556 "components", Expr);
2560 ("(Ada 2005) NULL not allowed in null-excluding formals",
2565 ("(Ada 2005) NULL not allowed in null-excluding objects",
2569 end Check_Null_Not_Allowed;
2571 -- Start of processing for Null_Exclusion_Static_Checks
2574 pragma Assert (K = N_Component_Declaration
2575 or else K = N_Parameter_Specification
2576 or else K = N_Object_Declaration
2577 or else K = N_Discriminant_Specification
2578 or else K = N_Allocator);
2581 when N_Component_Declaration =>
2582 Msg_K := Components;
2584 if not Present (Access_Definition (Component_Definition (N))) then
2585 Has_Null_Exclusion := Null_Exclusion_Present
2586 (Component_Definition (N));
2587 Typ := Etype (Subtype_Indication (Component_Definition (N)));
2588 Related_Nod := Subtype_Indication (Component_Definition (N));
2589 Check_Must_Be_Access (Typ, Has_Null_Exclusion);
2590 Check_Already_Null_Excluding_Type
2591 (Typ, Has_Null_Exclusion, Related_Nod);
2592 Check_Must_Be_Initialized (N, Related_Nod);
2595 Check_Null_Not_Allowed (N);
2597 when N_Parameter_Specification =>
2599 Has_Null_Exclusion := Null_Exclusion_Present (N);
2600 Typ := Entity (Parameter_Type (N));
2601 Related_Nod := Parameter_Type (N);
2602 Check_Must_Be_Access (Typ, Has_Null_Exclusion);
2603 Check_Already_Null_Excluding_Type
2604 (Typ, Has_Null_Exclusion, Related_Nod);
2605 Check_Null_Not_Allowed (N);
2607 when N_Object_Declaration =>
2609 Has_Null_Exclusion := Null_Exclusion_Present (N);
2610 Typ := Entity (Object_Definition (N));
2611 Related_Nod := Object_Definition (N);
2612 Check_Must_Be_Access (Typ, Has_Null_Exclusion);
2613 Check_Already_Null_Excluding_Type
2614 (Typ, Has_Null_Exclusion, Related_Nod);
2615 Check_Must_Be_Initialized (N, Related_Nod);
2616 Check_Null_Not_Allowed (N);
2618 when N_Discriminant_Specification =>
2619 Msg_K := Components;
2621 if Nkind (Discriminant_Type (N)) /= N_Access_Definition then
2622 Has_Null_Exclusion := Null_Exclusion_Present (N);
2623 Typ := Etype (Defining_Identifier (N));
2624 Related_Nod := Discriminant_Type (N);
2625 Check_Must_Be_Access (Typ, Has_Null_Exclusion);
2626 Check_Already_Null_Excluding_Type
2627 (Typ, Has_Null_Exclusion, Related_Nod);
2630 Check_Null_Not_Allowed (N);
2634 Has_Null_Exclusion := Null_Exclusion_Present (N);
2635 Typ := Etype (Expression (N));
2637 if Nkind (Expression (N)) = N_Qualified_Expression then
2638 Related_Nod := Subtype_Mark (Expression (N));
2640 Related_Nod := Expression (N);
2643 Check_Must_Be_Access (Typ, Has_Null_Exclusion);
2644 Check_Already_Null_Excluding_Type
2645 (Typ, Has_Null_Exclusion, Related_Nod);
2646 Check_Null_Not_Allowed (N);
2649 raise Program_Error;
2651 end Null_Exclusion_Static_Checks;
2653 ----------------------------------
2654 -- Conditional_Statements_Begin --
2655 ----------------------------------
2657 procedure Conditional_Statements_Begin is
2659 Saved_Checks_TOS := Saved_Checks_TOS + 1;
2661 -- If stack overflows, kill all checks, that way we know to
2662 -- simply reset the number of saved checks to zero on return.
2663 -- This should never occur in practice.
2665 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
2668 -- In the normal case, we just make a new stack entry saving
2669 -- the current number of saved checks for a later restore.
2672 Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks;
2674 if Debug_Flag_CC then
2675 w ("Conditional_Statements_Begin: Num_Saved_Checks = ",
2679 end Conditional_Statements_Begin;
2681 --------------------------------
2682 -- Conditional_Statements_End --
2683 --------------------------------
2685 procedure Conditional_Statements_End is
2687 pragma Assert (Saved_Checks_TOS > 0);
2689 -- If the saved checks stack overflowed, then we killed all
2690 -- checks, so setting the number of saved checks back to
2691 -- zero is correct. This should never occur in practice.
2693 if Saved_Checks_TOS > Saved_Checks_Stack'Last then
2694 Num_Saved_Checks := 0;
2696 -- In the normal case, restore the number of saved checks
2697 -- from the top stack entry.
2700 Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
2701 if Debug_Flag_CC then
2702 w ("Conditional_Statements_End: Num_Saved_Checks = ",
2707 Saved_Checks_TOS := Saved_Checks_TOS - 1;
2708 end Conditional_Statements_End;
2710 ---------------------
2711 -- Determine_Range --
2712 ---------------------
2714 Cache_Size : constant := 2 ** 10;
2715 type Cache_Index is range 0 .. Cache_Size - 1;
2716 -- Determine size of below cache (power of 2 is more efficient!)
2718 Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
2719 Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
2720 Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
2721 -- The above arrays are used to implement a small direct cache
2722 -- for Determine_Range calls. Because of the way Determine_Range
2723 -- recursively traces subexpressions, and because overflow checking
2724 -- calls the routine on the way up the tree, a quadratic behavior
2725 -- can otherwise be encountered in large expressions. The cache
2726 -- entry for node N is stored in the (N mod Cache_Size) entry, and
2727 -- can be validated by checking the actual node value stored there.
2729 procedure Determine_Range
2735 Typ : constant Entity_Id := Etype (N);
2739 -- Lo and Hi bounds of left operand
2743 -- Lo and Hi bounds of right (or only) operand
2746 -- Temp variable used to hold a bound node
2749 -- High bound of base type of expression
2753 -- Refined values for low and high bounds, after tightening
2756 -- Used in lower level calls to indicate if call succeeded
2758 Cindex : Cache_Index;
2759 -- Used to search cache
2761 function OK_Operands return Boolean;
2762 -- Used for binary operators. Determines the ranges of the left and
2763 -- right operands, and if they are both OK, returns True, and puts
2764 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left
2770 function OK_Operands return Boolean is
2772 Determine_Range (Left_Opnd (N), OK1, Lo_Left, Hi_Left);
2778 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
2782 -- Start of processing for Determine_Range
2785 -- Prevent junk warnings by initializing range variables
2792 -- If the type is not discrete, or is undefined, then we can't
2793 -- do anything about determining the range.
2795 if No (Typ) or else not Is_Discrete_Type (Typ)
2796 or else Error_Posted (N)
2802 -- For all other cases, we can determine the range
2806 -- If value is compile time known, then the possible range is the
2807 -- one value that we know this expression definitely has!
2809 if Compile_Time_Known_Value (N) then
2810 Lo := Expr_Value (N);
2815 -- Return if already in the cache
2817 Cindex := Cache_Index (N mod Cache_Size);
2819 if Determine_Range_Cache_N (Cindex) = N then
2820 Lo := Determine_Range_Cache_Lo (Cindex);
2821 Hi := Determine_Range_Cache_Hi (Cindex);
2825 -- Otherwise, start by finding the bounds of the type of the
2826 -- expression, the value cannot be outside this range (if it
2827 -- is, then we have an overflow situation, which is a separate
2828 -- check, we are talking here only about the expression value).
2830 -- We use the actual bound unless it is dynamic, in which case
2831 -- use the corresponding base type bound if possible. If we can't
2832 -- get a bound then we figure we can't determine the range (a
2833 -- peculiar case, that perhaps cannot happen, but there is no
2834 -- point in bombing in this optimization circuit.
2836 -- First the low bound
2838 Bound := Type_Low_Bound (Typ);
2840 if Compile_Time_Known_Value (Bound) then
2841 Lo := Expr_Value (Bound);
2843 elsif Compile_Time_Known_Value (Type_Low_Bound (Base_Type (Typ))) then
2844 Lo := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
2851 -- Now the high bound
2853 Bound := Type_High_Bound (Typ);
2855 -- We need the high bound of the base type later on, and this should
2856 -- always be compile time known. Again, it is not clear that this
2857 -- can ever be false, but no point in bombing.
2859 if Compile_Time_Known_Value (Type_High_Bound (Base_Type (Typ))) then
2860 Hbound := Expr_Value (Type_High_Bound (Base_Type (Typ)));
2868 -- If we have a static subtype, then that may have a tighter bound
2869 -- so use the upper bound of the subtype instead in this case.
2871 if Compile_Time_Known_Value (Bound) then
2872 Hi := Expr_Value (Bound);
2875 -- We may be able to refine this value in certain situations. If
2876 -- refinement is possible, then Lor and Hir are set to possibly
2877 -- tighter bounds, and OK1 is set to True.
2881 -- For unary plus, result is limited by range of operand
2884 Determine_Range (Right_Opnd (N), OK1, Lor, Hir);
2886 -- For unary minus, determine range of operand, and negate it
2889 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
2896 -- For binary addition, get range of each operand and do the
2897 -- addition to get the result range.
2901 Lor := Lo_Left + Lo_Right;
2902 Hir := Hi_Left + Hi_Right;
2905 -- Division is tricky. The only case we consider is where the
2906 -- right operand is a positive constant, and in this case we
2907 -- simply divide the bounds of the left operand
2911 if Lo_Right = Hi_Right
2912 and then Lo_Right > 0
2914 Lor := Lo_Left / Lo_Right;
2915 Hir := Hi_Left / Lo_Right;
2922 -- For binary subtraction, get range of each operand and do
2923 -- the worst case subtraction to get the result range.
2925 when N_Op_Subtract =>
2927 Lor := Lo_Left - Hi_Right;
2928 Hir := Hi_Left - Lo_Right;
2931 -- For MOD, if right operand is a positive constant, then
2932 -- result must be in the allowable range of mod results.
2936 if Lo_Right = Hi_Right
2937 and then Lo_Right /= 0
2939 if Lo_Right > 0 then
2941 Hir := Lo_Right - 1;
2943 else -- Lo_Right < 0
2944 Lor := Lo_Right + 1;
2953 -- For REM, if right operand is a positive constant, then
2954 -- result must be in the allowable range of mod results.
2958 if Lo_Right = Hi_Right
2959 and then Lo_Right /= 0
2962 Dval : constant Uint := (abs Lo_Right) - 1;
2965 -- The sign of the result depends on the sign of the
2966 -- dividend (but not on the sign of the divisor, hence
2967 -- the abs operation above).
2987 -- Attribute reference cases
2989 when N_Attribute_Reference =>
2990 case Attribute_Name (N) is
2992 -- For Pos/Val attributes, we can refine the range using the
2993 -- possible range of values of the attribute expression
2995 when Name_Pos | Name_Val =>
2996 Determine_Range (First (Expressions (N)), OK1, Lor, Hir);
2998 -- For Length attribute, use the bounds of the corresponding
2999 -- index type to refine the range.
3003 Atyp : Entity_Id := Etype (Prefix (N));
3011 if Is_Access_Type (Atyp) then
3012 Atyp := Designated_Type (Atyp);
3015 -- For string literal, we know exact value
3017 if Ekind (Atyp) = E_String_Literal_Subtype then
3019 Lo := String_Literal_Length (Atyp);
3020 Hi := String_Literal_Length (Atyp);
3024 -- Otherwise check for expression given
3026 if No (Expressions (N)) then
3030 UI_To_Int (Expr_Value (First (Expressions (N))));
3033 Indx := First_Index (Atyp);
3034 for J in 2 .. Inum loop
3035 Indx := Next_Index (Indx);
3039 (Type_Low_Bound (Etype (Indx)), OK1, LL, LU);
3043 (Type_High_Bound (Etype (Indx)), OK1, UL, UU);
3047 -- The maximum value for Length is the biggest
3048 -- possible gap between the values of the bounds.
3049 -- But of course, this value cannot be negative.
3051 Hir := UI_Max (Uint_0, UU - LL);
3053 -- For constrained arrays, the minimum value for
3054 -- Length is taken from the actual value of the
3055 -- bounds, since the index will be exactly of
3058 if Is_Constrained (Atyp) then
3059 Lor := UI_Max (Uint_0, UL - LU);
3061 -- For an unconstrained array, the minimum value
3062 -- for length is always zero.
3071 -- No special handling for other attributes
3072 -- Probably more opportunities exist here ???
3079 -- For type conversion from one discrete type to another, we
3080 -- can refine the range using the converted value.
3082 when N_Type_Conversion =>
3083 Determine_Range (Expression (N), OK1, Lor, Hir);
3085 -- Nothing special to do for all other expression kinds
3093 -- At this stage, if OK1 is true, then we know that the actual
3094 -- result of the computed expression is in the range Lor .. Hir.
3095 -- We can use this to restrict the possible range of results.
3099 -- If the refined value of the low bound is greater than the
3100 -- type high bound, then reset it to the more restrictive
3101 -- value. However, we do NOT do this for the case of a modular
3102 -- type where the possible upper bound on the value is above the
3103 -- base type high bound, because that means the result could wrap.
3106 and then not (Is_Modular_Integer_Type (Typ)
3107 and then Hir > Hbound)
3112 -- Similarly, if the refined value of the high bound is less
3113 -- than the value so far, then reset it to the more restrictive
3114 -- value. Again, we do not do this if the refined low bound is
3115 -- negative for a modular type, since this would wrap.
3118 and then not (Is_Modular_Integer_Type (Typ)
3119 and then Lor < Uint_0)
3125 -- Set cache entry for future call and we are all done
3127 Determine_Range_Cache_N (Cindex) := N;
3128 Determine_Range_Cache_Lo (Cindex) := Lo;
3129 Determine_Range_Cache_Hi (Cindex) := Hi;
3132 -- If any exception occurs, it means that we have some bug in the compiler
3133 -- possibly triggered by a previous error, or by some unforseen peculiar
3134 -- occurrence. However, this is only an optimization attempt, so there is
3135 -- really no point in crashing the compiler. Instead we just decide, too
3136 -- bad, we can't figure out a range in this case after all.
3141 -- Debug flag K disables this behavior (useful for debugging)
3143 if Debug_Flag_K then
3151 end Determine_Range;
3153 ------------------------------------
3154 -- Discriminant_Checks_Suppressed --
3155 ------------------------------------
3157 function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
3160 if Is_Unchecked_Union (E) then
3162 elsif Checks_May_Be_Suppressed (E) then
3163 return Is_Check_Suppressed (E, Discriminant_Check);
3167 return Scope_Suppress (Discriminant_Check);
3168 end Discriminant_Checks_Suppressed;
3170 --------------------------------
3171 -- Division_Checks_Suppressed --
3172 --------------------------------
3174 function Division_Checks_Suppressed (E : Entity_Id) return Boolean is
3176 if Present (E) and then Checks_May_Be_Suppressed (E) then
3177 return Is_Check_Suppressed (E, Division_Check);
3179 return Scope_Suppress (Division_Check);
3181 end Division_Checks_Suppressed;
3183 -----------------------------------
3184 -- Elaboration_Checks_Suppressed --
3185 -----------------------------------
3187 function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
3190 if Kill_Elaboration_Checks (E) then
3192 elsif Checks_May_Be_Suppressed (E) then
3193 return Is_Check_Suppressed (E, Elaboration_Check);
3197 return Scope_Suppress (Elaboration_Check);
3198 end Elaboration_Checks_Suppressed;
3200 ---------------------------
3201 -- Enable_Overflow_Check --
3202 ---------------------------
3204 procedure Enable_Overflow_Check (N : Node_Id) is
3205 Typ : constant Entity_Id := Base_Type (Etype (N));
3214 if Debug_Flag_CC then
3215 w ("Enable_Overflow_Check for node ", Int (N));
3216 Write_Str (" Source location = ");
3221 -- Nothing to do if the range of the result is known OK. We skip
3222 -- this for conversions, since the caller already did the check,
3223 -- and in any case the condition for deleting the check for a
3224 -- type conversion is different in any case.
3226 if Nkind (N) /= N_Type_Conversion then
3227 Determine_Range (N, OK, Lo, Hi);
3229 -- Note in the test below that we assume that if a bound of the
3230 -- range is equal to that of the type. That's not quite accurate
3231 -- but we do this for the following reasons:
3233 -- a) The way that Determine_Range works, it will typically report
3234 -- the bounds of the value as being equal to the bounds of the
3235 -- type, because it either can't tell anything more precise, or
3236 -- does not think it is worth the effort to be more precise.
3238 -- b) It is very unusual to have a situation in which this would
3239 -- generate an unnecessary overflow check (an example would be
3240 -- a subtype with a range 0 .. Integer'Last - 1 to which the
3241 -- literal value one is added.
3243 -- c) The alternative is a lot of special casing in this routine
3244 -- which would partially duplicate Determine_Range processing.
3247 and then Lo > Expr_Value (Type_Low_Bound (Typ))
3248 and then Hi < Expr_Value (Type_High_Bound (Typ))
3250 if Debug_Flag_CC then
3251 w ("No overflow check required");
3258 -- If not in optimizing mode, set flag and we are done. We are also
3259 -- done (and just set the flag) if the type is not a discrete type,
3260 -- since it is not worth the effort to eliminate checks for other
3261 -- than discrete types. In addition, we take this same path if we
3262 -- have stored the maximum number of checks possible already (a
3263 -- very unlikely situation, but we do not want to blow up!)
3265 if Optimization_Level = 0
3266 or else not Is_Discrete_Type (Etype (N))
3267 or else Num_Saved_Checks = Saved_Checks'Last
3269 Set_Do_Overflow_Check (N, True);
3271 if Debug_Flag_CC then
3272 w ("Optimization off");
3278 -- Otherwise evaluate and check the expression
3283 Target_Type => Empty,
3289 if Debug_Flag_CC then
3290 w ("Called Find_Check");
3294 w (" Check_Num = ", Chk);
3295 w (" Ent = ", Int (Ent));
3296 Write_Str (" Ofs = ");
3301 -- If check is not of form to optimize, then set flag and we are done
3304 Set_Do_Overflow_Check (N, True);
3308 -- If check is already performed, then return without setting flag
3311 if Debug_Flag_CC then
3312 w ("Check suppressed!");
3318 -- Here we will make a new entry for the new check
3320 Set_Do_Overflow_Check (N, True);
3321 Num_Saved_Checks := Num_Saved_Checks + 1;
3322 Saved_Checks (Num_Saved_Checks) :=
3327 Target_Type => Empty);
3329 if Debug_Flag_CC then
3330 w ("Make new entry, check number = ", Num_Saved_Checks);
3331 w (" Entity = ", Int (Ent));
3332 Write_Str (" Offset = ");
3334 w (" Check_Type = O");
3335 w (" Target_Type = Empty");
3338 -- If we get an exception, then something went wrong, probably because
3339 -- of an error in the structure of the tree due to an incorrect program.
3340 -- Or it may be a bug in the optimization circuit. In either case the
3341 -- safest thing is simply to set the check flag unconditionally.
3345 Set_Do_Overflow_Check (N, True);
3347 if Debug_Flag_CC then
3348 w (" exception occurred, overflow flag set");
3352 end Enable_Overflow_Check;
3354 ------------------------
3355 -- Enable_Range_Check --
3356 ------------------------
3358 procedure Enable_Range_Check (N : Node_Id) is
3367 -- Return if unchecked type conversion with range check killed.
3368 -- In this case we never set the flag (that's what Kill_Range_Check
3371 if Nkind (N) = N_Unchecked_Type_Conversion
3372 and then Kill_Range_Check (N)
3377 -- Debug trace output
3379 if Debug_Flag_CC then
3380 w ("Enable_Range_Check for node ", Int (N));
3381 Write_Str (" Source location = ");
3386 -- If not in optimizing mode, set flag and we are done. We are also
3387 -- done (and just set the flag) if the type is not a discrete type,
3388 -- since it is not worth the effort to eliminate checks for other
3389 -- than discrete types. In addition, we take this same path if we
3390 -- have stored the maximum number of checks possible already (a
3391 -- very unlikely situation, but we do not want to blow up!)
3393 if Optimization_Level = 0
3394 or else No (Etype (N))
3395 or else not Is_Discrete_Type (Etype (N))
3396 or else Num_Saved_Checks = Saved_Checks'Last
3398 Set_Do_Range_Check (N, True);
3400 if Debug_Flag_CC then
3401 w ("Optimization off");
3407 -- Otherwise find out the target type
3411 -- For assignment, use left side subtype
3413 if Nkind (P) = N_Assignment_Statement
3414 and then Expression (P) = N
3416 Ttyp := Etype (Name (P));
3418 -- For indexed component, use subscript subtype
3420 elsif Nkind (P) = N_Indexed_Component then
3427 Atyp := Etype (Prefix (P));
3429 if Is_Access_Type (Atyp) then
3430 Atyp := Designated_Type (Atyp);
3432 -- If the prefix is an access to an unconstrained array,
3433 -- perform check unconditionally: it depends on the bounds
3434 -- of an object and we cannot currently recognize whether
3435 -- the test may be redundant.
3437 if not Is_Constrained (Atyp) then
3438 Set_Do_Range_Check (N, True);
3443 Indx := First_Index (Atyp);
3444 Subs := First (Expressions (P));
3447 Ttyp := Etype (Indx);
3456 -- For now, ignore all other cases, they are not so interesting
3459 if Debug_Flag_CC then
3460 w (" target type not found, flag set");
3463 Set_Do_Range_Check (N, True);
3467 -- Evaluate and check the expression
3472 Target_Type => Ttyp,
3478 if Debug_Flag_CC then
3479 w ("Called Find_Check");
3480 w ("Target_Typ = ", Int (Ttyp));
3484 w (" Check_Num = ", Chk);
3485 w (" Ent = ", Int (Ent));
3486 Write_Str (" Ofs = ");
3491 -- If check is not of form to optimize, then set flag and we are done
3494 if Debug_Flag_CC then
3495 w (" expression not of optimizable type, flag set");
3498 Set_Do_Range_Check (N, True);
3502 -- If check is already performed, then return without setting flag
3505 if Debug_Flag_CC then
3506 w ("Check suppressed!");
3512 -- Here we will make a new entry for the new check
3514 Set_Do_Range_Check (N, True);
3515 Num_Saved_Checks := Num_Saved_Checks + 1;
3516 Saved_Checks (Num_Saved_Checks) :=
3521 Target_Type => Ttyp);
3523 if Debug_Flag_CC then
3524 w ("Make new entry, check number = ", Num_Saved_Checks);
3525 w (" Entity = ", Int (Ent));
3526 Write_Str (" Offset = ");
3528 w (" Check_Type = R");
3529 w (" Target_Type = ", Int (Ttyp));
3533 -- If we get an exception, then something went wrong, probably because
3534 -- of an error in the structure of the tree due to an incorrect program.
3535 -- Or it may be a bug in the optimization circuit. In either case the
3536 -- safest thing is simply to set the check flag unconditionally.
3540 Set_Do_Range_Check (N, True);
3542 if Debug_Flag_CC then
3543 w (" exception occurred, range flag set");
3547 end Enable_Range_Check;
3553 procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False) is
3554 Typ : constant Entity_Id := Etype (Expr);
3557 -- Ignore call if we are not doing any validity checking
3559 if not Validity_Checks_On then
3562 -- Ignore call if range checks suppressed on entity in question
3564 elsif Is_Entity_Name (Expr)
3565 and then Range_Checks_Suppressed (Entity (Expr))
3569 -- No check required if expression is from the expander, we assume
3570 -- the expander will generate whatever checks are needed. Note that
3571 -- this is not just an optimization, it avoids infinite recursions!
3573 -- Unchecked conversions must be checked, unless they are initialized
3574 -- scalar values, as in a component assignment in an init proc.
3576 -- In addition, we force a check if Force_Validity_Checks is set
3578 elsif not Comes_From_Source (Expr)
3579 and then not Force_Validity_Checks
3580 and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
3581 or else Kill_Range_Check (Expr))
3585 -- No check required if expression is known to have valid value
3587 elsif Expr_Known_Valid (Expr) then
3590 -- No check required if checks off
3592 elsif Range_Checks_Suppressed (Typ) then
3595 -- Ignore case of enumeration with holes where the flag is set not
3596 -- to worry about holes, since no special validity check is needed
3598 elsif Is_Enumeration_Type (Typ)
3599 and then Has_Non_Standard_Rep (Typ)
3604 -- No check required on the left-hand side of an assignment.
3606 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
3607 and then Expr = Name (Parent (Expr))
3611 -- An annoying special case. If this is an out parameter of a scalar
3612 -- type, then the value is not going to be accessed, therefore it is
3613 -- inappropriate to do any validity check at the call site.
3616 -- Only need to worry about scalar types
3618 if Is_Scalar_Type (Typ) then
3628 -- Find actual argument (which may be a parameter association)
3629 -- and the parent of the actual argument (the call statement)
3634 if Nkind (P) = N_Parameter_Association then
3639 -- Only need to worry if we are argument of a procedure
3640 -- call since functions don't have out parameters. If this
3641 -- is an indirect or dispatching call, get signature from
3642 -- the subprogram type.
3644 if Nkind (P) = N_Procedure_Call_Statement then
3645 L := Parameter_Associations (P);
3647 if Is_Entity_Name (Name (P)) then
3648 E := Entity (Name (P));
3650 pragma Assert (Nkind (Name (P)) = N_Explicit_Dereference);
3651 E := Etype (Name (P));
3654 -- Only need to worry if there are indeed actuals, and
3655 -- if this could be a procedure call, otherwise we cannot
3656 -- get a match (either we are not an argument, or the
3657 -- mode of the formal is not OUT). This test also filters
3658 -- out the generic case.
3660 if Is_Non_Empty_List (L)
3661 and then Is_Subprogram (E)
3663 -- This is the loop through parameters, looking to
3664 -- see if there is an OUT parameter for which we are
3667 F := First_Formal (E);
3670 while Present (F) loop
3671 if Ekind (F) = E_Out_Parameter and then A = N then
3684 -- If we fall through, a validity check is required. Note that it would
3685 -- not be good to set Do_Range_Check, even in contexts where this is
3686 -- permissible, since this flag causes checking against the target type,
3687 -- not the source type in contexts such as assignments
3689 Insert_Valid_Check (Expr);
3692 ----------------------
3693 -- Expr_Known_Valid --
3694 ----------------------
3696 function Expr_Known_Valid (Expr : Node_Id) return Boolean is
3697 Typ : constant Entity_Id := Etype (Expr);
3700 -- Non-scalar types are always consdered valid, since they never
3701 -- give rise to the issues of erroneous or bounded error behavior
3702 -- that are the concern. In formal reference manual terms the
3703 -- notion of validity only applies to scalar types.
3705 if not Is_Scalar_Type (Typ) then
3708 -- If no validity checking, then everything is considered valid
3710 elsif not Validity_Checks_On then
3713 -- Floating-point types are considered valid unless floating-point
3714 -- validity checks have been specifically turned on.
3716 elsif Is_Floating_Point_Type (Typ)
3717 and then not Validity_Check_Floating_Point
3721 -- If the expression is the value of an object that is known to
3722 -- be valid, then clearly the expression value itself is valid.
3724 elsif Is_Entity_Name (Expr)
3725 and then Is_Known_Valid (Entity (Expr))
3729 -- If the type is one for which all values are known valid, then
3730 -- we are sure that the value is valid except in the slightly odd
3731 -- case where the expression is a reference to a variable whose size
3732 -- has been explicitly set to a value greater than the object size.
3734 elsif Is_Known_Valid (Typ) then
3735 if Is_Entity_Name (Expr)
3736 and then Ekind (Entity (Expr)) = E_Variable
3737 and then Esize (Entity (Expr)) > Esize (Typ)
3744 -- Integer and character literals always have valid values, where
3745 -- appropriate these will be range checked in any case.
3747 elsif Nkind (Expr) = N_Integer_Literal
3749 Nkind (Expr) = N_Character_Literal
3753 -- If we have a type conversion or a qualification of a known valid
3754 -- value, then the result will always be valid.
3756 elsif Nkind (Expr) = N_Type_Conversion
3758 Nkind (Expr) = N_Qualified_Expression
3760 return Expr_Known_Valid (Expression (Expr));
3762 -- The result of any function call or operator is always considered
3763 -- valid, since we assume the necessary checks are done by the call.
3765 elsif Nkind (Expr) in N_Binary_Op
3767 Nkind (Expr) in N_Unary_Op
3769 Nkind (Expr) = N_Function_Call
3773 -- For all other cases, we do not know the expression is valid
3778 end Expr_Known_Valid;
3784 procedure Find_Check
3786 Check_Type : Character;
3787 Target_Type : Entity_Id;
3788 Entry_OK : out Boolean;
3789 Check_Num : out Nat;
3790 Ent : out Entity_Id;
3793 function Within_Range_Of
3794 (Target_Type : Entity_Id;
3795 Check_Type : Entity_Id) return Boolean;
3796 -- Given a requirement for checking a range against Target_Type, and
3797 -- and a range Check_Type against which a check has already been made,
3798 -- determines if the check against check type is sufficient to ensure
3799 -- that no check against Target_Type is required.
3801 ---------------------
3802 -- Within_Range_Of --
3803 ---------------------
3805 function Within_Range_Of
3806 (Target_Type : Entity_Id;
3807 Check_Type : Entity_Id) return Boolean
3810 if Target_Type = Check_Type then
3815 Tlo : constant Node_Id := Type_Low_Bound (Target_Type);
3816 Thi : constant Node_Id := Type_High_Bound (Target_Type);
3817 Clo : constant Node_Id := Type_Low_Bound (Check_Type);
3818 Chi : constant Node_Id := Type_High_Bound (Check_Type);
3822 or else (Compile_Time_Known_Value (Tlo)
3824 Compile_Time_Known_Value (Clo)
3826 Expr_Value (Clo) >= Expr_Value (Tlo)))
3829 or else (Compile_Time_Known_Value (Thi)
3831 Compile_Time_Known_Value (Chi)
3833 Expr_Value (Chi) <= Expr_Value (Clo)))
3841 end Within_Range_Of;
3843 -- Start of processing for Find_Check
3846 -- Establish default, to avoid warnings from GCC.
3850 -- Case of expression is simple entity reference
3852 if Is_Entity_Name (Expr) then
3853 Ent := Entity (Expr);
3856 -- Case of expression is entity + known constant
3858 elsif Nkind (Expr) = N_Op_Add
3859 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3860 and then Is_Entity_Name (Left_Opnd (Expr))
3862 Ent := Entity (Left_Opnd (Expr));
3863 Ofs := Expr_Value (Right_Opnd (Expr));
3865 -- Case of expression is entity - known constant
3867 elsif Nkind (Expr) = N_Op_Subtract
3868 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3869 and then Is_Entity_Name (Left_Opnd (Expr))
3871 Ent := Entity (Left_Opnd (Expr));
3872 Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr)));
3874 -- Any other expression is not of the right form
3883 -- Come here with expression of appropriate form, check if
3884 -- entity is an appropriate one for our purposes.
3886 if (Ekind (Ent) = E_Variable
3888 Ekind (Ent) = E_Constant
3890 Ekind (Ent) = E_Loop_Parameter
3892 Ekind (Ent) = E_In_Parameter)
3893 and then not Is_Library_Level_Entity (Ent)
3901 -- See if there is matching check already
3903 for J in reverse 1 .. Num_Saved_Checks loop
3905 SC : Saved_Check renames Saved_Checks (J);
3908 if SC.Killed = False
3909 and then SC.Entity = Ent
3910 and then SC.Offset = Ofs
3911 and then SC.Check_Type = Check_Type
3912 and then Within_Range_Of (Target_Type, SC.Target_Type)
3920 -- If we fall through entry was not found
3926 ---------------------------------
3927 -- Generate_Discriminant_Check --
3928 ---------------------------------
3930 -- Note: the code for this procedure is derived from the
3931 -- emit_discriminant_check routine a-trans.c v1.659.
3933 procedure Generate_Discriminant_Check (N : Node_Id) is
3934 Loc : constant Source_Ptr := Sloc (N);
3935 Pref : constant Node_Id := Prefix (N);
3936 Sel : constant Node_Id := Selector_Name (N);
3938 Orig_Comp : constant Entity_Id :=
3939 Original_Record_Component (Entity (Sel));
3940 -- The original component to be checked
3942 Discr_Fct : constant Entity_Id :=
3943 Discriminant_Checking_Func (Orig_Comp);
3944 -- The discriminant checking function
3947 -- One discriminant to be checked in the type
3949 Real_Discr : Entity_Id;
3950 -- Actual discriminant in the call
3952 Pref_Type : Entity_Id;
3953 -- Type of relevant prefix (ignoring private/access stuff)
3956 -- List of arguments for function call
3959 -- Keep track of the formal corresponding to the actual we build
3960 -- for each discriminant, in order to be able to perform the
3961 -- necessary type conversions.
3964 -- Selected component reference for checking function argument
3967 Pref_Type := Etype (Pref);
3969 -- Force evaluation of the prefix, so that it does not get evaluated
3970 -- twice (once for the check, once for the actual reference). Such a
3971 -- double evaluation is always a potential source of inefficiency,
3972 -- and is functionally incorrect in the volatile case, or when the
3973 -- prefix may have side-effects. An entity or a component of an
3974 -- entity requires no evaluation.
3976 if Is_Entity_Name (Pref) then
3977 if Treat_As_Volatile (Entity (Pref)) then
3978 Force_Evaluation (Pref, Name_Req => True);
3981 elsif Treat_As_Volatile (Etype (Pref)) then
3982 Force_Evaluation (Pref, Name_Req => True);
3984 elsif Nkind (Pref) = N_Selected_Component
3985 and then Is_Entity_Name (Prefix (Pref))
3990 Force_Evaluation (Pref, Name_Req => True);
3993 -- For a tagged type, use the scope of the original component to
3994 -- obtain the type, because ???
3996 if Is_Tagged_Type (Scope (Orig_Comp)) then
3997 Pref_Type := Scope (Orig_Comp);
3999 -- For an untagged derived type, use the discriminants of the
4000 -- parent which have been renamed in the derivation, possibly
4001 -- by a one-to-many discriminant constraint.
4002 -- For non-tagged type, initially get the Etype of the prefix
4005 if Is_Derived_Type (Pref_Type)
4006 and then Number_Discriminants (Pref_Type) /=
4007 Number_Discriminants (Etype (Base_Type (Pref_Type)))
4009 Pref_Type := Etype (Base_Type (Pref_Type));
4013 -- We definitely should have a checking function, This routine should
4014 -- not be called if no discriminant checking function is present.
4016 pragma Assert (Present (Discr_Fct));
4018 -- Create the list of the actual parameters for the call. This list
4019 -- is the list of the discriminant fields of the record expression to
4020 -- be discriminant checked.
4023 Formal := First_Formal (Discr_Fct);
4024 Discr := First_Discriminant (Pref_Type);
4025 while Present (Discr) loop
4027 -- If we have a corresponding discriminant field, and a parent
4028 -- subtype is present, then we want to use the corresponding
4029 -- discriminant since this is the one with the useful value.
4031 if Present (Corresponding_Discriminant (Discr))
4032 and then Ekind (Pref_Type) = E_Record_Type
4033 and then Present (Parent_Subtype (Pref_Type))
4035 Real_Discr := Corresponding_Discriminant (Discr);
4037 Real_Discr := Discr;
4040 -- Construct the reference to the discriminant
4043 Make_Selected_Component (Loc,
4045 Unchecked_Convert_To (Pref_Type,
4046 Duplicate_Subexpr (Pref)),
4047 Selector_Name => New_Occurrence_Of (Real_Discr, Loc));
4049 -- Manually analyze and resolve this selected component. We really
4050 -- want it just as it appears above, and do not want the expander
4051 -- playing discriminal games etc with this reference. Then we
4052 -- append the argument to the list we are gathering.
4054 Set_Etype (Scomp, Etype (Real_Discr));
4055 Set_Analyzed (Scomp, True);
4056 Append_To (Args, Convert_To (Etype (Formal), Scomp));
4058 Next_Formal_With_Extras (Formal);
4059 Next_Discriminant (Discr);
4062 -- Now build and insert the call
4065 Make_Raise_Constraint_Error (Loc,
4067 Make_Function_Call (Loc,
4068 Name => New_Occurrence_Of (Discr_Fct, Loc),
4069 Parameter_Associations => Args),
4070 Reason => CE_Discriminant_Check_Failed));
4071 end Generate_Discriminant_Check;
4073 ----------------------------
4074 -- Generate_Index_Checks --
4075 ----------------------------
4077 procedure Generate_Index_Checks (N : Node_Id) is
4078 Loc : constant Source_Ptr := Sloc (N);
4079 A : constant Node_Id := Prefix (N);
4085 Sub := First (Expressions (N));
4087 while Present (Sub) loop
4088 if Do_Range_Check (Sub) then
4089 Set_Do_Range_Check (Sub, False);
4091 -- Force evaluation except for the case of a simple name of
4092 -- a non-volatile entity.
4094 if not Is_Entity_Name (Sub)
4095 or else Treat_As_Volatile (Entity (Sub))
4097 Force_Evaluation (Sub);
4100 -- Generate a raise of constraint error with the appropriate
4101 -- reason and a condition of the form:
4103 -- Base_Type(Sub) not in array'range (subscript)
4105 -- Note that the reason we generate the conversion to the
4106 -- base type here is that we definitely want the range check
4107 -- to take place, even if it looks like the subtype is OK.
4108 -- Optimization considerations that allow us to omit the
4109 -- check have already been taken into account in the setting
4110 -- of the Do_Range_Check flag earlier on.
4115 Num := New_List (Make_Integer_Literal (Loc, Ind));
4119 Make_Raise_Constraint_Error (Loc,
4123 Convert_To (Base_Type (Etype (Sub)),
4124 Duplicate_Subexpr_Move_Checks (Sub)),
4126 Make_Attribute_Reference (Loc,
4127 Prefix => Duplicate_Subexpr_Move_Checks (A),
4128 Attribute_Name => Name_Range,
4129 Expressions => Num)),
4130 Reason => CE_Index_Check_Failed));
4136 end Generate_Index_Checks;
4138 --------------------------
4139 -- Generate_Range_Check --
4140 --------------------------
4142 procedure Generate_Range_Check
4144 Target_Type : Entity_Id;
4145 Reason : RT_Exception_Code)
4147 Loc : constant Source_Ptr := Sloc (N);
4148 Source_Type : constant Entity_Id := Etype (N);
4149 Source_Base_Type : constant Entity_Id := Base_Type (Source_Type);
4150 Target_Base_Type : constant Entity_Id := Base_Type (Target_Type);
4153 -- First special case, if the source type is already within the
4154 -- range of the target type, then no check is needed (probably we
4155 -- should have stopped Do_Range_Check from being set in the first
4156 -- place, but better late than later in preventing junk code!
4158 -- We do NOT apply this if the source node is a literal, since in
4159 -- this case the literal has already been labeled as having the
4160 -- subtype of the target.
4162 if In_Subrange_Of (Source_Type, Target_Type)
4164 (Nkind (N) = N_Integer_Literal
4166 Nkind (N) = N_Real_Literal
4168 Nkind (N) = N_Character_Literal
4171 and then Ekind (Entity (N)) = E_Enumeration_Literal))
4176 -- We need a check, so force evaluation of the node, so that it does
4177 -- not get evaluated twice (once for the check, once for the actual
4178 -- reference). Such a double evaluation is always a potential source
4179 -- of inefficiency, and is functionally incorrect in the volatile case.
4181 if not Is_Entity_Name (N)
4182 or else Treat_As_Volatile (Entity (N))
4184 Force_Evaluation (N);
4187 -- The easiest case is when Source_Base_Type and Target_Base_Type
4188 -- are the same since in this case we can simply do a direct
4189 -- check of the value of N against the bounds of Target_Type.
4191 -- [constraint_error when N not in Target_Type]
4193 -- Note: this is by far the most common case, for example all cases of
4194 -- checks on the RHS of assignments are in this category, but not all
4195 -- cases are like this. Notably conversions can involve two types.
4197 if Source_Base_Type = Target_Base_Type then
4199 Make_Raise_Constraint_Error (Loc,
4202 Left_Opnd => Duplicate_Subexpr (N),
4203 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
4206 -- Next test for the case where the target type is within the bounds
4207 -- of the base type of the source type, since in this case we can
4208 -- simply convert these bounds to the base type of T to do the test.
4210 -- [constraint_error when N not in
4211 -- Source_Base_Type (Target_Type'First)
4213 -- Source_Base_Type(Target_Type'Last))]
4215 -- The conversions will always work and need no check.
4217 elsif In_Subrange_Of (Target_Type, Source_Base_Type) then
4219 Make_Raise_Constraint_Error (Loc,
4222 Left_Opnd => Duplicate_Subexpr (N),
4227 Convert_To (Source_Base_Type,
4228 Make_Attribute_Reference (Loc,
4230 New_Occurrence_Of (Target_Type, Loc),
4231 Attribute_Name => Name_First)),
4234 Convert_To (Source_Base_Type,
4235 Make_Attribute_Reference (Loc,
4237 New_Occurrence_Of (Target_Type, Loc),
4238 Attribute_Name => Name_Last)))),
4241 -- Note that at this stage we now that the Target_Base_Type is
4242 -- not in the range of the Source_Base_Type (since even the
4243 -- Target_Type itself is not in this range). It could still be
4244 -- the case that the Source_Type is in range of the target base
4245 -- type, since we have not checked that case.
4247 -- If that is the case, we can freely convert the source to the
4248 -- target, and then test the target result against the bounds.
4250 elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
4252 -- We make a temporary to hold the value of the converted
4253 -- value (converted to the base type), and then we will
4254 -- do the test against this temporary.
4256 -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
4257 -- [constraint_error when Tnn not in Target_Type]
4259 -- Then the conversion itself is replaced by an occurrence of Tnn
4262 Tnn : constant Entity_Id :=
4263 Make_Defining_Identifier (Loc,
4264 Chars => New_Internal_Name ('T'));
4267 Insert_Actions (N, New_List (
4268 Make_Object_Declaration (Loc,
4269 Defining_Identifier => Tnn,
4270 Object_Definition =>
4271 New_Occurrence_Of (Target_Base_Type, Loc),
4272 Constant_Present => True,
4274 Make_Type_Conversion (Loc,
4275 Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
4276 Expression => Duplicate_Subexpr (N))),
4278 Make_Raise_Constraint_Error (Loc,
4281 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
4282 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
4284 Reason => Reason)));
4286 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
4289 -- At this stage, we know that we have two scalar types, which are
4290 -- directly convertible, and where neither scalar type has a base
4291 -- range that is in the range of the other scalar type.
4293 -- The only way this can happen is with a signed and unsigned type.
4294 -- So test for these two cases:
4297 -- Case of the source is unsigned and the target is signed
4299 if Is_Unsigned_Type (Source_Base_Type)
4300 and then not Is_Unsigned_Type (Target_Base_Type)
4302 -- If the source is unsigned and the target is signed, then we
4303 -- know that the source is not shorter than the target (otherwise
4304 -- the source base type would be in the target base type range).
4306 -- In other words, the unsigned type is either the same size
4307 -- as the target, or it is larger. It cannot be smaller.
4310 (Esize (Source_Base_Type) >= Esize (Target_Base_Type));
4312 -- We only need to check the low bound if the low bound of the
4313 -- target type is non-negative. If the low bound of the target
4314 -- type is negative, then we know that we will fit fine.
4316 -- If the high bound of the target type is negative, then we
4317 -- know we have a constraint error, since we can't possibly
4318 -- have a negative source.
4320 -- With these two checks out of the way, we can do the check
4321 -- using the source type safely
4323 -- This is definitely the most annoying case!
4325 -- [constraint_error
4326 -- when (Target_Type'First >= 0
4328 -- N < Source_Base_Type (Target_Type'First))
4329 -- or else Target_Type'Last < 0
4330 -- or else N > Source_Base_Type (Target_Type'Last)];
4332 -- We turn off all checks since we know that the conversions
4333 -- will work fine, given the guards for negative values.
4336 Make_Raise_Constraint_Error (Loc,
4342 Left_Opnd => Make_Op_Ge (Loc,
4344 Make_Attribute_Reference (Loc,
4346 New_Occurrence_Of (Target_Type, Loc),
4347 Attribute_Name => Name_First),
4348 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
4352 Left_Opnd => Duplicate_Subexpr (N),
4354 Convert_To (Source_Base_Type,
4355 Make_Attribute_Reference (Loc,
4357 New_Occurrence_Of (Target_Type, Loc),
4358 Attribute_Name => Name_First)))),
4363 Make_Attribute_Reference (Loc,
4364 Prefix => New_Occurrence_Of (Target_Type, Loc),
4365 Attribute_Name => Name_Last),
4366 Right_Opnd => Make_Integer_Literal (Loc, Uint_0))),
4370 Left_Opnd => Duplicate_Subexpr (N),
4372 Convert_To (Source_Base_Type,
4373 Make_Attribute_Reference (Loc,
4374 Prefix => New_Occurrence_Of (Target_Type, Loc),
4375 Attribute_Name => Name_Last)))),
4378 Suppress => All_Checks);
4380 -- Only remaining possibility is that the source is signed and
4381 -- the target is unsigned
4384 pragma Assert (not Is_Unsigned_Type (Source_Base_Type)
4385 and then Is_Unsigned_Type (Target_Base_Type));
4387 -- If the source is signed and the target is unsigned, then
4388 -- we know that the target is not shorter than the source
4389 -- (otherwise the target base type would be in the source
4390 -- base type range).
4392 -- In other words, the unsigned type is either the same size
4393 -- as the target, or it is larger. It cannot be smaller.
4395 -- Clearly we have an error if the source value is negative
4396 -- since no unsigned type can have negative values. If the
4397 -- source type is non-negative, then the check can be done
4398 -- using the target type.
4400 -- Tnn : constant Target_Base_Type (N) := Target_Type;
4402 -- [constraint_error
4403 -- when N < 0 or else Tnn not in Target_Type];
4405 -- We turn off all checks for the conversion of N to the
4406 -- target base type, since we generate the explicit check
4407 -- to ensure that the value is non-negative
4410 Tnn : constant Entity_Id :=
4411 Make_Defining_Identifier (Loc,
4412 Chars => New_Internal_Name ('T'));
4415 Insert_Actions (N, New_List (
4416 Make_Object_Declaration (Loc,
4417 Defining_Identifier => Tnn,
4418 Object_Definition =>
4419 New_Occurrence_Of (Target_Base_Type, Loc),
4420 Constant_Present => True,
4422 Make_Type_Conversion (Loc,
4424 New_Occurrence_Of (Target_Base_Type, Loc),
4425 Expression => Duplicate_Subexpr (N))),
4427 Make_Raise_Constraint_Error (Loc,
4432 Left_Opnd => Duplicate_Subexpr (N),
4433 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
4437 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
4439 New_Occurrence_Of (Target_Type, Loc))),
4442 Suppress => All_Checks);
4444 -- Set the Etype explicitly, because Insert_Actions may
4445 -- have placed the declaration in the freeze list for an
4446 -- enclosing construct, and thus it is not analyzed yet.
4448 Set_Etype (Tnn, Target_Base_Type);
4449 Rewrite (N, New_Occurrence_Of (Tnn, Loc));
4453 end Generate_Range_Check;
4455 ---------------------
4456 -- Get_Discriminal --
4457 ---------------------
4459 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is
4460 Loc : constant Source_Ptr := Sloc (E);
4465 -- The entity E is the type of a private component of the protected
4466 -- type, or the type of a renaming of that component within a protected
4467 -- operation of that type.
4471 if Ekind (Sc) /= E_Protected_Type then
4474 if Ekind (Sc) /= E_Protected_Type then
4479 D := First_Discriminant (Sc);
4482 and then Chars (D) /= Chars (Bound)
4484 Next_Discriminant (D);
4487 return New_Occurrence_Of (Discriminal (D), Loc);
4488 end Get_Discriminal;
4494 function Guard_Access
4497 Ck_Node : Node_Id) return Node_Id
4500 if Nkind (Cond) = N_Or_Else then
4501 Set_Paren_Count (Cond, 1);
4504 if Nkind (Ck_Node) = N_Allocator then
4511 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
4512 Right_Opnd => Make_Null (Loc)),
4513 Right_Opnd => Cond);
4517 -----------------------------
4518 -- Index_Checks_Suppressed --
4519 -----------------------------
4521 function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
4523 if Present (E) and then Checks_May_Be_Suppressed (E) then
4524 return Is_Check_Suppressed (E, Index_Check);
4526 return Scope_Suppress (Index_Check);
4528 end Index_Checks_Suppressed;
4534 procedure Initialize is
4536 for J in Determine_Range_Cache_N'Range loop
4537 Determine_Range_Cache_N (J) := Empty;
4541 -------------------------
4542 -- Insert_Range_Checks --
4543 -------------------------
4545 procedure Insert_Range_Checks
4546 (Checks : Check_Result;
4548 Suppress_Typ : Entity_Id;
4549 Static_Sloc : Source_Ptr := No_Location;
4550 Flag_Node : Node_Id := Empty;
4551 Do_Before : Boolean := False)
4553 Internal_Flag_Node : Node_Id := Flag_Node;
4554 Internal_Static_Sloc : Source_Ptr := Static_Sloc;
4556 Check_Node : Node_Id;
4557 Checks_On : constant Boolean :=
4558 (not Index_Checks_Suppressed (Suppress_Typ))
4560 (not Range_Checks_Suppressed (Suppress_Typ));
4563 -- For now we just return if Checks_On is false, however this should
4564 -- be enhanced to check for an always True value in the condition
4565 -- and to generate a compilation warning???
4567 if not Expander_Active or else not Checks_On then
4571 if Static_Sloc = No_Location then
4572 Internal_Static_Sloc := Sloc (Node);
4575 if No (Flag_Node) then
4576 Internal_Flag_Node := Node;
4579 for J in 1 .. 2 loop
4580 exit when No (Checks (J));
4582 if Nkind (Checks (J)) = N_Raise_Constraint_Error
4583 and then Present (Condition (Checks (J)))
4585 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
4586 Check_Node := Checks (J);
4587 Mark_Rewrite_Insertion (Check_Node);
4590 Insert_Before_And_Analyze (Node, Check_Node);
4592 Insert_After_And_Analyze (Node, Check_Node);
4595 Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
4600 Make_Raise_Constraint_Error (Internal_Static_Sloc,
4601 Reason => CE_Range_Check_Failed);
4602 Mark_Rewrite_Insertion (Check_Node);
4605 Insert_Before_And_Analyze (Node, Check_Node);
4607 Insert_After_And_Analyze (Node, Check_Node);
4611 end Insert_Range_Checks;
4613 ------------------------
4614 -- Insert_Valid_Check --
4615 ------------------------
4617 procedure Insert_Valid_Check (Expr : Node_Id) is
4618 Loc : constant Source_Ptr := Sloc (Expr);
4622 -- Do not insert if checks off, or if not checking validity
4624 if Range_Checks_Suppressed (Etype (Expr))
4625 or else (not Validity_Checks_On)
4630 -- If we have a checked conversion, then validity check applies to
4631 -- the expression inside the conversion, not the result, since if
4632 -- the expression inside is valid, then so is the conversion result.
4635 while Nkind (Exp) = N_Type_Conversion loop
4636 Exp := Expression (Exp);
4639 -- Insert the validity check. Note that we do this with validity
4640 -- checks turned off, to avoid recursion, we do not want validity
4641 -- checks on the validity checking code itself!
4643 Validity_Checks_On := False;
4646 Make_Raise_Constraint_Error (Loc,
4650 Make_Attribute_Reference (Loc,
4652 Duplicate_Subexpr_No_Checks (Exp, Name_Req => True),
4653 Attribute_Name => Name_Valid)),
4654 Reason => CE_Invalid_Data),
4655 Suppress => All_Checks);
4656 Validity_Checks_On := True;
4657 end Insert_Valid_Check;
4659 ----------------------------------
4660 -- Install_Null_Excluding_Check --
4661 ----------------------------------
4663 procedure Install_Null_Excluding_Check (N : Node_Id) is
4664 Loc : constant Source_Ptr := Sloc (N);
4665 Etyp : constant Entity_Id := Etype (N);
4668 pragma Assert (Is_Access_Type (Etyp));
4670 -- Don't need access check if: 1) we are analyzing a generic, 2) it is
4671 -- known to be non-null, or 3) the check was suppressed on the type
4674 or else Access_Checks_Suppressed (Etyp)
4678 -- Otherwise install access check
4682 Make_Raise_Constraint_Error (Loc,
4685 Left_Opnd => Duplicate_Subexpr_Move_Checks (N),
4686 Right_Opnd => Make_Null (Loc)),
4687 Reason => CE_Access_Check_Failed));
4689 end Install_Null_Excluding_Check;
4691 --------------------------
4692 -- Install_Static_Check --
4693 --------------------------
4695 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
4696 Stat : constant Boolean := Is_Static_Expression (R_Cno);
4697 Typ : constant Entity_Id := Etype (R_Cno);
4701 Make_Raise_Constraint_Error (Loc,
4702 Reason => CE_Range_Check_Failed));
4703 Set_Analyzed (R_Cno);
4704 Set_Etype (R_Cno, Typ);
4705 Set_Raises_Constraint_Error (R_Cno);
4706 Set_Is_Static_Expression (R_Cno, Stat);
4707 end Install_Static_Check;
4709 ---------------------
4710 -- Kill_All_Checks --
4711 ---------------------
4713 procedure Kill_All_Checks is
4715 if Debug_Flag_CC then
4716 w ("Kill_All_Checks");
4719 -- We reset the number of saved checks to zero, and also modify
4720 -- all stack entries for statement ranges to indicate that the
4721 -- number of checks at each level is now zero.
4723 Num_Saved_Checks := 0;
4725 for J in 1 .. Saved_Checks_TOS loop
4726 Saved_Checks_Stack (J) := 0;
4728 end Kill_All_Checks;
4734 procedure Kill_Checks (V : Entity_Id) is
4736 if Debug_Flag_CC then
4737 w ("Kill_Checks for entity", Int (V));
4740 for J in 1 .. Num_Saved_Checks loop
4741 if Saved_Checks (J).Entity = V then
4742 if Debug_Flag_CC then
4743 w (" Checks killed for saved check ", J);
4746 Saved_Checks (J).Killed := True;
4751 ------------------------------
4752 -- Length_Checks_Suppressed --
4753 ------------------------------
4755 function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
4757 if Present (E) and then Checks_May_Be_Suppressed (E) then
4758 return Is_Check_Suppressed (E, Length_Check);
4760 return Scope_Suppress (Length_Check);
4762 end Length_Checks_Suppressed;
4764 --------------------------------
4765 -- Overflow_Checks_Suppressed --
4766 --------------------------------
4768 function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
4770 if Present (E) and then Checks_May_Be_Suppressed (E) then
4771 return Is_Check_Suppressed (E, Overflow_Check);
4773 return Scope_Suppress (Overflow_Check);
4775 end Overflow_Checks_Suppressed;
4781 function Range_Check
4783 Target_Typ : Entity_Id;
4784 Source_Typ : Entity_Id := Empty;
4785 Warn_Node : Node_Id := Empty) return Check_Result
4788 return Selected_Range_Checks
4789 (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
4792 -----------------------------
4793 -- Range_Checks_Suppressed --
4794 -----------------------------
4796 function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
4800 -- Note: for now we always suppress range checks on Vax float types,
4801 -- since Gigi does not know how to generate these checks.
4803 if Vax_Float (E) then
4805 elsif Kill_Range_Checks (E) then
4807 elsif Checks_May_Be_Suppressed (E) then
4808 return Is_Check_Suppressed (E, Range_Check);
4812 return Scope_Suppress (Range_Check);
4813 end Range_Checks_Suppressed;
4819 procedure Remove_Checks (Expr : Node_Id) is
4820 Discard : Traverse_Result;
4821 pragma Warnings (Off, Discard);
4823 function Process (N : Node_Id) return Traverse_Result;
4824 -- Process a single node during the traversal
4826 function Traverse is new Traverse_Func (Process);
4827 -- The traversal function itself
4833 function Process (N : Node_Id) return Traverse_Result is
4835 if Nkind (N) not in N_Subexpr then
4839 Set_Do_Range_Check (N, False);
4843 Discard := Traverse (Left_Opnd (N));
4846 when N_Attribute_Reference =>
4847 Set_Do_Overflow_Check (N, False);
4849 when N_Function_Call =>
4850 Set_Do_Tag_Check (N, False);
4853 Set_Do_Overflow_Check (N, False);
4857 Set_Do_Division_Check (N, False);
4860 Set_Do_Length_Check (N, False);
4863 Set_Do_Division_Check (N, False);
4866 Set_Do_Length_Check (N, False);
4869 Set_Do_Division_Check (N, False);
4872 Set_Do_Length_Check (N, False);
4879 Discard := Traverse (Left_Opnd (N));
4882 when N_Selected_Component =>
4883 Set_Do_Discriminant_Check (N, False);
4885 when N_Type_Conversion =>
4886 Set_Do_Length_Check (N, False);
4887 Set_Do_Tag_Check (N, False);
4888 Set_Do_Overflow_Check (N, False);
4897 -- Start of processing for Remove_Checks
4900 Discard := Traverse (Expr);
4903 ----------------------------
4904 -- Selected_Length_Checks --
4905 ----------------------------
4907 function Selected_Length_Checks
4909 Target_Typ : Entity_Id;
4910 Source_Typ : Entity_Id;
4911 Warn_Node : Node_Id) return Check_Result
4913 Loc : constant Source_Ptr := Sloc (Ck_Node);
4916 Expr_Actual : Node_Id;
4918 Cond : Node_Id := Empty;
4919 Do_Access : Boolean := False;
4920 Wnode : Node_Id := Warn_Node;
4921 Ret_Result : Check_Result := (Empty, Empty);
4922 Num_Checks : Natural := 0;
4924 procedure Add_Check (N : Node_Id);
4925 -- Adds the action given to Ret_Result if N is non-Empty
4927 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
4928 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
4929 -- Comments required ???
4931 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
4932 -- True for equal literals and for nodes that denote the same constant
4933 -- entity, even if its value is not a static constant. This includes the
4934 -- case of a discriminal reference within an init proc. Removes some
4935 -- obviously superfluous checks.
4937 function Length_E_Cond
4938 (Exptyp : Entity_Id;
4940 Indx : Nat) return Node_Id;
4941 -- Returns expression to compute:
4942 -- Typ'Length /= Exptyp'Length
4944 function Length_N_Cond
4947 Indx : Nat) return Node_Id;
4948 -- Returns expression to compute:
4949 -- Typ'Length /= Expr'Length
4955 procedure Add_Check (N : Node_Id) is
4959 -- For now, ignore attempt to place more than 2 checks ???
4961 if Num_Checks = 2 then
4965 pragma Assert (Num_Checks <= 1);
4966 Num_Checks := Num_Checks + 1;
4967 Ret_Result (Num_Checks) := N;
4975 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
4976 Pt : constant Entity_Id := Scope (Scope (E));
4978 E1 : Entity_Id := E;
4981 if Ekind (Scope (E)) = E_Record_Type
4982 and then Has_Discriminants (Scope (E))
4984 N := Build_Discriminal_Subtype_Of_Component (E);
4987 Insert_Action (Ck_Node, N);
4988 E1 := Defining_Identifier (N);
4992 if Ekind (E1) = E_String_Literal_Subtype then
4994 Make_Integer_Literal (Loc,
4995 Intval => String_Literal_Length (E1));
4997 elsif Ekind (Pt) = E_Protected_Type
4998 and then Has_Discriminants (Pt)
4999 and then Has_Completion (Pt)
5000 and then not Inside_Init_Proc
5003 -- If the type whose length is needed is a private component
5004 -- constrained by a discriminant, we must expand the 'Length
5005 -- attribute into an explicit computation, using the discriminal
5006 -- of the current protected operation. This is because the actual
5007 -- type of the prival is constructed after the protected opera-
5008 -- tion has been fully expanded.
5011 Indx_Type : Node_Id;
5014 Do_Expand : Boolean := False;
5017 Indx_Type := First_Index (E);
5019 for J in 1 .. Indx - 1 loop
5020 Next_Index (Indx_Type);
5023 Get_Index_Bounds (Indx_Type, Lo, Hi);
5025 if Nkind (Lo) = N_Identifier
5026 and then Ekind (Entity (Lo)) = E_In_Parameter
5028 Lo := Get_Discriminal (E, Lo);
5032 if Nkind (Hi) = N_Identifier
5033 and then Ekind (Entity (Hi)) = E_In_Parameter
5035 Hi := Get_Discriminal (E, Hi);
5040 if not Is_Entity_Name (Lo) then
5041 Lo := Duplicate_Subexpr_No_Checks (Lo);
5044 if not Is_Entity_Name (Hi) then
5045 Lo := Duplicate_Subexpr_No_Checks (Hi);
5051 Make_Op_Subtract (Loc,
5055 Right_Opnd => Make_Integer_Literal (Loc, 1));
5060 Make_Attribute_Reference (Loc,
5061 Attribute_Name => Name_Length,
5063 New_Occurrence_Of (E1, Loc));
5066 Set_Expressions (N, New_List (
5067 Make_Integer_Literal (Loc, Indx)));
5076 Make_Attribute_Reference (Loc,
5077 Attribute_Name => Name_Length,
5079 New_Occurrence_Of (E1, Loc));
5082 Set_Expressions (N, New_List (
5083 Make_Integer_Literal (Loc, Indx)));
5095 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is
5098 Make_Attribute_Reference (Loc,
5099 Attribute_Name => Name_Length,
5101 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
5102 Expressions => New_List (
5103 Make_Integer_Literal (Loc, Indx)));
5111 function Length_E_Cond
5112 (Exptyp : Entity_Id;
5114 Indx : Nat) return Node_Id
5119 Left_Opnd => Get_E_Length (Typ, Indx),
5120 Right_Opnd => Get_E_Length (Exptyp, Indx));
5128 function Length_N_Cond
5131 Indx : Nat) return Node_Id
5136 Left_Opnd => Get_E_Length (Typ, Indx),
5137 Right_Opnd => Get_N_Length (Expr, Indx));
5141 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is
5144 (Nkind (L) = N_Integer_Literal
5145 and then Nkind (R) = N_Integer_Literal
5146 and then Intval (L) = Intval (R))
5150 and then Ekind (Entity (L)) = E_Constant
5151 and then ((Is_Entity_Name (R)
5152 and then Entity (L) = Entity (R))
5154 (Nkind (R) = N_Type_Conversion
5155 and then Is_Entity_Name (Expression (R))
5156 and then Entity (L) = Entity (Expression (R)))))
5160 and then Ekind (Entity (R)) = E_Constant
5161 and then Nkind (L) = N_Type_Conversion
5162 and then Is_Entity_Name (Expression (L))
5163 and then Entity (R) = Entity (Expression (L)))
5167 and then Is_Entity_Name (R)
5168 and then Entity (L) = Entity (R)
5169 and then Ekind (Entity (L)) = E_In_Parameter
5170 and then Inside_Init_Proc);
5173 -- Start of processing for Selected_Length_Checks
5176 if not Expander_Active then
5180 if Target_Typ = Any_Type
5181 or else Target_Typ = Any_Composite
5182 or else Raises_Constraint_Error (Ck_Node)
5191 T_Typ := Target_Typ;
5193 if No (Source_Typ) then
5194 S_Typ := Etype (Ck_Node);
5196 S_Typ := Source_Typ;
5199 if S_Typ = Any_Type or else S_Typ = Any_Composite then
5203 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
5204 S_Typ := Designated_Type (S_Typ);
5205 T_Typ := Designated_Type (T_Typ);
5208 -- A simple optimization
5210 if Nkind (Ck_Node) = N_Null then
5215 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
5216 if Is_Constrained (T_Typ) then
5218 -- The checking code to be generated will freeze the
5219 -- corresponding array type. However, we must freeze the
5220 -- type now, so that the freeze node does not appear within
5221 -- the generated condional expression, but ahead of it.
5223 Freeze_Before (Ck_Node, T_Typ);
5225 Expr_Actual := Get_Referenced_Object (Ck_Node);
5226 Exptyp := Get_Actual_Subtype (Expr_Actual);
5228 if Is_Access_Type (Exptyp) then
5229 Exptyp := Designated_Type (Exptyp);
5232 -- String_Literal case. This needs to be handled specially be-
5233 -- cause no index types are available for string literals. The
5234 -- condition is simply:
5236 -- T_Typ'Length = string-literal-length
5238 if Nkind (Expr_Actual) = N_String_Literal
5239 and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype
5243 Left_Opnd => Get_E_Length (T_Typ, 1),
5245 Make_Integer_Literal (Loc,
5247 String_Literal_Length (Etype (Expr_Actual))));
5249 -- General array case. Here we have a usable actual subtype for
5250 -- the expression, and the condition is built from the two types
5253 -- T_Typ'Length /= Exptyp'Length or else
5254 -- T_Typ'Length (2) /= Exptyp'Length (2) or else
5255 -- T_Typ'Length (3) /= Exptyp'Length (3) or else
5258 elsif Is_Constrained (Exptyp) then
5260 Ndims : constant Nat := Number_Dimensions (T_Typ);
5274 -- At the library level, we need to ensure that the
5275 -- type of the object is elaborated before the check
5276 -- itself is emitted. This is only done if the object
5277 -- is in the current compilation unit, otherwise the
5278 -- type is frozen and elaborated in its unit.
5280 if Is_Itype (Exptyp)
5282 Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package
5284 not In_Package_Body (Cunit_Entity (Current_Sem_Unit))
5285 and then In_Open_Scopes (Scope (Exptyp))
5287 Ref_Node := Make_Itype_Reference (Sloc (Ck_Node));
5288 Set_Itype (Ref_Node, Exptyp);
5289 Insert_Action (Ck_Node, Ref_Node);
5292 L_Index := First_Index (T_Typ);
5293 R_Index := First_Index (Exptyp);
5295 for Indx in 1 .. Ndims loop
5296 if not (Nkind (L_Index) = N_Raise_Constraint_Error
5298 Nkind (R_Index) = N_Raise_Constraint_Error)
5300 Get_Index_Bounds (L_Index, L_Low, L_High);
5301 Get_Index_Bounds (R_Index, R_Low, R_High);
5303 -- Deal with compile time length check. Note that we
5304 -- skip this in the access case, because the access
5305 -- value may be null, so we cannot know statically.
5308 and then Compile_Time_Known_Value (L_Low)
5309 and then Compile_Time_Known_Value (L_High)
5310 and then Compile_Time_Known_Value (R_Low)
5311 and then Compile_Time_Known_Value (R_High)
5313 if Expr_Value (L_High) >= Expr_Value (L_Low) then
5314 L_Length := Expr_Value (L_High) -
5315 Expr_Value (L_Low) + 1;
5317 L_Length := UI_From_Int (0);
5320 if Expr_Value (R_High) >= Expr_Value (R_Low) then
5321 R_Length := Expr_Value (R_High) -
5322 Expr_Value (R_Low) + 1;
5324 R_Length := UI_From_Int (0);
5327 if L_Length > R_Length then
5329 (Compile_Time_Constraint_Error
5330 (Wnode, "too few elements for}?", T_Typ));
5332 elsif L_Length < R_Length then
5334 (Compile_Time_Constraint_Error
5335 (Wnode, "too many elements for}?", T_Typ));
5338 -- The comparison for an individual index subtype
5339 -- is omitted if the corresponding index subtypes
5340 -- statically match, since the result is known to
5341 -- be true. Note that this test is worth while even
5342 -- though we do static evaluation, because non-static
5343 -- subtypes can statically match.
5346 Subtypes_Statically_Match
5347 (Etype (L_Index), Etype (R_Index))
5350 (Same_Bounds (L_Low, R_Low)
5351 and then Same_Bounds (L_High, R_High))
5354 (Cond, Length_E_Cond (Exptyp, T_Typ, Indx));
5363 -- Handle cases where we do not get a usable actual subtype that
5364 -- is constrained. This happens for example in the function call
5365 -- and explicit dereference cases. In these cases, we have to get
5366 -- the length or range from the expression itself, making sure we
5367 -- do not evaluate it more than once.
5369 -- Here Ck_Node is the original expression, or more properly the
5370 -- result of applying Duplicate_Expr to the original tree,
5371 -- forcing the result to be a name.
5375 Ndims : constant Nat := Number_Dimensions (T_Typ);
5378 -- Build the condition for the explicit dereference case
5380 for Indx in 1 .. Ndims loop
5382 (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx));
5389 -- Construct the test and insert into the tree
5391 if Present (Cond) then
5393 Cond := Guard_Access (Cond, Loc, Ck_Node);
5397 (Make_Raise_Constraint_Error (Loc,
5399 Reason => CE_Length_Check_Failed));
5403 end Selected_Length_Checks;
5405 ---------------------------
5406 -- Selected_Range_Checks --
5407 ---------------------------
5409 function Selected_Range_Checks
5411 Target_Typ : Entity_Id;
5412 Source_Typ : Entity_Id;
5413 Warn_Node : Node_Id) return Check_Result
5415 Loc : constant Source_Ptr := Sloc (Ck_Node);
5418 Expr_Actual : Node_Id;
5420 Cond : Node_Id := Empty;
5421 Do_Access : Boolean := False;
5422 Wnode : Node_Id := Warn_Node;
5423 Ret_Result : Check_Result := (Empty, Empty);
5424 Num_Checks : Integer := 0;
5426 procedure Add_Check (N : Node_Id);
5427 -- Adds the action given to Ret_Result if N is non-Empty
5429 function Discrete_Range_Cond
5431 Typ : Entity_Id) return Node_Id;
5432 -- Returns expression to compute:
5433 -- Low_Bound (Expr) < Typ'First
5435 -- High_Bound (Expr) > Typ'Last
5437 function Discrete_Expr_Cond
5439 Typ : Entity_Id) return Node_Id;
5440 -- Returns expression to compute:
5445 function Get_E_First_Or_Last
5448 Nam : Name_Id) return Node_Id;
5449 -- Returns expression to compute:
5450 -- E'First or E'Last
5452 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
5453 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id;
5454 -- Returns expression to compute:
5455 -- N'First or N'Last using Duplicate_Subexpr_No_Checks
5457 function Range_E_Cond
5458 (Exptyp : Entity_Id;
5462 -- Returns expression to compute:
5463 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
5465 function Range_Equal_E_Cond
5466 (Exptyp : Entity_Id;
5468 Indx : Nat) return Node_Id;
5469 -- Returns expression to compute:
5470 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
5472 function Range_N_Cond
5475 Indx : Nat) return Node_Id;
5476 -- Return expression to compute:
5477 -- Expr'First < Typ'First or else Expr'Last > Typ'Last
5483 procedure Add_Check (N : Node_Id) is
5487 -- For now, ignore attempt to place more than 2 checks ???
5489 if Num_Checks = 2 then
5493 pragma Assert (Num_Checks <= 1);
5494 Num_Checks := Num_Checks + 1;
5495 Ret_Result (Num_Checks) := N;
5499 -------------------------
5500 -- Discrete_Expr_Cond --
5501 -------------------------
5503 function Discrete_Expr_Cond
5505 Typ : Entity_Id) return Node_Id
5513 Convert_To (Base_Type (Typ),
5514 Duplicate_Subexpr_No_Checks (Expr)),
5516 Convert_To (Base_Type (Typ),
5517 Get_E_First_Or_Last (Typ, 0, Name_First))),
5522 Convert_To (Base_Type (Typ),
5523 Duplicate_Subexpr_No_Checks (Expr)),
5527 Get_E_First_Or_Last (Typ, 0, Name_Last))));
5528 end Discrete_Expr_Cond;
5530 -------------------------
5531 -- Discrete_Range_Cond --
5532 -------------------------
5534 function Discrete_Range_Cond
5536 Typ : Entity_Id) return Node_Id
5538 LB : Node_Id := Low_Bound (Expr);
5539 HB : Node_Id := High_Bound (Expr);
5541 Left_Opnd : Node_Id;
5542 Right_Opnd : Node_Id;
5545 if Nkind (LB) = N_Identifier
5546 and then Ekind (Entity (LB)) = E_Discriminant then
5547 LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
5550 if Nkind (HB) = N_Identifier
5551 and then Ekind (Entity (HB)) = E_Discriminant then
5552 HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
5559 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)),
5563 (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First)));
5565 if Base_Type (Typ) = Typ then
5568 elsif Compile_Time_Known_Value (High_Bound (Scalar_Range (Typ)))
5570 Compile_Time_Known_Value (High_Bound (Scalar_Range
5573 if Is_Floating_Point_Type (Typ) then
5574 if Expr_Value_R (High_Bound (Scalar_Range (Typ))) =
5575 Expr_Value_R (High_Bound (Scalar_Range (Base_Type (Typ))))
5581 if Expr_Value (High_Bound (Scalar_Range (Typ))) =
5582 Expr_Value (High_Bound (Scalar_Range (Base_Type (Typ))))
5593 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)),
5598 Get_E_First_Or_Last (Typ, 0, Name_Last)));
5600 return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
5601 end Discrete_Range_Cond;
5603 -------------------------
5604 -- Get_E_First_Or_Last --
5605 -------------------------
5607 function Get_E_First_Or_Last
5610 Nam : Name_Id) return Node_Id
5618 if Is_Array_Type (E) then
5619 N := First_Index (E);
5621 for J in 2 .. Indx loop
5626 N := Scalar_Range (E);
5629 if Nkind (N) = N_Subtype_Indication then
5630 LB := Low_Bound (Range_Expression (Constraint (N)));
5631 HB := High_Bound (Range_Expression (Constraint (N)));
5633 elsif Is_Entity_Name (N) then
5634 LB := Type_Low_Bound (Etype (N));
5635 HB := Type_High_Bound (Etype (N));
5638 LB := Low_Bound (N);
5639 HB := High_Bound (N);
5642 if Nam = Name_First then
5648 if Nkind (Bound) = N_Identifier
5649 and then Ekind (Entity (Bound)) = E_Discriminant
5651 -- If this is a task discriminant, and we are the body, we must
5652 -- retrieve the corresponding body discriminal. This is another
5653 -- consequence of the early creation of discriminals, and the
5654 -- need to generate constraint checks before their declarations
5655 -- are made visible.
5657 if Is_Concurrent_Record_Type (Scope (Entity (Bound))) then
5659 Tsk : constant Entity_Id :=
5660 Corresponding_Concurrent_Type
5661 (Scope (Entity (Bound)));
5665 if In_Open_Scopes (Tsk)
5666 and then Has_Completion (Tsk)
5668 -- Find discriminant of original task, and use its
5669 -- current discriminal, which is the renaming within
5672 Disc := First_Discriminant (Tsk);
5673 while Present (Disc) loop
5674 if Chars (Disc) = Chars (Entity (Bound)) then
5675 Set_Scope (Discriminal (Disc), Tsk);
5676 return New_Occurrence_Of (Discriminal (Disc), Loc);
5679 Next_Discriminant (Disc);
5682 -- That loop should always succeed in finding a matching
5683 -- entry and returning. Fatal error if not.
5685 raise Program_Error;
5689 New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
5693 return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
5696 elsif Nkind (Bound) = N_Identifier
5697 and then Ekind (Entity (Bound)) = E_In_Parameter
5698 and then not Inside_Init_Proc
5700 return Get_Discriminal (E, Bound);
5702 elsif Nkind (Bound) = N_Integer_Literal then
5703 return Make_Integer_Literal (Loc, Intval (Bound));
5706 return Duplicate_Subexpr_No_Checks (Bound);
5708 end Get_E_First_Or_Last;
5714 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is
5717 Make_Attribute_Reference (Loc,
5718 Attribute_Name => Name_First,
5720 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
5721 Expressions => New_List (
5722 Make_Integer_Literal (Loc, Indx)));
5729 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is
5732 Make_Attribute_Reference (Loc,
5733 Attribute_Name => Name_Last,
5735 Duplicate_Subexpr_No_Checks (N, Name_Req => True),
5736 Expressions => New_List (
5737 Make_Integer_Literal (Loc, Indx)));
5744 function Range_E_Cond
5745 (Exptyp : Entity_Id;
5747 Indx : Nat) return Node_Id
5754 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
5755 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
5759 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
5760 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
5764 ------------------------
5765 -- Range_Equal_E_Cond --
5766 ------------------------
5768 function Range_Equal_E_Cond
5769 (Exptyp : Entity_Id;
5771 Indx : Nat) return Node_Id
5778 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
5779 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
5782 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
5783 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
5784 end Range_Equal_E_Cond;
5790 function Range_N_Cond
5793 Indx : Nat) return Node_Id
5800 Left_Opnd => Get_N_First (Expr, Indx),
5801 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
5805 Left_Opnd => Get_N_Last (Expr, Indx),
5806 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
5809 -- Start of processing for Selected_Range_Checks
5812 if not Expander_Active then
5816 if Target_Typ = Any_Type
5817 or else Target_Typ = Any_Composite
5818 or else Raises_Constraint_Error (Ck_Node)
5827 T_Typ := Target_Typ;
5829 if No (Source_Typ) then
5830 S_Typ := Etype (Ck_Node);
5832 S_Typ := Source_Typ;
5835 if S_Typ = Any_Type or else S_Typ = Any_Composite then
5839 -- The order of evaluating T_Typ before S_Typ seems to be critical
5840 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed
5841 -- in, and since Node can be an N_Range node, it might be invalid.
5842 -- Should there be an assert check somewhere for taking the Etype of
5843 -- an N_Range node ???
5845 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
5846 S_Typ := Designated_Type (S_Typ);
5847 T_Typ := Designated_Type (T_Typ);
5850 -- A simple optimization
5852 if Nkind (Ck_Node) = N_Null then
5857 -- For an N_Range Node, check for a null range and then if not
5858 -- null generate a range check action.
5860 if Nkind (Ck_Node) = N_Range then
5862 -- There's no point in checking a range against itself
5864 if Ck_Node = Scalar_Range (T_Typ) then
5869 T_LB : constant Node_Id := Type_Low_Bound (T_Typ);
5870 T_HB : constant Node_Id := Type_High_Bound (T_Typ);
5871 LB : constant Node_Id := Low_Bound (Ck_Node);
5872 HB : constant Node_Id := High_Bound (Ck_Node);
5873 Null_Range : Boolean;
5875 Out_Of_Range_L : Boolean;
5876 Out_Of_Range_H : Boolean;
5879 -- Check for case where everything is static and we can
5880 -- do the check at compile time. This is skipped if we
5881 -- have an access type, since the access value may be null.
5883 -- ??? This code can be improved since you only need to know
5884 -- that the two respective bounds (LB & T_LB or HB & T_HB)
5885 -- are known at compile time to emit pertinent messages.
5887 if Compile_Time_Known_Value (LB)
5888 and then Compile_Time_Known_Value (HB)
5889 and then Compile_Time_Known_Value (T_LB)
5890 and then Compile_Time_Known_Value (T_HB)
5891 and then not Do_Access
5893 -- Floating-point case
5895 if Is_Floating_Point_Type (S_Typ) then
5896 Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
5898 (Expr_Value_R (LB) < Expr_Value_R (T_LB))
5900 (Expr_Value_R (LB) > Expr_Value_R (T_HB));
5903 (Expr_Value_R (HB) > Expr_Value_R (T_HB))
5905 (Expr_Value_R (HB) < Expr_Value_R (T_LB));
5907 -- Fixed or discrete type case
5910 Null_Range := Expr_Value (HB) < Expr_Value (LB);
5912 (Expr_Value (LB) < Expr_Value (T_LB))
5914 (Expr_Value (LB) > Expr_Value (T_HB));
5917 (Expr_Value (HB) > Expr_Value (T_HB))
5919 (Expr_Value (HB) < Expr_Value (T_LB));
5922 if not Null_Range then
5923 if Out_Of_Range_L then
5924 if No (Warn_Node) then
5926 (Compile_Time_Constraint_Error
5927 (Low_Bound (Ck_Node),
5928 "static value out of range of}?", T_Typ));
5932 (Compile_Time_Constraint_Error
5934 "static range out of bounds of}?", T_Typ));
5938 if Out_Of_Range_H then
5939 if No (Warn_Node) then
5941 (Compile_Time_Constraint_Error
5942 (High_Bound (Ck_Node),
5943 "static value out of range of}?", T_Typ));
5947 (Compile_Time_Constraint_Error
5949 "static range out of bounds of}?", T_Typ));
5957 LB : Node_Id := Low_Bound (Ck_Node);
5958 HB : Node_Id := High_Bound (Ck_Node);
5962 -- If either bound is a discriminant and we are within
5963 -- the record declaration, it is a use of the discriminant
5964 -- in a constraint of a component, and nothing can be
5965 -- checked here. The check will be emitted within the
5966 -- init proc. Before then, the discriminal has no real
5969 if Nkind (LB) = N_Identifier
5970 and then Ekind (Entity (LB)) = E_Discriminant
5972 if Current_Scope = Scope (Entity (LB)) then
5976 New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
5980 if Nkind (HB) = N_Identifier
5981 and then Ekind (Entity (HB)) = E_Discriminant
5983 if Current_Scope = Scope (Entity (HB)) then
5987 New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
5991 Cond := Discrete_Range_Cond (Ck_Node, T_Typ);
5992 Set_Paren_Count (Cond, 1);
5998 Left_Opnd => Duplicate_Subexpr_No_Checks (HB),
5999 Right_Opnd => Duplicate_Subexpr_No_Checks (LB)),
6000 Right_Opnd => Cond);
6006 elsif Is_Scalar_Type (S_Typ) then
6008 -- This somewhat duplicates what Apply_Scalar_Range_Check does,
6009 -- except the above simply sets a flag in the node and lets
6010 -- gigi generate the check base on the Etype of the expression.
6011 -- Sometimes, however we want to do a dynamic check against an
6012 -- arbitrary target type, so we do that here.
6014 if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then
6015 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
6017 -- For literals, we can tell if the constraint error will be
6018 -- raised at compile time, so we never need a dynamic check, but
6019 -- if the exception will be raised, then post the usual warning,
6020 -- and replace the literal with a raise constraint error
6021 -- expression. As usual, skip this for access types
6023 elsif Compile_Time_Known_Value (Ck_Node)
6024 and then not Do_Access
6027 LB : constant Node_Id := Type_Low_Bound (T_Typ);
6028 UB : constant Node_Id := Type_High_Bound (T_Typ);
6030 Out_Of_Range : Boolean;
6031 Static_Bounds : constant Boolean :=
6032 Compile_Time_Known_Value (LB)
6033 and Compile_Time_Known_Value (UB);
6036 -- Following range tests should use Sem_Eval routine ???
6038 if Static_Bounds then
6039 if Is_Floating_Point_Type (S_Typ) then
6041 (Expr_Value_R (Ck_Node) < Expr_Value_R (LB))
6043 (Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
6045 else -- fixed or discrete type
6047 Expr_Value (Ck_Node) < Expr_Value (LB)
6049 Expr_Value (Ck_Node) > Expr_Value (UB);
6052 -- Bounds of the type are static and the literal is
6053 -- out of range so make a warning message.
6055 if Out_Of_Range then
6056 if No (Warn_Node) then
6058 (Compile_Time_Constraint_Error
6060 "static value out of range of}?", T_Typ));
6064 (Compile_Time_Constraint_Error
6066 "static value out of range of}?", T_Typ));
6071 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
6075 -- Here for the case of a non-static expression, we need a runtime
6076 -- check unless the source type range is guaranteed to be in the
6077 -- range of the target type.
6080 if not In_Subrange_Of (S_Typ, T_Typ) then
6081 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
6086 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
6087 if Is_Constrained (T_Typ) then
6089 Expr_Actual := Get_Referenced_Object (Ck_Node);
6090 Exptyp := Get_Actual_Subtype (Expr_Actual);
6092 if Is_Access_Type (Exptyp) then
6093 Exptyp := Designated_Type (Exptyp);
6096 -- String_Literal case. This needs to be handled specially be-
6097 -- cause no index types are available for string literals. The
6098 -- condition is simply:
6100 -- T_Typ'Length = string-literal-length
6102 if Nkind (Expr_Actual) = N_String_Literal then
6105 -- General array case. Here we have a usable actual subtype for
6106 -- the expression, and the condition is built from the two types
6108 -- T_Typ'First < Exptyp'First or else
6109 -- T_Typ'Last > Exptyp'Last or else
6110 -- T_Typ'First(1) < Exptyp'First(1) or else
6111 -- T_Typ'Last(1) > Exptyp'Last(1) or else
6114 elsif Is_Constrained (Exptyp) then
6116 Ndims : constant Nat := Number_Dimensions (T_Typ);
6126 L_Index := First_Index (T_Typ);
6127 R_Index := First_Index (Exptyp);
6129 for Indx in 1 .. Ndims loop
6130 if not (Nkind (L_Index) = N_Raise_Constraint_Error
6132 Nkind (R_Index) = N_Raise_Constraint_Error)
6134 Get_Index_Bounds (L_Index, L_Low, L_High);
6135 Get_Index_Bounds (R_Index, R_Low, R_High);
6137 -- Deal with compile time length check. Note that we
6138 -- skip this in the access case, because the access
6139 -- value may be null, so we cannot know statically.
6142 Subtypes_Statically_Match
6143 (Etype (L_Index), Etype (R_Index))
6145 -- If the target type is constrained then we
6146 -- have to check for exact equality of bounds
6147 -- (required for qualified expressions).
6149 if Is_Constrained (T_Typ) then
6152 Range_Equal_E_Cond (Exptyp, T_Typ, Indx));
6156 (Cond, Range_E_Cond (Exptyp, T_Typ, Indx));
6167 -- Handle cases where we do not get a usable actual subtype that
6168 -- is constrained. This happens for example in the function call
6169 -- and explicit dereference cases. In these cases, we have to get
6170 -- the length or range from the expression itself, making sure we
6171 -- do not evaluate it more than once.
6173 -- Here Ck_Node is the original expression, or more properly the
6174 -- result of applying Duplicate_Expr to the original tree,
6175 -- forcing the result to be a name.
6179 Ndims : constant Nat := Number_Dimensions (T_Typ);
6182 -- Build the condition for the explicit dereference case
6184 for Indx in 1 .. Ndims loop
6186 (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
6193 -- Generate an Action to check that the bounds of the
6194 -- source value are within the constraints imposed by the
6195 -- target type for a conversion to an unconstrained type.
6198 if Nkind (Parent (Ck_Node)) = N_Type_Conversion then
6200 Opnd_Index : Node_Id;
6201 Targ_Index : Node_Id;
6205 := First_Index (Get_Actual_Subtype (Ck_Node));
6206 Targ_Index := First_Index (T_Typ);
6208 while Opnd_Index /= Empty loop
6209 if Nkind (Opnd_Index) = N_Range then
6211 (Low_Bound (Opnd_Index), Etype (Targ_Index))
6214 (High_Bound (Opnd_Index), Etype (Targ_Index))
6218 -- If null range, no check needed.
6220 Compile_Time_Known_Value (High_Bound (Opnd_Index))
6222 Compile_Time_Known_Value (Low_Bound (Opnd_Index))
6224 Expr_Value (High_Bound (Opnd_Index)) <
6225 Expr_Value (Low_Bound (Opnd_Index))
6229 elsif Is_Out_Of_Range
6230 (Low_Bound (Opnd_Index), Etype (Targ_Index))
6233 (High_Bound (Opnd_Index), Etype (Targ_Index))
6236 (Compile_Time_Constraint_Error
6237 (Wnode, "value out of range of}?", T_Typ));
6243 (Opnd_Index, Etype (Targ_Index)));
6247 Next_Index (Opnd_Index);
6248 Next_Index (Targ_Index);
6255 -- Construct the test and insert into the tree
6257 if Present (Cond) then
6259 Cond := Guard_Access (Cond, Loc, Ck_Node);
6263 (Make_Raise_Constraint_Error (Loc,
6265 Reason => CE_Range_Check_Failed));
6269 end Selected_Range_Checks;
6271 -------------------------------
6272 -- Storage_Checks_Suppressed --
6273 -------------------------------
6275 function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is
6277 if Present (E) and then Checks_May_Be_Suppressed (E) then
6278 return Is_Check_Suppressed (E, Storage_Check);
6280 return Scope_Suppress (Storage_Check);
6282 end Storage_Checks_Suppressed;
6284 ---------------------------
6285 -- Tag_Checks_Suppressed --
6286 ---------------------------
6288 function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
6291 if Kill_Tag_Checks (E) then
6293 elsif Checks_May_Be_Suppressed (E) then
6294 return Is_Check_Suppressed (E, Tag_Check);
6298 return Scope_Suppress (Tag_Check);
6299 end Tag_Checks_Suppressed;